Taylor Bockman
9 years ago
158 changed files with 64 additions and 59367 deletions
@ -1 +1 @@ |
|||||||
Good signature from 474F05837FBDEF9B GNU ELPA Signing Agent <elpasign@elpa.gnu.org> (trust undefined) created at 2015-10-23T02:05:01-0700 using DSA |
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
@ -1,130 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,150 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,106 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,225 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,157 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,164 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,112 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,309 +0,0 @@ |
|||||||
;;; 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
@ -1,208 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,12 +0,0 @@ |
|||||||
(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: |
|
||||||
@ -1,122 +0,0 @@ |
|||||||
;;; 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
@ -1,129 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,71 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,154 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,610 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,499 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,383 +0,0 @@ |
|||||||
;;; 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
@ -1 +0,0 @@ |
|||||||
(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") |
|
||||||
@ -1,205 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,11 +0,0 @@ |
|||||||
(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: |
|
||||||
@ -1,209 +0,0 @@ |
|||||||
-- 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 |
|
||||||
@ -1,48 +0,0 @@ |
|||||||
-- 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 [] |
|
||||||
@ -1 +0,0 @@ |
|||||||
(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")) |
|
||||||
@ -1,61 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1 +0,0 @@ |
|||||||
(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")) |
|
||||||
@ -1,121 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1 +0,0 @@ |
|||||||
(define-package "gitignore-mode" "20150330.1048" "Major mode for editing .gitignore files" 'nil :url "https://github.com/magit/git-modes" :keywords '("convenience" "vc" "git")) |
|
||||||
@ -1,61 +0,0 @@ |
|||||||
;;; 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.
@ -1,438 +0,0 @@ |
|||||||
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>. |
|
||||||
@ -1,125 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,68 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,231 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,974 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,184 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,65 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,944 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,70 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,163 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,133 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,266 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,429 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,744 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,619 +0,0 @@ |
|||||||
;;; 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
@ -1,589 +0,0 @@ |
|||||||
;;; 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
@ -1,223 +0,0 @@ |
|||||||
;;; 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 |
|
||||||
@ -1,529 +0,0 @@ |
|||||||
;;; 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) |
|
||||||
@ -1,159 +0,0 @@ |
|||||||
;;; 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
@ -1,5 +0,0 @@ |
|||||||
(define-package "haskell-mode" "20151022.340" "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
@ -1,114 +0,0 @@ |
|||||||
;;; haskell-modules.el --- -*- 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-sort-imports) |
|
||||||
(require 'haskell-align-imports) |
|
||||||
(require 'haskell-session) |
|
||||||
(require 'haskell-navigate-imports) |
|
||||||
(require 'haskell-complete-module) |
|
||||||
(require 'haskell-sandbox) |
|
||||||
|
|
||||||
(defun haskell-add-import (&optional module) |
|
||||||
"Add an import to the import list." |
|
||||||
(interactive) |
|
||||||
(save-excursion |
|
||||||
(goto-char (point-max)) |
|
||||||
(haskell-navigate-imports) |
|
||||||
(insert (haskell-import-for-module |
|
||||||
(or module |
|
||||||
(haskell-complete-module-read |
|
||||||
"Module: " |
|
||||||
(haskell-session-all-modules (haskell-modules-session)))))) |
|
||||||
(haskell-sort-imports) |
|
||||||
(haskell-align-imports))) |
|
||||||
|
|
||||||
(defun haskell-import-for-module (module) |
|
||||||
"Get import statements for the given module." |
|
||||||
(let ((mapping (assoc module haskell-import-mapping))) |
|
||||||
(if mapping |
|
||||||
(cdr mapping) |
|
||||||
(concat (read-from-minibuffer "Import line: " |
|
||||||
(format "import %s" module)) |
|
||||||
"\n")))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-installed-modules (_session &optional _dontcreate) |
|
||||||
"Get the modules installed in the current package set." |
|
||||||
;; TODO: Again, this makes HEAVY use of unix utilities. It'll work |
|
||||||
;; fine in Linux, probably okay on OS X, and probably not at all on |
|
||||||
;; Windows. Again, if someone wants to test on Windows and come up |
|
||||||
;; with alternatives that's OK. |
|
||||||
;; |
|
||||||
;; Ideally all these package queries can be provided by a Haskell |
|
||||||
;; program based on the Cabal API. Possibly as a nice service. Such |
|
||||||
;; a service could cache and do nice things like that. For now, this |
|
||||||
;; simple shell script takes us far. |
|
||||||
;; |
|
||||||
;; Probably also we can take the code from inferior-haskell-mode. |
|
||||||
;; |
|
||||||
;; Ugliness aside, if it saves us time to type it's a winner. |
|
||||||
;; |
|
||||||
;; FIXME/TODO: add support for (eq 'cabal-repl (haskell-process-type)) |
|
||||||
(let ((session (haskell-session-maybe))) |
|
||||||
(when session |
|
||||||
(let ((modules (shell-command-to-string |
|
||||||
(format "%s | %s | %s" |
|
||||||
(cond |
|
||||||
((haskell-sandbox-exists-p session) |
|
||||||
(concat "ghc-pkg dump -f " |
|
||||||
(shell-quote-argument (haskell-sandbox-pkgdb session)))) |
|
||||||
(t "ghc-pkg dump")) |
|
||||||
"egrep '^(exposed-modules: | )[A-Z]'" |
|
||||||
"cut -c18-")))) |
|
||||||
(split-string modules))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-all-modules (session &optional dontcreate) |
|
||||||
"Get all modules -- installed or in the current project. |
|
||||||
If DONTCREATE is non-nil don't create a new session." |
|
||||||
(append (haskell-session-installed-modules session dontcreate) |
|
||||||
(haskell-session-project-modules session dontcreate))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-project-modules (session &optional dontcreate) |
|
||||||
"Get the modules of the current project. |
|
||||||
If DONTCREATE is non-nil don't create a new session." |
|
||||||
(if (or (not dontcreate) (haskell-session-maybe)) |
|
||||||
(let* ((modules |
|
||||||
(shell-command-to-string |
|
||||||
(format "%s && %s" |
|
||||||
(format "cd %s" (haskell-session-cabal-dir session)) |
|
||||||
;; TODO: Use a different, better source. Possibly hasktags or some such. |
|
||||||
;; TODO: At least make it cross-platform. Linux |
|
||||||
;; (and possibly OS X) have egrep, Windows |
|
||||||
;; doesn't -- or does it via Cygwin or MinGW? |
|
||||||
;; This also doesn't handle module\nName. But those gits can just cut it out! |
|
||||||
"egrep '^module[\t\r ]+[^(\t\r ]+' . -r -I --include='*.*hs' --include='*.hsc' -s -o -h | sed 's/^module[\t\r ]*//' | sort | uniq")))) |
|
||||||
(split-string modules)))) |
|
||||||
|
|
||||||
(defun haskell-modules-session () |
|
||||||
"Get the `haskell-session', throw an error if it's not |
|
||||||
available." |
|
||||||
(or (haskell-session-maybe) |
|
||||||
(haskell-session-assign |
|
||||||
(or (haskell-session-from-buffer) |
|
||||||
(haskell-session-choose) |
|
||||||
(error "No session associated with this buffer. Try M-x haskell-session-change or report this as a bug."))))) |
|
||||||
|
|
||||||
(provide 'haskell-modules) |
|
||||||
@ -1,130 +0,0 @@ |
|||||||
;;; haskell-move-nested.el --- Change the column of text nested below a line -*- 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: |
|
||||||
|
|
||||||
;; This module is intended for Haskell mode users, but is |
|
||||||
;; independent of Haskell mode. |
|
||||||
|
|
||||||
;; Example usage: |
|
||||||
|
|
||||||
;; (define-key haskell-mode-map (kbd "C-,") 'haskell-move-nested-left) |
|
||||||
;; (define-key haskell-mode-map (kbd "C-.") 'haskell-move-nested-right) |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-move-nested (cols) |
|
||||||
"Shift the nested off-side-rule block adjacent to point by COLS columns to the right. |
|
||||||
|
|
||||||
In Transient Mark mode, if the mark is active, operate on the contents |
|
||||||
of the region instead. |
|
||||||
" |
|
||||||
(save-excursion |
|
||||||
(if (and transient-mark-mode mark-active) |
|
||||||
(progn |
|
||||||
(indent-rigidly (region-beginning) (region-end) cols) |
|
||||||
(setq deactivate-mark nil)) |
|
||||||
(let ((region (haskell-move-nested-region))) |
|
||||||
(when region |
|
||||||
(indent-rigidly (car region) (cdr region) cols)))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-move-nested-right (cols) |
|
||||||
"Increase indentation of the following off-side-rule block adjacent to point. |
|
||||||
|
|
||||||
Use a numeric prefix argument to indicate amount of indentation to apply. |
|
||||||
|
|
||||||
In Transient Mark mode, if the mark is active, operate on the contents |
|
||||||
of the region instead." |
|
||||||
(interactive "p") |
|
||||||
(haskell-move-nested cols) |
|
||||||
) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-move-nested-left (cols) |
|
||||||
"Decrease indentation of the following off-side-rule block adjacent to point. |
|
||||||
|
|
||||||
Use a numeric prefix argument to indicate amount of indentation to apply. |
|
||||||
|
|
||||||
In Transient Mark mode, if the mark is active, operate on the contents |
|
||||||
of the region instead." |
|
||||||
(interactive "p") |
|
||||||
(haskell-move-nested (- cols)) |
|
||||||
) |
|
||||||
|
|
||||||
(defun haskell-move-nested-region () |
|
||||||
"Infer region off-side-rule block adjacent to point. |
|
||||||
Used by `haskell-move-nested'. |
|
||||||
" |
|
||||||
(save-excursion |
|
||||||
(let ((starting-level (current-column))) |
|
||||||
(forward-line) |
|
||||||
(let ((current-level (haskell-move-nested-indent-level))) |
|
||||||
(let ((start-point (line-beginning-position)) |
|
||||||
(start-end-point (line-end-position)) |
|
||||||
(end-point nil) |
|
||||||
(last-line 0)) |
|
||||||
(forward-line) |
|
||||||
(while (and (not (= (line-beginning-position) last-line)) |
|
||||||
(or (> (haskell-move-nested-indent-level) starting-level) |
|
||||||
(and (> current-level starting-level) |
|
||||||
(>= (haskell-move-nested-indent-level) current-level)))) |
|
||||||
(setq last-line (line-beginning-position)) |
|
||||||
(setq end-point (line-end-position)) |
|
||||||
(forward-line)) |
|
||||||
(cons start-point (or end-point |
|
||||||
start-end-point))))))) |
|
||||||
|
|
||||||
(defun haskell-move-nested-indent-level () |
|
||||||
(max |
|
||||||
0 |
|
||||||
(1- (length |
|
||||||
(buffer-substring-no-properties |
|
||||||
(line-beginning-position) |
|
||||||
(or (save-excursion (goto-char (line-beginning-position)) |
|
||||||
(search-forward-regexp "[^ ]" (line-end-position) t 1)) |
|
||||||
(line-beginning-position))))))) |
|
||||||
|
|
||||||
(defun haskell-kill-nested () |
|
||||||
"Kill the nested region after point." |
|
||||||
(interactive) |
|
||||||
(let ((start (point)) |
|
||||||
(reg (save-excursion |
|
||||||
(search-backward-regexp "^[ ]+" (line-beginning-position) t 1) |
|
||||||
(search-forward-regexp "[^ ]" (line-end-position) t 1) |
|
||||||
(haskell-move-nested-region)))) |
|
||||||
(kill-region start (cdr reg)))) |
|
||||||
|
|
||||||
(defun haskell-delete-nested () |
|
||||||
"Kill the nested region after point." |
|
||||||
(interactive) |
|
||||||
(let ((start (point)) |
|
||||||
(reg (save-excursion |
|
||||||
(search-backward-regexp "^[ ]+" (line-beginning-position) t 1) |
|
||||||
(search-forward-regexp "[^ ]" (line-end-position) t 1) |
|
||||||
(haskell-move-nested-region)))) |
|
||||||
(delete-region start (cdr reg)))) |
|
||||||
|
|
||||||
(provide 'haskell-move-nested) |
|
||||||
|
|
||||||
;;; haskell-move-nested.el ends here |
|
||||||
@ -1,122 +0,0 @@ |
|||||||
;;; haskell-navigate-imports.el --- A function for cycling through Haskell import lists -*- 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: |
|
||||||
|
|
||||||
;; The cycling step will stop once at the last import list so |
|
||||||
;; that it is easy to add a new import list. |
|
||||||
|
|
||||||
;; This module works completely independently of any libraries |
|
||||||
;; (including haskell-mode). |
|
||||||
|
|
||||||
;; Exports three interactive functions: |
|
||||||
;; 1. haskell-navigate-imports |
|
||||||
;; 2. haskell-navigate-imports-go |
|
||||||
;; 3. haskell-navigate-imports-return |
|
||||||
|
|
||||||
;; Example usage: |
|
||||||
|
|
||||||
;; (require 'haskell-navigate-imports) |
|
||||||
;; (define-key haskell-mode-map [f8] 'haskell-navigate-imports) |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(defvar haskell-navigate-imports-start-point nil) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-navigate-imports (&optional return) |
|
||||||
"Cycle the Haskell import lines or return to point (with prefix arg)." |
|
||||||
(interactive "P") |
|
||||||
(if return |
|
||||||
(haskell-navigate-imports-return) |
|
||||||
(haskell-navigate-imports-go))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-navigate-imports-go () |
|
||||||
"Go to the first line of a list of consequtive import lines. Cycles." |
|
||||||
(interactive) |
|
||||||
(unless (or (haskell-navigate-imports-line) |
|
||||||
(equal (line-beginning-position) (point-min)) |
|
||||||
(save-excursion (forward-line -1) |
|
||||||
(haskell-navigate-imports-line))) |
|
||||||
(setq haskell-navigate-imports-start-point (point))) |
|
||||||
(haskell-navigate-imports-go-internal)) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-navigate-imports-return () |
|
||||||
"Return to the non-import point we were at before going to the module list. |
|
||||||
If we were originally at an import list, we can just cycle through easily." |
|
||||||
(interactive) |
|
||||||
(when haskell-navigate-imports-start-point |
|
||||||
(goto-char haskell-navigate-imports-start-point))) |
|
||||||
|
|
||||||
(defun haskell-navigate-imports-go-internal () |
|
||||||
"Go to the first line of a list of consequtive import lines. Cycle." |
|
||||||
(if (haskell-navigate-imports-line) |
|
||||||
(progn (haskell-navigate-imports-goto-end) |
|
||||||
(when (haskell-navigate-imports-find-forward-line) |
|
||||||
(haskell-navigate-imports-go-internal))) |
|
||||||
(let ((point (haskell-navigate-imports-find-forward-line))) |
|
||||||
(if point |
|
||||||
(goto-char point) |
|
||||||
(progn (goto-char (point-min)) |
|
||||||
(if (haskell-navigate-imports-find-forward-line) |
|
||||||
(haskell-navigate-imports-go-internal) |
|
||||||
(when (search-forward-regexp "^module" nil t 1) |
|
||||||
(search-forward "\n\n" nil t 1)))))))) |
|
||||||
|
|
||||||
(defun haskell-navigate-imports-goto-end () |
|
||||||
"Skip a bunch of consequtive import lines." |
|
||||||
(while (not (or (equal (point) |
|
||||||
(point-max)) |
|
||||||
(not (haskell-navigate-imports-line)))) |
|
||||||
(forward-line))) |
|
||||||
|
|
||||||
(defun haskell-navigate-imports-find-forward-line () |
|
||||||
"Return a point with at an import line, or nothing." |
|
||||||
(save-excursion |
|
||||||
(while (not (or (equal (point) (point-max)) |
|
||||||
(haskell-navigate-imports-after-imports-p) ;; This one just speeds it up. |
|
||||||
(haskell-navigate-imports-line))) |
|
||||||
(forward-line)) |
|
||||||
(if (haskell-navigate-imports-line) |
|
||||||
(point) |
|
||||||
nil))) |
|
||||||
|
|
||||||
(defun haskell-navigate-imports-line () |
|
||||||
"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-navigate-imports-after-imports-p () |
|
||||||
"Are we after the imports list? Just for a speed boost." |
|
||||||
(save-excursion |
|
||||||
(goto-char (line-beginning-position)) |
|
||||||
(not (not (search-forward-regexp "\\( = \\|\\<instance\\>\\| :: \\)" |
|
||||||
(line-end-position) t 1))))) |
|
||||||
|
|
||||||
(provide 'haskell-navigate-imports) |
|
||||||
|
|
||||||
;;; haskell-navigate-imports.el ends here |
|
||||||
@ -1,140 +0,0 @@ |
|||||||
;;; haskell-package.el --- Interface for working with Cabal packages -*- lexical-binding: t -*- |
|
||||||
|
|
||||||
;; Copyright (C) 2011 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) |
|
||||||
|
|
||||||
(defun haskell-package-conf-user-path-get () |
|
||||||
"Get the user conf path." |
|
||||||
(let ((out (shell-command-to-string "ghc-pkg --user list no-results-please"))) |
|
||||||
(string-match "\n\\(.*\\):\n" out) (match-string 1 out))) |
|
||||||
|
|
||||||
(defun haskell-package-conf-global-path-get () |
|
||||||
"Get the global conf path." |
|
||||||
(let ((out (shell-command-to-string "ghc-pkg --global list no-results-please"))) |
|
||||||
(string-match "\n\\(.*\\):\n" out) (match-string 1 out))) |
|
||||||
|
|
||||||
(defun haskell-package-get-all (conf) |
|
||||||
"Get all package descriptions for the given `conf'." |
|
||||||
(let ((all (shell-command-to-string (format "ghc-pkg -f %s dump" conf)))) |
|
||||||
(mapcar (lambda (text) |
|
||||||
(haskell-package-parse text)) |
|
||||||
(split-string all "\n---\n")))) |
|
||||||
|
|
||||||
(defun haskell-package-get (conf name version) |
|
||||||
"Get a package description for the given `name' and `version' in the given `conf'." |
|
||||||
(haskell-package-parse |
|
||||||
(shell-command-to-string |
|
||||||
(format "ghc-pkg -f %s describe %s-%s" |
|
||||||
conf |
|
||||||
name |
|
||||||
version)))) |
|
||||||
|
|
||||||
(cl-defstruct haskell-package "Haskell package object.") |
|
||||||
|
|
||||||
(defun haskell-package-parse (text) |
|
||||||
"Parse a package into a package object." |
|
||||||
(let ((pkg (haskell-package-read-description text))) |
|
||||||
(make-haskell-package |
|
||||||
:name (cdr (assoc "name" pkg)) |
|
||||||
:version (cdr (assoc "version" pkg)) |
|
||||||
:id (cdr (assoc "id" pkg)) |
|
||||||
:license (cdr (assoc "license" pkg)) |
|
||||||
:copyright (cdr (assoc "copyright" pkg)) |
|
||||||
:maintainer (cdr (assoc "maintainer" pkg)) |
|
||||||
:stability (cdr (assoc "stability" pkg)) |
|
||||||
:homepage (cdr (assoc "homepage" pkg)) |
|
||||||
:package-url (cdr (assoc "package-url" pkg)) |
|
||||||
:description (cdr (assoc "description" pkg)) |
|
||||||
:categories (cdr (assoc "category" pkg)) |
|
||||||
:authors (cdr (assoc "author" pkg)) |
|
||||||
:is-exposed (equal "True" (cdr (assoc "exposed" pkg))) |
|
||||||
:exposed-modules (split-string (or (cdr (assoc "exposed-modules" pkg)) "") |
|
||||||
"[\n ]") |
|
||||||
:hidden-modules (split-string (or (cdr (assoc "hidden-modules" pkg)) "") |
|
||||||
"[\n ]") |
|
||||||
:imports-dirs (cdr (assoc "imports-dirs" pkg)) |
|
||||||
:library-dirs (cdr (assoc "library-dirs" pkg)) |
|
||||||
:haskell-libraries (cdr (assoc "haskell-libraries" pkg)) |
|
||||||
:extra-libraries (cdr (assoc "extra-libraries" pkg)) |
|
||||||
:extra-ghci-libraries (cdr (assoc "extra-ghci-libraries" pkg)) |
|
||||||
:include-dirs (cdr (assoc "include-dirs" pkg)) |
|
||||||
:includes (cdr (assoc "includes" pkg)) |
|
||||||
:depends (cdr (assoc "depends" pkg)) |
|
||||||
:hugs-options (cdr (assoc "hugs-options" pkg)) |
|
||||||
:cc-options (cdr (assoc "cc-options" pkg)) |
|
||||||
:ld-options (cdr (assoc "ld-options" pkg)) |
|
||||||
:framework-dirs (cdr (assoc "framework-dirs" pkg)) |
|
||||||
:frameworks (cdr (assoc "frameworks" pkg)) |
|
||||||
:haddock-interfaces (cdr (assoc "haddock-interfaces" pkg)) |
|
||||||
:haddock-html (cdr (assoc "haddock-html" pkg))))) |
|
||||||
|
|
||||||
(defun haskell-package-read-description (text) |
|
||||||
"Return an association list of key-values from a pkg description string." |
|
||||||
(let* ((marked (replace-regexp-in-string |
|
||||||
"\n\\([^ ]\\)" |
|
||||||
(lambda (match) |
|
||||||
(concat "\n:" (substring match 1))) |
|
||||||
text)) |
|
||||||
(alist (mapcar 'haskell-package-key-value |
|
||||||
(split-string marked "\n:")))) |
|
||||||
alist)) |
|
||||||
|
|
||||||
(defun haskell-package-key-value (entry) |
|
||||||
"Return a (key . value) pair from an entry." |
|
||||||
(let ((key-values (split-string entry ": "))) |
|
||||||
(if (listp key-values) |
|
||||||
(cons (car key-values) |
|
||||||
(replace-regexp-in-string |
|
||||||
"\n[ ]*" |
|
||||||
" " |
|
||||||
(mapconcat 'identity (cdr key-values) ": "))) |
|
||||||
key-values))) |
|
||||||
|
|
||||||
(defun haskell-package-list-get (conf) |
|
||||||
"Get the list of packages in the given config." |
|
||||||
(haskell-package-list-parse |
|
||||||
(shell-command-to-string |
|
||||||
(format "ghc-pkg -f %s list" |
|
||||||
conf)))) |
|
||||||
|
|
||||||
(defun haskell-package-list-parse (text) |
|
||||||
"Parse the list of installed packges." |
|
||||||
(let* ((lines (split-string text "\n "))) |
|
||||||
(mapcar |
|
||||||
(lambda (line) |
|
||||||
(string-match "^{?\\([a-zA-Z0-9-_]+\\)-\\([0-9.]+\\)}?$" line) |
|
||||||
(cons (match-string 1 line) (match-string 2 line))) |
|
||||||
(cl-delete-if |
|
||||||
(lambda (line) |
|
||||||
(not (string-match "^{?[a-zA-Z0-9-_]+-[0-9.]+}?$" line))) |
|
||||||
lines)))) |
|
||||||
|
|
||||||
(provide 'haskell-package) |
|
||||||
|
|
||||||
;;; haskell-package.el ends here |
|
||||||
@ -1,103 +0,0 @@ |
|||||||
;;; haskell-presentation-mode.el --- Presenting Haskell things -*- 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: |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(require 'haskell-mode) |
|
||||||
(require 'haskell-session) |
|
||||||
|
|
||||||
(define-derived-mode haskell-presentation-mode |
|
||||||
haskell-mode "Presentation" |
|
||||||
"Major mode for viewing Haskell snippets. |
|
||||||
\\{hypertext-mode-map}" |
|
||||||
(setq case-fold-search nil)) |
|
||||||
|
|
||||||
(defconst haskell-presentation-buffer-name |
|
||||||
"*Haskell Presentation*" |
|
||||||
"Haskell Presentation buffer name.") |
|
||||||
|
|
||||||
(defconst haskell-presentation-hint-message |
|
||||||
"-- Hit `q' to close this window; `c' to clear.\n\n" |
|
||||||
"Hint message appered in Haskell Presentation buffer.") |
|
||||||
|
|
||||||
(easy-mmode-defmap |
|
||||||
haskell-presentation-mode-map |
|
||||||
`(("q" . quit-window) |
|
||||||
("c" . haskell-presentation-clear)) |
|
||||||
"The base key map for `haskell-presentation-mode'.") |
|
||||||
|
|
||||||
(defun haskell-presentation-buffer () |
|
||||||
"Return Haskell Presentaion buffer. |
|
||||||
Return current presenation buffer or create new one if absent. |
|
||||||
Never returns nil." |
|
||||||
;; TODO Provide interactive calling options: when called interactively make |
|
||||||
;; the presentation buffer current. |
|
||||||
(let ((may-buffer (get-buffer haskell-presentation-buffer-name))) |
|
||||||
(if may-buffer |
|
||||||
may-buffer |
|
||||||
(let ((buffer (generate-new-buffer haskell-presentation-buffer-name))) |
|
||||||
(with-current-buffer buffer |
|
||||||
(insert haskell-presentation-hint-message) |
|
||||||
(haskell-presentation-mode) |
|
||||||
(setq buffer-read-only t)) |
|
||||||
buffer)))) |
|
||||||
|
|
||||||
(defun haskell-presentation-clear () |
|
||||||
"Clear Haskell Presentation buffer." |
|
||||||
(interactive) |
|
||||||
(let ((hp-buf (get-buffer haskell-presentation-buffer-name))) |
|
||||||
(when hp-buf |
|
||||||
(with-current-buffer hp-buf |
|
||||||
(let ((buffer-read-only nil)) |
|
||||||
(erase-buffer) |
|
||||||
(insert haskell-presentation-hint-message)))))) |
|
||||||
|
|
||||||
(defun haskell-presentation-present (session code &optional clear) |
|
||||||
"Present given code in a popup buffer. |
|
||||||
Creates temporal Haskell Presentation buffer and assigns it to |
|
||||||
given haskell SESSION; presented CODE will be fontified as |
|
||||||
haskell code. Give an optional non-nil CLEAR arg to clear the |
|
||||||
buffer before presenting message." |
|
||||||
(let ((buffer (haskell-presentation-buffer))) |
|
||||||
(with-current-buffer buffer |
|
||||||
|
|
||||||
(when (boundp 'shm-display-quarantine) |
|
||||||
(set (make-local-variable 'shm-display-quarantine) nil)) |
|
||||||
|
|
||||||
(when clear (haskell-presentation-clear)) |
|
||||||
(haskell-session-assign session) |
|
||||||
(save-excursion |
|
||||||
(let ((buffer-read-only nil)) |
|
||||||
(goto-char (point-min)) |
|
||||||
(forward-line 2) |
|
||||||
(insert code "\n\n")))) |
|
||||||
|
|
||||||
(if (eq major-mode 'haskell-presentation-mode) |
|
||||||
(switch-to-buffer buffer) |
|
||||||
(pop-to-buffer buffer)))) |
|
||||||
|
|
||||||
(provide 'haskell-presentation-mode) |
|
||||||
|
|
||||||
;;; haskell-presentation-mode.el ends here |
|
||||||
@ -1,495 +0,0 @@ |
|||||||
;;; haskell-process.el --- Communicating with the inferior Haskell process -*- lexical-binding: t -*- |
|
||||||
|
|
||||||
;; Copyright (C) 2011 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. |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(require 'cl-lib) |
|
||||||
(require 'json) |
|
||||||
(require 'url-util) |
|
||||||
(require 'haskell-compat) |
|
||||||
(require 'haskell-session) |
|
||||||
(require 'haskell-customize) |
|
||||||
(require 'haskell-string) |
|
||||||
|
|
||||||
(defconst haskell-process-prompt-regex "\4" |
|
||||||
"Used for delimiting command replies. 4 is End of Transmission.") |
|
||||||
|
|
||||||
(defvar haskell-reload-p nil |
|
||||||
"Used internally for `haskell-process-loadish'.") |
|
||||||
|
|
||||||
(defconst haskell-process-greetings |
|
||||||
(list "Hello, Haskell!" |
|
||||||
"The lambdas must flow." |
|
||||||
"Hours of hacking await!" |
|
||||||
"The next big Haskell project is about to start!" |
|
||||||
"Your wish is my IO ().") |
|
||||||
"Greetings for when the Haskell process starts up.") |
|
||||||
|
|
||||||
(defconst haskell-process-logo |
|
||||||
(expand-file-name "logo.svg" haskell-mode-pkg-base-dir) |
|
||||||
"Haskell logo for notifications.") |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Accessing commands -- using cl 'defstruct' |
|
||||||
|
|
||||||
(cl-defstruct haskell-command |
|
||||||
"Data structure representing a command to be executed when with |
|
||||||
a custom state and three callback." |
|
||||||
;; hold the custom command state |
|
||||||
;; state :: a |
|
||||||
state |
|
||||||
;; called when to execute a command |
|
||||||
;; go :: a -> () |
|
||||||
go |
|
||||||
;; called whenever output was collected from the haskell process |
|
||||||
;; live :: a -> Response -> Bool |
|
||||||
live |
|
||||||
;; called when the output from the haskell process indicates that the command |
|
||||||
;; is complete |
|
||||||
;; complete :: a -> Response -> () |
|
||||||
complete) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Building the process |
|
||||||
|
|
||||||
(defun haskell-process-compute-process-log-and-command (session hptype) |
|
||||||
"Compute the log and process to start command for the SESSION from the HPTYPE. |
|
||||||
Do not actually start any process. |
|
||||||
HPTYPE is the result of calling `'haskell-process-type`' function." |
|
||||||
(let ((session-name (haskell-session-name session))) |
|
||||||
(cl-ecase hptype |
|
||||||
('ghci |
|
||||||
(append (list (format "Starting inferior GHCi process %s ..." |
|
||||||
haskell-process-path-ghci) |
|
||||||
session-name |
|
||||||
nil) |
|
||||||
(apply haskell-process-wrapper-function |
|
||||||
(list |
|
||||||
(cons haskell-process-path-ghci haskell-process-args-ghci))))) |
|
||||||
('cabal-repl |
|
||||||
(append (list (format "Starting inferior `cabal repl' process using %s ..." |
|
||||||
haskell-process-path-cabal) |
|
||||||
session-name |
|
||||||
nil) |
|
||||||
(apply haskell-process-wrapper-function |
|
||||||
(list |
|
||||||
(append |
|
||||||
(list haskell-process-path-cabal "repl") |
|
||||||
haskell-process-args-cabal-repl |
|
||||||
(let ((target (haskell-session-target session))) |
|
||||||
(if target (list target) nil))))))) |
|
||||||
('stack-ghci |
|
||||||
(append (list (format "Starting inferior stack GHCi process using %s" haskell-process-path-stack) |
|
||||||
session-name |
|
||||||
nil) |
|
||||||
(apply haskell-process-wrapper-function |
|
||||||
(list |
|
||||||
(append |
|
||||||
(list haskell-process-path-stack "ghci") |
|
||||||
(let ((target (haskell-session-target session))) |
|
||||||
(if target (list target) nil)) |
|
||||||
haskell-process-args-stack-ghci)))))))) |
|
||||||
|
|
||||||
(defun haskell-process-make (name) |
|
||||||
"Make an inferior Haskell process." |
|
||||||
(list (cons 'name name))) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Process communication |
|
||||||
|
|
||||||
(defun haskell-process-sentinel (proc event) |
|
||||||
"The sentinel for the process pipe." |
|
||||||
(let ((session (haskell-process-project-by-proc proc))) |
|
||||||
(when session |
|
||||||
(let* ((process (haskell-session-process session))) |
|
||||||
(unless (haskell-process-restarting process) |
|
||||||
(haskell-process-log |
|
||||||
(propertize (format "Event: %S\n" event) |
|
||||||
'face '((:weight bold)))) |
|
||||||
(haskell-process-log |
|
||||||
(propertize "Process reset.\n" |
|
||||||
'face font-lock-comment-face)) |
|
||||||
(run-hook-with-args 'haskell-process-ended-hook process)))))) |
|
||||||
|
|
||||||
(defun haskell-process-filter (proc response) |
|
||||||
"The filter for the process pipe." |
|
||||||
(let ((i 0)) |
|
||||||
(cl-loop for line in (split-string response "\n") |
|
||||||
do (haskell-process-log |
|
||||||
(concat (if (= i 0) |
|
||||||
(propertize "<- " 'face font-lock-comment-face) |
|
||||||
" ") |
|
||||||
(propertize line 'face 'haskell-interactive-face-compile-warning))) |
|
||||||
do (setq i (1+ i)))) |
|
||||||
(let ((session (haskell-process-project-by-proc proc))) |
|
||||||
(when session |
|
||||||
(if (haskell-process-cmd (haskell-session-process session)) |
|
||||||
(haskell-process-collect session |
|
||||||
response |
|
||||||
(haskell-session-process session)) |
|
||||||
(haskell-process-log |
|
||||||
(replace-regexp-in-string "\4" "" response)))))) |
|
||||||
|
|
||||||
(defun haskell-process-log (msg) |
|
||||||
"Effective append MSG to the process log (if enabled)." |
|
||||||
(when haskell-process-log |
|
||||||
(let* ((append-to (get-buffer-create "*haskell-process-log*")) |
|
||||||
(windows (get-buffer-window-list append-to t t)) |
|
||||||
move-point-in-windows) |
|
||||||
(with-current-buffer append-to |
|
||||||
(setq buffer-read-only nil) |
|
||||||
;; record in which windows we should keep point at eob. |
|
||||||
(dolist (window windows) |
|
||||||
(when (= (window-point window) (point-max)) |
|
||||||
(push window move-point-in-windows))) |
|
||||||
(let (return-to-position) |
|
||||||
;; decide whether we should reset point to return-to-position |
|
||||||
;; or leave it at eob. |
|
||||||
(unless (= (point) (point-max)) |
|
||||||
(setq return-to-position (point)) |
|
||||||
(goto-char (point-max))) |
|
||||||
(insert "\n" msg "\n") |
|
||||||
(when return-to-position |
|
||||||
(goto-char return-to-position))) |
|
||||||
;; advance to point-max in windows where it is needed |
|
||||||
(dolist (window move-point-in-windows) |
|
||||||
(set-window-point window (point-max))) |
|
||||||
(setq buffer-read-only t))))) |
|
||||||
|
|
||||||
(defun haskell-process-project-by-proc (proc) |
|
||||||
"Find project by process." |
|
||||||
(cl-find-if (lambda (project) |
|
||||||
(string= (haskell-session-name project) |
|
||||||
(process-name proc))) |
|
||||||
haskell-sessions)) |
|
||||||
|
|
||||||
(defun haskell-process-collect (_session response process) |
|
||||||
"Collect input for the response until receives a prompt." |
|
||||||
(haskell-process-set-response process |
|
||||||
(concat (haskell-process-response process) response)) |
|
||||||
(while (haskell-process-live-updates process)) |
|
||||||
(when (string-match haskell-process-prompt-regex |
|
||||||
(haskell-process-response process)) |
|
||||||
(haskell-command-exec-complete |
|
||||||
(haskell-process-cmd process) |
|
||||||
(replace-regexp-in-string |
|
||||||
haskell-process-prompt-regex |
|
||||||
"" |
|
||||||
(haskell-process-response process))) |
|
||||||
(haskell-process-reset process) |
|
||||||
(haskell-process-trigger-queue process))) |
|
||||||
|
|
||||||
(defun haskell-process-reset (process) |
|
||||||
"Reset the process's state, ready for the next send/reply." |
|
||||||
(progn (haskell-process-set-response-cursor process 0) |
|
||||||
(haskell-process-set-response process "") |
|
||||||
(haskell-process-set-cmd process nil))) |
|
||||||
|
|
||||||
(defun haskell-process-consume (process regex) |
|
||||||
"Consume a regex from the response and move the cursor along if succeed." |
|
||||||
(when (string-match regex |
|
||||||
(haskell-process-response process) |
|
||||||
(haskell-process-response-cursor process)) |
|
||||||
(haskell-process-set-response-cursor process (match-end 0)) |
|
||||||
t)) |
|
||||||
|
|
||||||
(defun haskell-process-send-string (process string) |
|
||||||
"Try to send a string to the process's process. Ask to restart if it's not running." |
|
||||||
(let ((child (haskell-process-process process))) |
|
||||||
(if (equal 'run (process-status child)) |
|
||||||
(let ((out (concat string "\n"))) |
|
||||||
(haskell-process-log |
|
||||||
(propertize (concat (propertize "-> " 'face font-lock-comment-face) |
|
||||||
(propertize string 'face font-lock-string-face)) |
|
||||||
'face '((:weight bold)))) |
|
||||||
(process-send-string child out)) |
|
||||||
(unless (haskell-process-restarting process) |
|
||||||
(run-hook-with-args 'haskell-process-ended process))))) |
|
||||||
|
|
||||||
(defun haskell-process-live-updates (process) |
|
||||||
"Process live updates." |
|
||||||
(haskell-command-exec-live (haskell-process-cmd process) |
|
||||||
(haskell-process-response process))) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Making commands |
|
||||||
|
|
||||||
(defun haskell-process-queue-without-filters (process line) |
|
||||||
"Queue LINE to be sent to PROCESS without bothering to look at |
|
||||||
the response." |
|
||||||
(haskell-process-queue-command |
|
||||||
process |
|
||||||
(make-haskell-command |
|
||||||
:state (cons process line) |
|
||||||
:go (lambda (state) |
|
||||||
(haskell-process-send-string (car state) |
|
||||||
(cdr state)))))) |
|
||||||
|
|
||||||
|
|
||||||
(defun haskell-process-queue-command (process command) |
|
||||||
"Add a command to the process command queue." |
|
||||||
(haskell-process-cmd-queue-add process command) |
|
||||||
(haskell-process-trigger-queue process)) |
|
||||||
|
|
||||||
(defun haskell-process-trigger-queue (process) |
|
||||||
"Trigger the next command in the queue to be ran if there is no current command." |
|
||||||
(if (and (haskell-process-process process) |
|
||||||
(process-live-p (haskell-process-process process))) |
|
||||||
(unless (haskell-process-cmd process) |
|
||||||
(let ((cmd (haskell-process-cmd-queue-pop process))) |
|
||||||
(when cmd |
|
||||||
(haskell-process-set-cmd process cmd) |
|
||||||
(haskell-command-exec-go cmd)))) |
|
||||||
(progn (haskell-process-reset process) |
|
||||||
(haskell-process-set process 'command-queue nil) |
|
||||||
(run-hook-with-args 'haskell-process-ended process)))) |
|
||||||
|
|
||||||
(defun haskell-process-queue-flushed-p (process) |
|
||||||
"Return t if command queue has been completely processed." |
|
||||||
(not (or (haskell-process-cmd-queue process) |
|
||||||
(haskell-process-cmd process)))) |
|
||||||
|
|
||||||
(defun haskell-process-queue-flush (process) |
|
||||||
"Block till PROCESS' command queue has been completely processed. |
|
||||||
This uses `accept-process-output' internally." |
|
||||||
(while (not (haskell-process-queue-flushed-p process)) |
|
||||||
(haskell-process-trigger-queue process) |
|
||||||
(accept-process-output (haskell-process-process process) 1))) |
|
||||||
|
|
||||||
(defun haskell-process-queue-sync-request (process reqstr) |
|
||||||
"Queue submitting REQSTR to PROCESS and return response blockingly." |
|
||||||
(let ((cmd (make-haskell-command |
|
||||||
:state (cons nil process) |
|
||||||
:go `(lambda (s) (haskell-process-send-string (cdr s) ,reqstr)) |
|
||||||
:complete 'setcar))) |
|
||||||
(haskell-process-queue-command process cmd) |
|
||||||
(haskell-process-queue-flush process) |
|
||||||
(car-safe (haskell-command-state cmd)))) |
|
||||||
|
|
||||||
(defun haskell-process-get-repl-completions (process inputstr &optional limit) |
|
||||||
"Perform `:complete repl ...' query for INPUTSTR using PROCESS. |
|
||||||
Give optional LIMIT arg to limit completion candidates count, |
|
||||||
zero, negative values, and nil means all possible completions. |
|
||||||
Returns NIL when no completions found." |
|
||||||
(let* ((mlimit (if (and limit (> limit 0)) |
|
||||||
(concat " " (number-to-string limit) " ") |
|
||||||
" ")) |
|
||||||
(reqstr (concat ":complete repl" |
|
||||||
mlimit |
|
||||||
(haskell-string-literal-encode inputstr))) |
|
||||||
(rawstr (haskell-process-queue-sync-request process reqstr))) |
|
||||||
;; TODO use haskell-utils-parse-repl-response |
|
||||||
(if (string-prefix-p "unknown command " rawstr) |
|
||||||
(error "GHCi lacks `:complete' support (try installing 7.8 or ghci-ng)") |
|
||||||
(let* ((s1 (split-string rawstr "\r?\n" t)) |
|
||||||
(cs (mapcar #'haskell-string-literal-decode (cdr s1))) |
|
||||||
(h0 (car s1))) ;; "<limit count> <all count> <unused string>" |
|
||||||
(unless (string-match "\\`\\([0-9]+\\) \\([0-9]+\\) \\(\".*\"\\)\\'" h0) |
|
||||||
(error "Invalid `:complete' response")) |
|
||||||
(let ((cnt1 (match-string 1 h0)) |
|
||||||
(h1 (haskell-string-literal-decode (match-string 3 h0)))) |
|
||||||
(unless (= (string-to-number cnt1) (length cs)) |
|
||||||
(error "Lengths inconsistent in `:complete' reponse")) |
|
||||||
(cons h1 cs)))))) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Accessing the process |
|
||||||
|
|
||||||
(defun haskell-process-get (process key) |
|
||||||
"Get the PROCESS's KEY value. |
|
||||||
Returns nil if KEY not set." |
|
||||||
(cdr (assq key process))) |
|
||||||
|
|
||||||
(defun haskell-process-set (process key value) |
|
||||||
"Set the PROCESS's KEY to VALUE. |
|
||||||
Returns newly set VALUE." |
|
||||||
(if process |
|
||||||
(let ((cell (assq key process))) |
|
||||||
(if cell |
|
||||||
(setcdr cell value) ; modify cell in-place |
|
||||||
(setcdr process (cons (cons key value) (cdr process))) ; new cell |
|
||||||
value)) |
|
||||||
(display-warning 'haskell-interactive |
|
||||||
"`haskell-process-set' called with nil process"))) |
|
||||||
|
|
||||||
;; Wrappers using haskell-process-{get,set} |
|
||||||
|
|
||||||
(defun haskell-process-set-sent-stdin (p v) |
|
||||||
"We've sent stdin, so let's not clear the output at the end." |
|
||||||
(haskell-process-set p 'sent-stdin v)) |
|
||||||
|
|
||||||
(defun haskell-process-sent-stdin-p (p) |
|
||||||
"Did we send any stdin to the process during evaluation?" |
|
||||||
(haskell-process-get p 'sent-stdin)) |
|
||||||
|
|
||||||
(defun haskell-process-set-suggested-imports (p v) |
|
||||||
"Remember what imports have been suggested, to avoid |
|
||||||
re-asking about the same imports." |
|
||||||
(haskell-process-set p 'suggested-imported v)) |
|
||||||
|
|
||||||
(defun haskell-process-suggested-imports (p) |
|
||||||
"Get what modules have already been suggested and accepted." |
|
||||||
(haskell-process-get p 'suggested-imported)) |
|
||||||
|
|
||||||
(defun haskell-process-set-evaluating (p v) |
|
||||||
"Set status of evaluating to be on/off." |
|
||||||
(haskell-process-set p 'evaluating v)) |
|
||||||
|
|
||||||
(defun haskell-process-evaluating-p (p) |
|
||||||
"Set status of evaluating to be on/off." |
|
||||||
(haskell-process-get p 'evaluating)) |
|
||||||
|
|
||||||
(defun haskell-process-set-process (p v) |
|
||||||
"Set the process's inferior process." |
|
||||||
(haskell-process-set p 'inferior-process v)) |
|
||||||
|
|
||||||
(defun haskell-process-process (p) |
|
||||||
"Get the process child." |
|
||||||
(haskell-process-get p 'inferior-process)) |
|
||||||
|
|
||||||
(defun haskell-process-name (p) |
|
||||||
"Get the process name." |
|
||||||
(haskell-process-get p 'name)) |
|
||||||
|
|
||||||
(defun haskell-process-cmd (p) |
|
||||||
"Get the process's current command. |
|
||||||
Return nil if no current command." |
|
||||||
(haskell-process-get p 'current-command)) |
|
||||||
|
|
||||||
(defun haskell-process-set-cmd (p v) |
|
||||||
"Set the process's current command." |
|
||||||
(haskell-process-set-evaluating p nil) |
|
||||||
(haskell-process-set-sent-stdin p nil) |
|
||||||
(haskell-process-set-suggested-imports p nil) |
|
||||||
(haskell-process-set p 'current-command v)) |
|
||||||
|
|
||||||
(defun haskell-process-response (p) |
|
||||||
"Get the process's current response." |
|
||||||
(haskell-process-get p 'current-response)) |
|
||||||
|
|
||||||
(defun haskell-process-session (p) |
|
||||||
"Get the process's current session." |
|
||||||
(haskell-process-get p 'session)) |
|
||||||
|
|
||||||
(defun haskell-process-set-response (p v) |
|
||||||
"Set the process's current response." |
|
||||||
(haskell-process-set p 'current-response v)) |
|
||||||
|
|
||||||
(defun haskell-process-set-session (p v) |
|
||||||
"Set the process's current session." |
|
||||||
(haskell-process-set p 'session v)) |
|
||||||
|
|
||||||
(defun haskell-process-response-cursor (p) |
|
||||||
"Get the process's current response cursor." |
|
||||||
(haskell-process-get p 'current-response-cursor)) |
|
||||||
|
|
||||||
(defun haskell-process-set-response-cursor (p v) |
|
||||||
"Set the process's response cursor." |
|
||||||
(haskell-process-set p 'current-response-cursor v)) |
|
||||||
|
|
||||||
;; low-level command queue operations |
|
||||||
|
|
||||||
(defun haskell-process-restarting (process) |
|
||||||
"Is the PROCESS restarting?" |
|
||||||
(haskell-process-get process 'is-restarting)) |
|
||||||
|
|
||||||
(defun haskell-process-cmd-queue (process) |
|
||||||
"Get the PROCESS' command queue. |
|
||||||
New entries get added to the end of the list. Use |
|
||||||
`haskell-process-cmd-queue-add' and |
|
||||||
`haskell-process-cmd-queue-pop' to modify the command queue." |
|
||||||
(haskell-process-get process 'command-queue)) |
|
||||||
|
|
||||||
(defun haskell-process-cmd-queue-add (process cmd) |
|
||||||
"Add CMD to end of PROCESS's command queue." |
|
||||||
(cl-check-type cmd haskell-command) |
|
||||||
(haskell-process-set process |
|
||||||
'command-queue |
|
||||||
(append (haskell-process-cmd-queue process) |
|
||||||
(list cmd)))) |
|
||||||
|
|
||||||
(defun haskell-process-cmd-queue-pop (process) |
|
||||||
"Pop the PROCESS' next entry from command queue. |
|
||||||
Returns nil if queue is empty." |
|
||||||
(let ((queue (haskell-process-cmd-queue process))) |
|
||||||
(when queue |
|
||||||
(haskell-process-set process 'command-queue (cdr queue)) |
|
||||||
(car queue)))) |
|
||||||
|
|
||||||
|
|
||||||
(defun haskell-process-unignore-file (session file) |
|
||||||
" |
|
||||||
|
|
||||||
Note to Windows Emacs hackers: |
|
||||||
|
|
||||||
chmod is how to change the mode of files in POSIX |
|
||||||
systems. This will not work on your operating |
|
||||||
system. |
|
||||||
|
|
||||||
There is a command a bit like chmod called \"Calcs\" |
|
||||||
that you can try using here: |
|
||||||
|
|
||||||
http://technet.microsoft.com/en-us/library/bb490872.aspx |
|
||||||
|
|
||||||
If it works, you can submit a patch to this |
|
||||||
function and remove this comment. |
|
||||||
" |
|
||||||
(shell-command (read-from-minibuffer "Permissions command: " |
|
||||||
(concat "chmod 700 " |
|
||||||
file))) |
|
||||||
(haskell-session-modify |
|
||||||
session |
|
||||||
'ignored-files |
|
||||||
(lambda (files) |
|
||||||
(cl-remove-if (lambda (path) |
|
||||||
(string= path file)) |
|
||||||
files)))) |
|
||||||
|
|
||||||
(defun haskell-command-exec-go (command) |
|
||||||
"Call the command's go function." |
|
||||||
(let ((go-func (haskell-command-go command))) |
|
||||||
(when go-func |
|
||||||
(funcall go-func (haskell-command-state command))))) |
|
||||||
|
|
||||||
(defun haskell-command-exec-complete (command response) |
|
||||||
"Call the command's complete function." |
|
||||||
(let ((comp-func (haskell-command-complete command))) |
|
||||||
(when comp-func |
|
||||||
(condition-case e |
|
||||||
(funcall comp-func |
|
||||||
(haskell-command-state command) |
|
||||||
response) |
|
||||||
(quit (message "Quit")) |
|
||||||
(error (message "Haskell process command errored with: %S" e)))))) |
|
||||||
|
|
||||||
(defun haskell-command-exec-live (command response) |
|
||||||
"Trigger the command's live updates callback." |
|
||||||
(let ((live-func (haskell-command-live command))) |
|
||||||
(when live-func |
|
||||||
(funcall live-func |
|
||||||
(haskell-command-state command) |
|
||||||
response)))) |
|
||||||
|
|
||||||
(provide 'haskell-process) |
|
||||||
|
|
||||||
;;; haskell-process.el ends here |
|
||||||
@ -1,120 +0,0 @@ |
|||||||
;;; haskell-repl.el --- REPL evaluation -*- 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-interactive-mode) |
|
||||||
|
|
||||||
(defun haskell-interactive-handle-expr () |
|
||||||
"Handle an inputted expression at the REPL." |
|
||||||
(when (haskell-interactive-at-prompt) |
|
||||||
(let ((expr (haskell-interactive-mode-input))) |
|
||||||
(unless (string= "" (replace-regexp-in-string " " "" expr)) |
|
||||||
(cond |
|
||||||
;; If already evaluating, then the user is trying to send |
|
||||||
;; input to the REPL during evaluation. Most likely in |
|
||||||
;; response to a getLine-like function. |
|
||||||
((and (haskell-process-evaluating-p (haskell-interactive-process)) |
|
||||||
(= (line-end-position) (point-max))) |
|
||||||
(goto-char (point-max)) |
|
||||||
(let ((process (haskell-interactive-process)) |
|
||||||
(string (buffer-substring-no-properties |
|
||||||
haskell-interactive-mode-result-end |
|
||||||
(point)))) |
|
||||||
;; here we need to go to end of line again as evil-mode |
|
||||||
;; might hae managed to put us one char back |
|
||||||
(goto-char (point-max)) |
|
||||||
(insert "\n") |
|
||||||
;; Bring the marker forward |
|
||||||
(setq haskell-interactive-mode-result-end |
|
||||||
(point-max)) |
|
||||||
(haskell-process-set-sent-stdin process t) |
|
||||||
(haskell-process-send-string process string))) |
|
||||||
;; Otherwise we start a normal evaluation call. |
|
||||||
(t (setq haskell-interactive-mode-old-prompt-start |
|
||||||
(copy-marker haskell-interactive-mode-prompt-start)) |
|
||||||
(set-marker haskell-interactive-mode-prompt-start (point-max)) |
|
||||||
(haskell-interactive-mode-history-add expr) |
|
||||||
(haskell-interactive-mode-do-expr expr))))))) |
|
||||||
|
|
||||||
(defun haskell-interactive-mode-do-expr (expr) |
|
||||||
(cond |
|
||||||
((string-match "^:present " expr) |
|
||||||
(haskell-interactive-mode-do-presentation (replace-regexp-in-string "^:present " "" expr))) |
|
||||||
(t |
|
||||||
(haskell-interactive-mode-run-expr expr)))) |
|
||||||
|
|
||||||
(defun haskell-interactive-mode-run-expr (expr) |
|
||||||
"Run the given expression." |
|
||||||
(let ((session (haskell-interactive-session)) |
|
||||||
(process (haskell-interactive-process))) |
|
||||||
(haskell-process-queue-command |
|
||||||
process |
|
||||||
(make-haskell-command |
|
||||||
:state (list session process expr 0) |
|
||||||
:go (lambda (state) |
|
||||||
(goto-char (point-max)) |
|
||||||
(insert "\n") |
|
||||||
(setq haskell-interactive-mode-result-end |
|
||||||
(point-max)) |
|
||||||
(haskell-process-send-string (cadr state) |
|
||||||
(haskell-interactive-mode-multi-line (cl-caddr state))) |
|
||||||
(haskell-process-set-evaluating (cadr state) t)) |
|
||||||
:live (lambda (state buffer) |
|
||||||
(unless (and (string-prefix-p ":q" (cl-caddr state)) |
|
||||||
(string-prefix-p (cl-caddr state) ":quit")) |
|
||||||
(let* ((cursor (cl-cadddr state)) |
|
||||||
(next (replace-regexp-in-string |
|
||||||
haskell-process-prompt-regex |
|
||||||
"" |
|
||||||
(substring buffer cursor)))) |
|
||||||
(haskell-interactive-mode-eval-result (car state) next) |
|
||||||
(setf (cl-cdddr state) (list (length buffer))) |
|
||||||
nil))) |
|
||||||
:complete |
|
||||||
(lambda (state response) |
|
||||||
(haskell-process-set-evaluating (cadr state) nil) |
|
||||||
(unless (haskell-interactive-mode-trigger-compile-error state response) |
|
||||||
(haskell-interactive-mode-expr-result state response))))))) |
|
||||||
|
|
||||||
(defun haskell-interactive-mode-expr-result (state response) |
|
||||||
"Print the result of evaluating the expression." |
|
||||||
(let ((response |
|
||||||
(with-temp-buffer |
|
||||||
(insert (haskell-interactive-mode-cleanup-response |
|
||||||
(cl-caddr state) response)) |
|
||||||
(haskell-interactive-mode-handle-h) |
|
||||||
(buffer-string)))) |
|
||||||
(when haskell-interactive-mode-eval-mode |
|
||||||
(unless (haskell-process-sent-stdin-p (cadr state)) |
|
||||||
(haskell-interactive-mode-eval-as-mode (car state) response)))) |
|
||||||
(haskell-interactive-mode-prompt (car state))) |
|
||||||
|
|
||||||
(defun haskell-interactive-mode-eval-as-mode (session text) |
|
||||||
"Insert TEXT font-locked according to `haskell-interactive-mode-eval-mode'." |
|
||||||
(with-current-buffer (haskell-session-interactive-buffer session) |
|
||||||
(let ((inhibit-read-only t)) |
|
||||||
(delete-region (1+ haskell-interactive-mode-prompt-start) (point)) |
|
||||||
(goto-char (point-max)) |
|
||||||
(let ((start (point))) |
|
||||||
(insert (haskell-fontify-as-mode text |
|
||||||
haskell-interactive-mode-eval-mode)) |
|
||||||
(when haskell-interactive-mode-collapse |
|
||||||
(haskell-collapse start (point))))))) |
|
||||||
|
|
||||||
(provide 'haskell-repl) |
|
||||||
@ -1,41 +0,0 @@ |
|||||||
;;; haskell-sandbox.el --- Support for sandboxes -*- 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) |
|
||||||
|
|
||||||
(defun haskell-sandbox-path (session) |
|
||||||
"Is there a cabal sandbox?" |
|
||||||
(concat (haskell-session-cabal-dir session) |
|
||||||
"/.cabal-sandbox")) |
|
||||||
|
|
||||||
(defun haskell-sandbox-exists-p (session) |
|
||||||
"Is there a cabal sandbox?" |
|
||||||
(file-exists-p (haskell-sandbox-path session))) |
|
||||||
|
|
||||||
(defun haskell-sandbox-pkgdb (session) |
|
||||||
"Get the package database of the sandbox." |
|
||||||
(let* ((files (directory-files (haskell-sandbox-path session))) |
|
||||||
(dir (car (cl-remove-if-not (lambda (file) |
|
||||||
(string-match ".conf.d$" file)) |
|
||||||
files)))) |
|
||||||
(when dir |
|
||||||
(concat (haskell-sandbox-path session) "/" dir)))) |
|
||||||
|
|
||||||
(provide 'haskell-sandbox) |
|
||||||
@ -1,230 +0,0 @@ |
|||||||
;;; haskell-session.el --- Haskell sessions -*- lexical-binding: t -*- |
|
||||||
|
|
||||||
;; Copyright (C) 2011-2012 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-cabal) |
|
||||||
(require 'haskell-string) |
|
||||||
(require 'haskell-customize) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Globals |
|
||||||
|
|
||||||
;; Used internally |
|
||||||
(defvar haskell-session) |
|
||||||
|
|
||||||
(make-variable-buffer-local 'haskell-session) |
|
||||||
|
|
||||||
(defvar haskell-sessions (list) |
|
||||||
"All Haskell sessions in the Emacs session.") |
|
||||||
|
|
||||||
(defun haskell-session-tags-filename (session) |
|
||||||
"Get the filename for the TAGS file." |
|
||||||
(concat (haskell-session-cabal-dir session) "/TAGS")) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Finding/clearing the session |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-maybe () |
|
||||||
"Maybe get the Haskell session, return nil if there isn't one." |
|
||||||
(if (default-boundp 'haskell-session) |
|
||||||
haskell-session |
|
||||||
(setq haskell-session nil))) |
|
||||||
|
|
||||||
(defun haskell-session-from-buffer () |
|
||||||
"Get the session based on the buffer." |
|
||||||
(when (and (buffer-file-name) |
|
||||||
(consp haskell-sessions)) |
|
||||||
(cl-reduce (lambda (acc a) |
|
||||||
(let ((dir (haskell-session-get a 'cabal-dir))) |
|
||||||
(if dir |
|
||||||
(if (string-prefix-p dir |
|
||||||
(file-name-directory (buffer-file-name))) |
|
||||||
(if acc |
|
||||||
(if (and |
|
||||||
(> (length (haskell-session-get a 'cabal-dir)) |
|
||||||
(length (haskell-session-get acc 'cabal-dir)))) |
|
||||||
a |
|
||||||
acc) |
|
||||||
a) |
|
||||||
acc) |
|
||||||
acc))) |
|
||||||
haskell-sessions |
|
||||||
:initial-value nil))) |
|
||||||
|
|
||||||
(defun haskell-session-default-name () |
|
||||||
"Generate a default project name for the new project prompt." |
|
||||||
(let ((file (haskell-cabal-find-file))) |
|
||||||
(or (when file |
|
||||||
(downcase (file-name-sans-extension |
|
||||||
(file-name-nondirectory file)))) |
|
||||||
"haskell"))) |
|
||||||
|
|
||||||
(defun haskell-session-assign (session) |
|
||||||
"Assing current buffer to SESSION. |
|
||||||
More verbose doc string for `haskell-session-assign` |
|
||||||
This could be helpfull for temporal or auxilar buffers such as |
|
||||||
presentation mode buffers (e.g. in case when session is killed |
|
||||||
with all relevant buffers)." |
|
||||||
(set (make-local-variable 'haskell-session) session)) |
|
||||||
|
|
||||||
(defun haskell-session-choose () |
|
||||||
"Find a session by choosing from a list of the current sessions." |
|
||||||
(when haskell-sessions |
|
||||||
(let* ((session-name (funcall haskell-completing-read-function |
|
||||||
"Choose Haskell session: " |
|
||||||
(cl-remove-if (lambda (name) |
|
||||||
(and haskell-session |
|
||||||
(string= (haskell-session-name haskell-session) |
|
||||||
name))) |
|
||||||
(mapcar 'haskell-session-name haskell-sessions)))) |
|
||||||
(session (cl-find-if (lambda (session) |
|
||||||
(string= (haskell-session-name session) |
|
||||||
session-name)) |
|
||||||
haskell-sessions))) |
|
||||||
session))) |
|
||||||
|
|
||||||
(defun haskell-session-clear () |
|
||||||
"Clear the buffer of any Haskell session choice." |
|
||||||
(set (make-local-variable 'haskell-session) nil)) |
|
||||||
|
|
||||||
(defun haskell-session-lookup (name) |
|
||||||
"Get the session by name." |
|
||||||
(cl-remove-if-not (lambda (s) |
|
||||||
(string= name (haskell-session-name s))) |
|
||||||
haskell-sessions)) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Session modules |
|
||||||
|
|
||||||
(defun haskell-session-strip-dir (session file) |
|
||||||
"Strip the load dir from the file path." |
|
||||||
(let ((cur-dir (haskell-session-current-dir session))) |
|
||||||
(if (> (length file) (length cur-dir)) |
|
||||||
(if (string= (substring file 0 (length cur-dir)) |
|
||||||
cur-dir) |
|
||||||
(replace-regexp-in-string |
|
||||||
"^[/\\]" "" |
|
||||||
(substring file |
|
||||||
(length cur-dir))) |
|
||||||
file) |
|
||||||
file))) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Accessing the session |
|
||||||
|
|
||||||
(defun haskell-session-current-dir (s) |
|
||||||
"Get the session current directory." |
|
||||||
(let ((dir (haskell-session-get s 'current-dir))) |
|
||||||
(or dir |
|
||||||
(error "No current directory.")))) |
|
||||||
|
|
||||||
(defun haskell-session-name (s) |
|
||||||
"Get the session name." |
|
||||||
(haskell-session-get s 'name)) |
|
||||||
|
|
||||||
(defun haskell-session-target (s) |
|
||||||
"Get the session build target. |
|
||||||
If `haskell-process-load-or-reload-prompt' is nil, accept `default'." |
|
||||||
(let* ((maybe-target (haskell-session-get s 'target)) |
|
||||||
(target (if maybe-target maybe-target |
|
||||||
(let ((new-target |
|
||||||
(if haskell-process-load-or-reload-prompt |
|
||||||
(read-string "build target (empty for default):") |
|
||||||
""))) |
|
||||||
(haskell-session-set-target s new-target))))) |
|
||||||
(if (not (string= target "")) target nil))) |
|
||||||
|
|
||||||
(defun haskell-session-set-target (s target) |
|
||||||
"Set the session build target." |
|
||||||
(haskell-session-set s 'target target)) |
|
||||||
|
|
||||||
(defun haskell-session-set-interactive-buffer (s v) |
|
||||||
"Set the session interactive buffer." |
|
||||||
(haskell-session-set s 'interactive-buffer v)) |
|
||||||
|
|
||||||
(defun haskell-session-set-process (s v) |
|
||||||
"Set the session process." |
|
||||||
(haskell-session-set s 'process v)) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-process (s) |
|
||||||
"Get the session process." |
|
||||||
(haskell-session-get s 'process)) |
|
||||||
|
|
||||||
(defun haskell-session-set-cabal-dir (s v) |
|
||||||
"Set the session cabal-dir." |
|
||||||
(let ((true-path (file-truename v))) |
|
||||||
(haskell-session-set s 'cabal-dir true-path) |
|
||||||
(haskell-session-set-cabal-checksum s true-path))) |
|
||||||
|
|
||||||
(defun haskell-session-set-current-dir (s v) |
|
||||||
"Set the session current directory." |
|
||||||
(let ((true-path (file-truename v))) |
|
||||||
(haskell-session-set s 'current-dir true-path))) |
|
||||||
|
|
||||||
(defun haskell-session-set-cabal-checksum (s cabal-dir) |
|
||||||
"Set the session checksum of .cabal files" |
|
||||||
(haskell-session-set s 'cabal-checksum |
|
||||||
(haskell-cabal-compute-checksum cabal-dir))) |
|
||||||
|
|
||||||
(defun haskell-session-cabal-dir (s) |
|
||||||
"Get the session cabal-dir." |
|
||||||
(or (haskell-session-get s 'cabal-dir) |
|
||||||
(let ((set-dir (haskell-cabal-get-dir (not haskell-process-load-or-reload-prompt)))) |
|
||||||
(if set-dir |
|
||||||
(progn (haskell-session-set-cabal-dir s set-dir) |
|
||||||
set-dir) |
|
||||||
(haskell-session-cabal-dir s))))) |
|
||||||
|
|
||||||
(defun haskell-session-modify (session key update) |
|
||||||
"Update the value at KEY in SESSION with UPDATE." |
|
||||||
(haskell-session-set |
|
||||||
session |
|
||||||
key |
|
||||||
(funcall update |
|
||||||
(haskell-session-get session key)))) |
|
||||||
|
|
||||||
(defun haskell-session-get (session key) |
|
||||||
"Get the SESSION's KEY value. |
|
||||||
Returns nil if KEY not set." |
|
||||||
(cdr (assq key session))) |
|
||||||
|
|
||||||
(defun haskell-session-set (session key value) |
|
||||||
"Set the SESSION's KEY to VALUE. |
|
||||||
Returns newly set VALUE." |
|
||||||
(let ((cell (assq key session))) |
|
||||||
(if cell |
|
||||||
(setcdr cell value) ; modify cell in-place |
|
||||||
(setcdr session (cons (cons key value) (cdr session))) ; new cell |
|
||||||
value))) |
|
||||||
|
|
||||||
(provide 'haskell-session) |
|
||||||
|
|
||||||
;;; haskell-session.el ends here |
|
||||||
@ -1,270 +0,0 @@ |
|||||||
;;; haskell-simple-indent.el --- Simple indentation module for Haskell Mode -*- lexical-binding: t -*- |
|
||||||
|
|
||||||
;; Copyright (C) 1998 Heribert Schuetz, Graeme E Moss |
|
||||||
|
|
||||||
;; Author: Heribert Schuetz <Heribert.Schuetz@informatik.uni-muenchen.de> |
|
||||||
;; Graeme E Moss <gem@cs.york.ac.uk> |
|
||||||
;; Keywords: indentation 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/>. |
|
||||||
|
|
||||||
;;; Commentary: |
|
||||||
|
|
||||||
;; Purpose: |
|
||||||
;; |
|
||||||
;; To support simple indentation of Haskell scripts. |
|
||||||
;; |
|
||||||
;; |
|
||||||
;; Installation: |
|
||||||
;; |
|
||||||
;; To bind TAB to the indentation command for all Haskell buffers, add |
|
||||||
;; this to .emacs: |
|
||||||
;; |
|
||||||
;; (add-hook 'haskell-mode-hook 'turn-on-haskell-simple-indent) |
|
||||||
;; |
|
||||||
;; Otherwise, call `turn-on-haskell-simple-indent'. |
|
||||||
;; |
|
||||||
;; |
|
||||||
;; Customisation: |
|
||||||
;; |
|
||||||
;; None supported. |
|
||||||
;; |
|
||||||
;; |
|
||||||
;; History: |
|
||||||
;; |
|
||||||
;; If you have any problems or suggestions, after consulting the list |
|
||||||
;; below, email gem@cs.york.ac.uk quoting the version of you are |
|
||||||
;; using, the version of Emacs you are using, and a small example of |
|
||||||
;; the problem or suggestion. |
|
||||||
;; |
|
||||||
;; Version 1.0: |
|
||||||
;; Brought over from Haskell mode v1.1. |
|
||||||
;; |
|
||||||
;; Present Limitations/Future Work (contributions are most welcome!): |
|
||||||
;; |
|
||||||
;; (None so far.) |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
;; All functions/variables start with |
|
||||||
;; `(turn-(on/off)-)haskell-simple-indent'. |
|
||||||
|
|
||||||
(require 'haskell-mode) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defgroup haskell-simple-indent nil |
|
||||||
"Simple Haskell indentation." |
|
||||||
:link '(custom-manual "(haskell-mode)Indentation") |
|
||||||
:group 'haskell |
|
||||||
:prefix "haskell-simple-indent-") |
|
||||||
|
|
||||||
;; Version. |
|
||||||
(defconst haskell-simple-indent-version "1.2" |
|
||||||
"`haskell-simple-indent' version number.") |
|
||||||
(defun haskell-simple-indent-version () |
|
||||||
"Echo the current version of `haskell-simple-indent' in the minibuffer." |
|
||||||
(interactive) |
|
||||||
(message "Using haskell-simple-indent version %s" |
|
||||||
haskell-simple-indent-version)) |
|
||||||
|
|
||||||
;; Partly stolen from `indent-relative' in indent.el: |
|
||||||
(defun haskell-simple-indent () |
|
||||||
"Space out to under next visible indent point. |
|
||||||
|
|
||||||
Indent points are positions of non-whitespace following |
|
||||||
whitespace in lines preceeding point. Example: |
|
||||||
|
|
||||||
func arg cx = when (isTrue) $ do |
|
||||||
print 42 |
|
||||||
^ ^ ^ ^ ^ ^ ^ ^ ^ ^ |
|
||||||
|
|
||||||
A position is visible if it is to the left of the first |
|
||||||
non-whitespace (indentation) of every nonblank line between the |
|
||||||
position and the current line. If there is no visible indent |
|
||||||
point beyond the current column, position given by |
|
||||||
`indent-next-tab-stop' is used instead." |
|
||||||
(interactive) |
|
||||||
(let* ((start-column (or (save-excursion |
|
||||||
(back-to-indentation) |
|
||||||
(if (not (eolp)) |
|
||||||
(current-column))) |
|
||||||
(current-column))) |
|
||||||
(invisible-from nil) ; `nil' means infinity here |
|
||||||
(found) |
|
||||||
(indent)) |
|
||||||
(save-excursion |
|
||||||
;; Loop stops if there no more lines above this one or when has |
|
||||||
;; found a line starting at first column. |
|
||||||
(while (and (not found) |
|
||||||
(or (not invisible-from) |
|
||||||
(not (zerop invisible-from))) |
|
||||||
(zerop (forward-line -1))) |
|
||||||
;; Ignore empty lines. |
|
||||||
(if (not (looking-at "[ \t]*\n")) |
|
||||||
(let ((this-indentation (current-indentation))) |
|
||||||
;; Is this line so indented that it cannot have |
|
||||||
;; influence on indentation points? |
|
||||||
(if (or (not invisible-from) |
|
||||||
(< this-indentation invisible-from)) |
|
||||||
(if (> this-indentation start-column) |
|
||||||
(setq invisible-from this-indentation) |
|
||||||
(let ((end (line-end-position))) |
|
||||||
(move-to-column start-column) |
|
||||||
;; Is start-column inside a tab on this line? |
|
||||||
(if (> (current-column) start-column) |
|
||||||
(backward-char 1)) |
|
||||||
;; Skip to the end of non-whitespace. |
|
||||||
(skip-chars-forward "^ \t" end) |
|
||||||
;; Skip over whitespace. |
|
||||||
(skip-chars-forward " \t" end) |
|
||||||
;; Indentation point found if not at the end of |
|
||||||
;; line and if not covered by any line below |
|
||||||
;; this one. In that case use invisible-from. |
|
||||||
(setq indent (if (or (= (point) end) |
|
||||||
(and invisible-from |
|
||||||
(> (current-column) invisible-from))) |
|
||||||
invisible-from |
|
||||||
(current-column))) |
|
||||||
;; Signal that solution is found. |
|
||||||
(setq found t)))))))) |
|
||||||
|
|
||||||
|
|
||||||
(let ((opoint (point-marker))) |
|
||||||
;; Indent to the calculated indent or last know invisible-from |
|
||||||
;; or use tab-to-tab-stop. Try hard to keep cursor in the same |
|
||||||
;; place or move it to the indentation if it was before it. And |
|
||||||
;; keep content of the line intact. |
|
||||||
(setq indent (or indent |
|
||||||
invisible-from |
|
||||||
(if (fboundp 'indent-next-tab-stop) |
|
||||||
(indent-next-tab-stop start-column)) |
|
||||||
(let ((tabs tab-stop-list)) |
|
||||||
(while (and tabs (>= start-column (car tabs))) |
|
||||||
(setq tabs (cdr tabs))) |
|
||||||
(if tabs (car tabs))) |
|
||||||
(* (/ (+ start-column tab-width) tab-width) tab-width))) |
|
||||||
(indent-line-to indent) |
|
||||||
(if (> opoint (point)) |
|
||||||
(goto-char opoint)) |
|
||||||
(set-marker opoint nil)))) |
|
||||||
|
|
||||||
(defun haskell-simple-indent-backtab () |
|
||||||
"Indent backwards. Dual to `haskell-simple-indent'." |
|
||||||
(interactive) |
|
||||||
(let ((saved-column (or (save-excursion |
|
||||||
(back-to-indentation) |
|
||||||
(if (not (eolp)) |
|
||||||
(current-column))) |
|
||||||
(current-column))) |
|
||||||
(i 0) |
|
||||||
(x 0)) |
|
||||||
|
|
||||||
(save-excursion |
|
||||||
(back-to-indentation) |
|
||||||
(delete-region (line-beginning-position) (point))) |
|
||||||
(while (< (or (save-excursion |
|
||||||
(back-to-indentation) |
|
||||||
(if (not (eolp)) |
|
||||||
(current-column))) |
|
||||||
(current-column)) saved-column) |
|
||||||
(haskell-simple-indent) |
|
||||||
(setq i (+ i 1))) |
|
||||||
|
|
||||||
(save-excursion |
|
||||||
(back-to-indentation) |
|
||||||
(delete-region (line-beginning-position) (point))) |
|
||||||
(while (< x (- i 1)) |
|
||||||
(haskell-simple-indent) |
|
||||||
(setq x (+ x 1))))) |
|
||||||
|
|
||||||
(defun haskell-simple-indent-newline-same-col () |
|
||||||
"Make a newline and go to the same column as the current line." |
|
||||||
(interactive) |
|
||||||
(let ((start-end |
|
||||||
(save-excursion |
|
||||||
(let* ((start (line-beginning-position)) |
|
||||||
(end (progn (goto-char start) |
|
||||||
(search-forward-regexp |
|
||||||
"[^ ]" (line-end-position) t 1)))) |
|
||||||
(when end (cons start (1- end))))))) |
|
||||||
(if start-end |
|
||||||
(progn (newline) |
|
||||||
(insert (buffer-substring-no-properties |
|
||||||
(car start-end) (cdr start-end)))) |
|
||||||
(newline)))) |
|
||||||
|
|
||||||
(defun haskell-simple-indent-newline-indent () |
|
||||||
"Make a newline on the current column and indent on step." |
|
||||||
(interactive) |
|
||||||
(haskell-simple-indent-newline-same-col) |
|
||||||
(insert (make-string haskell-indent-spaces ? ))) |
|
||||||
|
|
||||||
(defun haskell-simple-indent-comment-indent-function () |
|
||||||
"Haskell version of `comment-indent-function'." |
|
||||||
;; This is required when filladapt is turned off. Without it, when |
|
||||||
;; filladapt is not used, comments which start in column zero |
|
||||||
;; cascade one character to the right |
|
||||||
(save-excursion |
|
||||||
(beginning-of-line) |
|
||||||
(let ((eol (line-end-position))) |
|
||||||
(and comment-start-skip |
|
||||||
(re-search-forward comment-start-skip eol t) |
|
||||||
(setq eol (match-beginning 0))) |
|
||||||
(goto-char eol) |
|
||||||
(skip-chars-backward " \t") |
|
||||||
(max comment-column (+ (current-column) (if (bolp) 0 1)))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(define-minor-mode haskell-simple-indent-mode |
|
||||||
"Simple Haskell indentation mode that uses simple heuristic. |
|
||||||
In this minor mode, `indent-for-tab-command' (bound to <tab> by |
|
||||||
default) will move the cursor to the next indent point in the |
|
||||||
previous nonblank line, whereas `haskell-simple-indent-backtab' |
|
||||||
\ (bound to <backtab> by default) will move the cursor the |
|
||||||
previous indent point. An indent point is a non-whitespace |
|
||||||
character following whitespace. |
|
||||||
|
|
||||||
Runs `haskell-simple-indent-hook' on activation." |
|
||||||
:lighter " Ind" |
|
||||||
:group 'haskell-simple-indent |
|
||||||
:keymap '(([backtab] . haskell-simple-indent-backtab)) |
|
||||||
(kill-local-variable 'comment-indent-function) |
|
||||||
(kill-local-variable 'indent-line-function) |
|
||||||
(when haskell-simple-indent-mode |
|
||||||
(set (make-local-variable 'comment-indent-function) #'haskell-simple-indent-comment-indent-function) |
|
||||||
(set (make-local-variable 'indent-line-function) 'haskell-simple-indent) |
|
||||||
(run-hooks 'haskell-simple-indent-hook))) |
|
||||||
|
|
||||||
;; The main functions. |
|
||||||
;;;###autoload |
|
||||||
(defun turn-on-haskell-simple-indent () |
|
||||||
"Turn on function `haskell-simple-indent-mode'." |
|
||||||
(interactive) |
|
||||||
(haskell-simple-indent-mode)) |
|
||||||
(make-obsolete 'turn-on-haskell-simple-indent |
|
||||||
'haskell-simple-indent-mode |
|
||||||
"2015-07-23") |
|
||||||
|
|
||||||
(defun turn-off-haskell-simple-indent () |
|
||||||
"Turn off function `haskell-simple-indent-mode'." |
|
||||||
(interactive) |
|
||||||
(haskell-simple-indent-mode 0)) |
|
||||||
|
|
||||||
;; Provide ourselves: |
|
||||||
|
|
||||||
(provide 'haskell-simple-indent) |
|
||||||
|
|
||||||
;;; haskell-simple-indent.el ends here |
|
||||||
@ -1,129 +0,0 @@ |
|||||||
;;; haskell-sort-imports.el --- Sort the list of Haskell imports at the point alphabetically -*- 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: |
|
||||||
|
|
||||||
;; If the region is active it sorts the imports within the |
|
||||||
;; region. |
|
||||||
|
|
||||||
;; This will align and sort the columns of the current import |
|
||||||
;; list. It's more or less the coolest thing on the planet. |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(require 'cl-lib) |
|
||||||
|
|
||||||
(defvar haskell-sort-imports-regexp |
|
||||||
(concat "^import[ ]+" |
|
||||||
"\\(qualified \\)?" |
|
||||||
"[ ]*\\(\"[^\"]*\" \\)?" |
|
||||||
"[ ]*\\([A-Za-z0-9_.']*.*\\)")) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-sort-imports () |
|
||||||
"Sort the import list at point. It sorts the current group |
|
||||||
i.e. an import list separated by blank lines on either side. |
|
||||||
|
|
||||||
If the region is active, it will restrict the imports to sort |
|
||||||
within that region." |
|
||||||
(interactive) |
|
||||||
(when (haskell-sort-imports-at-import) |
|
||||||
(let* ((points (haskell-sort-imports-decl-points)) |
|
||||||
(current-string (buffer-substring-no-properties (car points) |
|
||||||
(cdr points))) |
|
||||||
(current-offset (- (point) (car points)))) |
|
||||||
(if (region-active-p) |
|
||||||
(progn (goto-char (region-beginning)) |
|
||||||
(haskell-sort-imports-goto-import-start)) |
|
||||||
(haskell-sort-imports-goto-group-start)) |
|
||||||
(let* ((start (point)) |
|
||||||
(imports (haskell-sort-imports-collect-imports)) |
|
||||||
(sorted (sort (cl-copy-list imports) |
|
||||||
(lambda (a b) |
|
||||||
(string< (haskell-sort-imports-normalize a) |
|
||||||
(haskell-sort-imports-normalize b)))))) |
|
||||||
(when (not (equal imports sorted)) |
|
||||||
(delete-region start (point)) |
|
||||||
(mapc (lambda (import) (insert import "\n")) sorted)) |
|
||||||
(goto-char start) |
|
||||||
(when (search-forward current-string nil t 1) |
|
||||||
(forward-char (- (length current-string))) |
|
||||||
(forward-char current-offset)))))) |
|
||||||
|
|
||||||
(defun haskell-sort-imports-normalize (i) |
|
||||||
"Normalize an import, if possible, so that it can be sorted." |
|
||||||
(if (string-match haskell-sort-imports-regexp |
|
||||||
i) |
|
||||||
(match-string 3 i) |
|
||||||
i)) |
|
||||||
|
|
||||||
(defun haskell-sort-imports-collect-imports () |
|
||||||
(let ((imports (list))) |
|
||||||
(while (looking-at "import") |
|
||||||
(let* ((points (haskell-sort-imports-decl-points)) |
|
||||||
(string (buffer-substring-no-properties (car points) |
|
||||||
(cdr points)))) |
|
||||||
(goto-char (min (1+ (cdr points)) |
|
||||||
(point-max))) |
|
||||||
(setq imports (cons string imports)))) |
|
||||||
(reverse (delq nil (delete-dups imports))))) |
|
||||||
|
|
||||||
(defun haskell-sort-imports-goto-group-start () |
|
||||||
"Go to the start of the import group." |
|
||||||
(or (and (search-backward "\n\n" nil t 1) |
|
||||||
(goto-char (+ 2 (line-end-position)))) |
|
||||||
(when (search-backward-regexp "^module " nil t 1) |
|
||||||
(goto-char (1+ (line-end-position)))) |
|
||||||
(goto-char (point-min)))) |
|
||||||
|
|
||||||
(defun haskell-sort-imports-at-import () |
|
||||||
"Are we at an import?" |
|
||||||
(save-excursion |
|
||||||
(haskell-sort-imports-goto-import-start) |
|
||||||
(looking-at "import"))) |
|
||||||
|
|
||||||
(defun haskell-sort-imports-goto-import-start () |
|
||||||
"Go to the start of the import." |
|
||||||
(goto-char (car (haskell-sort-imports-decl-points)))) |
|
||||||
|
|
||||||
(defun haskell-sort-imports-decl-points () |
|
||||||
"Get the points of the declaration." |
|
||||||
(save-excursion |
|
||||||
(let ((start (or (progn (goto-char (line-end-position)) |
|
||||||
(search-backward-regexp "^[^ \n]" nil t 1) |
|
||||||
(unless (or (looking-at "^-}$") |
|
||||||
(looking-at "^{-$")) |
|
||||||
(point))) |
|
||||||
0)) |
|
||||||
(end (progn (goto-char (1+ (point))) |
|
||||||
(or (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) |
|
||||||
(forward-char -1) |
|
||||||
(search-backward-regexp "[^\n ]" nil t) |
|
||||||
(line-end-position)) |
|
||||||
(when (search-forward-regexp "\n" nil t 1) |
|
||||||
(1- (point))) |
|
||||||
(point-max))))) |
|
||||||
(cons start end)))) |
|
||||||
|
|
||||||
(provide 'haskell-sort-imports) |
|
||||||
|
|
||||||
;;; haskell-sort-imports.el ends here |
|
||||||
@ -1,167 +0,0 @@ |
|||||||
;;; haskell-string.el --- Haskell related string utilities -*- 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: |
|
||||||
|
|
||||||
;;; Todo: |
|
||||||
|
|
||||||
;; - write ERT tests |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(defun haskell-string-trim (string) |
|
||||||
"Remove whitespace around STRING. |
|
||||||
|
|
||||||
A Whitespace character is defined in the Haskell Report as follows |
|
||||||
|
|
||||||
whitechar -> newline | vertab | space | tab | uniWhite |
|
||||||
newline -> return linefeed | return | linefeed | formfeed |
|
||||||
uniWhite -> any Unicode character defined as whitespace |
|
||||||
|
|
||||||
Note: The implementation currently only supports ASCII |
|
||||||
white-space characters, i.e. the implemention doesn't |
|
||||||
consider uniWhite." |
|
||||||
|
|
||||||
(let ((s1 (if (string-match "[\t\n\v\f\r ]+\\'" string) (replace-match "" t t string) string))) |
|
||||||
(if (string-match "\\`[\t\n\v\f\r ]+" s1) (replace-match "" t t s1) s1))) |
|
||||||
|
|
||||||
(defun haskell-string-only-spaces-p (string) |
|
||||||
"Return t if STRING contains only whitespace (or is empty)." |
|
||||||
(string= "" (haskell-string-trim string))) |
|
||||||
|
|
||||||
(defun haskell-string-take (string n) |
|
||||||
"Return (up to) N character length prefix of STRING." |
|
||||||
(substring string 0 (min (length string) n))) |
|
||||||
|
|
||||||
(defconst haskell-string-literal-encode-ascii-array |
|
||||||
[ "\\NUL" "\\SOH" "\\STX" "\\ETX" "\\EOT" "\\ENQ" "\\ACK" "\\a" "\\b" "\\t" "\\n" "\\v" "\\f" "\\r" "\\SO" "\\SI" "\\DLE" "\\DC1" "\\DC2" "\\DC3" "\\DC4" "\\NAK" "\\SYN" "\\ETB" "\\CAN" "\\EM" "\\SUB" "\\ESC" "\\FS" "\\GS" "\\RS" "\\US" " " "!" "\\\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?" "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\\\" "]" "^" "_" "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "\\DEL" ] |
|
||||||
"Array of encodings for 7-bit ASCII character points indexed by ASCII value.") |
|
||||||
|
|
||||||
(defun haskell-string-literal-encode (str &optional no-quotes) |
|
||||||
"Encode STR according Haskell escape rules using 7-bit ASCII representation. |
|
||||||
|
|
||||||
The serialization has been implement to closely match the |
|
||||||
behaviour of GHC's Show instance for Strings. |
|
||||||
|
|
||||||
If NO-QUOTES is non-nil, omit wrapping result in quotes. |
|
||||||
|
|
||||||
This is the dual operation to `haskell-string-literal-decode'." |
|
||||||
|
|
||||||
(let ((lastc -1)) |
|
||||||
(let ((encode (lambda (c) |
|
||||||
(let ((lc lastc)) |
|
||||||
(setq lastc c) |
|
||||||
(if (>= c 128) ;; if non-ASCII code point |
|
||||||
(format "\\%d" c) |
|
||||||
;; else, for ASCII code points |
|
||||||
(if (or (and (= lc 14) (= c ?H)) ;; "\SO\&H" |
|
||||||
(and (>= lc 128) (>= c ?0) (<= c ?9))) ;; "\123\&4" |
|
||||||
(concat "\\&" (aref haskell-string-literal-encode-ascii-array c)) |
|
||||||
(aref haskell-string-literal-encode-ascii-array c) |
|
||||||
)))))) |
|
||||||
|
|
||||||
(if no-quotes |
|
||||||
(mapconcat encode str "") |
|
||||||
(concat "\"" (mapconcat encode str "") "\""))))) |
|
||||||
|
|
||||||
(defconst haskell-string-literal-escapes-regexp |
|
||||||
(concat "[\\]\\(?:" |
|
||||||
(regexp-opt (append |
|
||||||
(mapcar (lambda (c) (format "%c" c)) |
|
||||||
"abfnrtv\\\"'&") ;; "charesc" escape sequences |
|
||||||
(mapcar (lambda (c) (format "^%c" c)) |
|
||||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZ@[\\]^_") ;; "cntrl" escape sequences |
|
||||||
(mapcar (lambda (s) (format "%s" s)) |
|
||||||
(split-string "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")))) ;; "ascii" (w\o "cntrl") escape sequences |
|
||||||
"\\|" "[\t\n\v\f\r ]+[\\]" ;; whitespace gaps |
|
||||||
"\\|" "[0-9]+" ;; decimal escape sequence |
|
||||||
"\\|" "o[0-7]+" ;; octal escape sequence |
|
||||||
"\\|" "x[0-9a-f]+" ;; hex escape sequence |
|
||||||
"\\)?") ;; everything else is an invalid escape sequence |
|
||||||
"Regexp for matching escape codes in string literals. |
|
||||||
See Haskell Report Sect 2.6, |
|
||||||
URL `http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6', |
|
||||||
for more details.") |
|
||||||
|
|
||||||
(defconst haskell-string-literal-decode1-table |
|
||||||
(let ((h (make-hash-table :test 'equal))) |
|
||||||
(mapc (lambda (c) (puthash (concat "\\" (car c)) (cdr c) h)) |
|
||||||
'(;; ascii-escapes |
|
||||||
("NUL" . "\x00") ("SOH" . "\x01") ("STX" . "\x02") ("ETX" . "\x03") ("EOT" . "\x04") ("ENQ" . "\x05") |
|
||||||
("ACK" . "\x06") ("BEL" . "\x07") ("BS" . "\x08") ("HT" . "\x09") ("LF" . "\x0a") ("VT" . "\x0b") |
|
||||||
("FF" . "\x0c") ("CR" . "\x0d") ("SO" . "\x0e") ("SI" . "\x0f") ("DLE" . "\x10") ("DC1" . "\x11") |
|
||||||
("DC2" . "\x12") ("DC3" . "\x13") ("DC4" . "\x14") ("NAK" . "\x15") ("SYN" . "\x16") ("ETB" . "\x17") |
|
||||||
("CAN" . "\x18") ("EM" . "\x19") ("SUB" . "\x1a") ("ESC" . "\x1b") ("FS" . "\x1c") ("GS" . "\x1d") |
|
||||||
("RS" . "\x1e") ("US" . "\x1f") ("SP" . "\x20") ("DEL" . "\x7f" ) |
|
||||||
;; C-compatible single-char escape sequences |
|
||||||
("a" . "\x07") ("b" . "\x08") ("f" . "\x0c") ("n" . "\x0a") ("r" . "\x0d") ("t" . "\x09") ("v" . "\x0b") |
|
||||||
;; trivial escapes |
|
||||||
("\\" . "\\") ("\"" . "\"") ("'" . "'") |
|
||||||
;; "empty" escape |
|
||||||
("&" . ""))) |
|
||||||
h) |
|
||||||
"Hash table containing irregular escape sequences and their decoded strings. |
|
||||||
Used by `haskell-string-literal-decode1'.") |
|
||||||
|
|
||||||
(defun haskell-string-literal-decode1 (l) |
|
||||||
"Decode a single string literal escape sequence. |
|
||||||
L must contain exactly one escape sequence. |
|
||||||
This is an internal function used by `haskell-string-literal-decode'." |
|
||||||
(let ((case-fold-search nil)) |
|
||||||
(cond |
|
||||||
((gethash l haskell-string-literal-decode1-table)) |
|
||||||
((string-match "\\`[\\][0-9]+\\'" l) (char-to-string (string-to-number (substring l 1) 10))) |
|
||||||
((string-match "\\`[\\]x[[:xdigit:]]+\\'" l) (char-to-string (string-to-number (substring l 2) 16))) |
|
||||||
((string-match "\\`[\\]o[0-7]+\\'" l) (char-to-string (string-to-number (substring l 2) 8))) |
|
||||||
((string-match "\\`[\\]\\^[@-_]\\'" l) (char-to-string (- (aref l 2) ?@))) ;; "cntrl" escapes |
|
||||||
((string-match "\\`[\\][\t\n\v\f\r ]+[\\]\\'" l) "") ;; whitespace gap |
|
||||||
(t (error "Invalid escape sequence"))))) |
|
||||||
|
|
||||||
(defun haskell-string-literal-decode (estr &optional no-quotes) |
|
||||||
"Decode a Haskell string-literal. |
|
||||||
If NO-QUOTES is nil, ESTR must be surrounded by quotes. |
|
||||||
|
|
||||||
This is the dual operation to `haskell-string-literal-encode'." |
|
||||||
(if (and (not no-quotes) |
|
||||||
(string-match-p "\\`\"[^\\\"[:cntrl:]]*\"\\'" estr)) |
|
||||||
(substring estr 1 -1) ;; optimized fast-path for trivial strings |
|
||||||
(let ((s (if no-quotes ;; else: do general decoding |
|
||||||
estr |
|
||||||
(if (string-match-p "\\`\".*\"\\'" estr) |
|
||||||
(substring estr 1 -1) |
|
||||||
(error "String literal must be delimited by quotes")))) |
|
||||||
(case-fold-search nil)) |
|
||||||
(replace-regexp-in-string haskell-string-literal-escapes-regexp #'haskell-string-literal-decode1 s t t)))) |
|
||||||
|
|
||||||
(defun haskell-string-ellipsize (string n) |
|
||||||
"Return STRING truncated to (at most) N characters. |
|
||||||
If truncation occured, last character in string is replaced by `…'. |
|
||||||
See also `haskell-string-take'." |
|
||||||
(cond |
|
||||||
((<= (length string) n) string) ;; no truncation needed |
|
||||||
((< n 1) "") |
|
||||||
(t (concat (substring string 0 (1- n)) "…")))) |
|
||||||
|
|
||||||
(provide 'haskell-string) |
|
||||||
|
|
||||||
;;; haskell-string.el ends here |
|
||||||
@ -1,301 +0,0 @@ |
|||||||
;;; haskell-unicode-input-method.el --- Haskell Unicode helper functions -*- coding: utf-8; lexical-binding: t -*- |
|
||||||
|
|
||||||
;; Copyright (C) 2010-2011 Roel van Dijk |
|
||||||
|
|
||||||
;; Author: Roel van Dijk <vandijk.roel@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 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: |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(require 'quail) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun turn-on-haskell-unicode-input-method () |
|
||||||
"Set input method `haskell-unicode'. |
|
||||||
See Info node `Unicode(haskell-mode)' for more details." |
|
||||||
(interactive) |
|
||||||
(set-input-method "haskell-unicode")) |
|
||||||
|
|
||||||
(quail-define-package |
|
||||||
"haskell-unicode" ;; name |
|
||||||
"UTF-8" ;; language |
|
||||||
"\\" ;; title |
|
||||||
t ;; guidance |
|
||||||
"Haskell Unicode input method. |
|
||||||
Designed to be used with the Haskell UnicodeSyntax language |
|
||||||
extension in combination with the x-unicode-symbols set of |
|
||||||
packages (base-unicode-symbols and containers-unicode-symbols). |
|
||||||
" ;; docstring |
|
||||||
nil ;; translation-keys |
|
||||||
nil ;; forget-last-selection |
|
||||||
nil ;; deterministic |
|
||||||
nil ;; kbd-translate |
|
||||||
nil ;; show-layout |
|
||||||
nil ;; create-decode-map |
|
||||||
nil ;; maximum-shortest |
|
||||||
nil ;; overlay-plist |
|
||||||
nil ;; update-translation-function |
|
||||||
nil ;; conversion-keys |
|
||||||
t ;; simple |
|
||||||
) |
|
||||||
|
|
||||||
(quail-define-rules |
|
||||||
;; Greek letters |
|
||||||
("alpha " ["α"]) |
|
||||||
("Alpha " ["Α"]) |
|
||||||
("beta " ["β"]) |
|
||||||
("Beta " ["Β"]) |
|
||||||
("gamma " ["γ"]) |
|
||||||
("Gamma " ["Γ"]) |
|
||||||
("delta " ["δ"]) |
|
||||||
("Delta " ["Δ"]) |
|
||||||
("epsilon " ["ε"]) |
|
||||||
("Epsilon " ["Ε"]) |
|
||||||
("zeta " ["ζ"]) |
|
||||||
("Zeta " ["Ζ"]) |
|
||||||
("eta " ["η"]) |
|
||||||
("Eta " ["Η"]) |
|
||||||
("theta " ["θ"]) |
|
||||||
("Theta " ["Θ"]) |
|
||||||
("iota " ["ι"]) |
|
||||||
("Iota " ["Ι"]) |
|
||||||
("kappa " ["κ"]) |
|
||||||
("Kappa " ["Κ"]) |
|
||||||
("lambda " ["λ"]) |
|
||||||
("Lambda " ["Λ"]) |
|
||||||
("lamda " ["λ"]) |
|
||||||
("Lamda " ["Λ"]) |
|
||||||
("mu " ["μ"]) |
|
||||||
("Mu " ["Μ"]) |
|
||||||
("nu " ["ν"]) |
|
||||||
("Nu " ["Ν"]) |
|
||||||
("xi " ["ξ"]) |
|
||||||
("Xi " ["Ξ"]) |
|
||||||
("omicron " ["ο"]) |
|
||||||
("Omicron " ["Ο"]) |
|
||||||
("pi " ["π"]) |
|
||||||
("Pi " ["Π"]) |
|
||||||
("rho " ["ρ"]) |
|
||||||
("Rho " ["Ρ"]) |
|
||||||
("sigma " ["σ"]) |
|
||||||
("Sigma " ["Σ"]) |
|
||||||
("tau " ["τ"]) |
|
||||||
("Tau " ["Τ"]) |
|
||||||
("upsilon " ["υ"]) |
|
||||||
("Upsilon " ["Υ"]) |
|
||||||
("phi " ["φ"]) |
|
||||||
("Phi " ["Φ"]) |
|
||||||
("chi " ["χ"]) |
|
||||||
("Chi " ["Χ"]) |
|
||||||
("psi " ["ψ"]) |
|
||||||
("Psi " ["Ψ"]) |
|
||||||
("omega " ["ω"]) |
|
||||||
("Omega " ["Ω"]) |
|
||||||
("digamma " ["ϝ"]) |
|
||||||
("Digamma " ["Ϝ"]) |
|
||||||
("san " ["ϻ"]) |
|
||||||
("San " ["Ϻ"]) |
|
||||||
("qoppa " ["ϙ"]) |
|
||||||
("Qoppa " ["Ϙ"]) |
|
||||||
("sampi " ["ϡ"]) |
|
||||||
("Sampi " ["Ϡ"]) |
|
||||||
("stigma " ["ϛ"]) |
|
||||||
("Stigma " ["Ϛ"]) |
|
||||||
("heta " ["ͱ"]) |
|
||||||
("Heta " ["Ͱ"]) |
|
||||||
("sho " ["ϸ"]) |
|
||||||
("Sho " ["Ϸ"]) |
|
||||||
|
|
||||||
;; Double-struck letters |
|
||||||
("|A|" ["𝔸"]) |
|
||||||
("|B|" ["𝔹"]) |
|
||||||
("|C|" ["ℂ"]) |
|
||||||
("|D|" ["𝔻"]) |
|
||||||
("|E|" ["𝔼"]) |
|
||||||
("|F|" ["𝔽"]) |
|
||||||
("|G|" ["𝔾"]) |
|
||||||
("|H|" ["ℍ"]) |
|
||||||
("|I|" ["𝕀"]) |
|
||||||
("|J|" ["𝕁"]) |
|
||||||
("|K|" ["𝕂"]) |
|
||||||
("|L|" ["𝕃"]) |
|
||||||
("|M|" ["𝕄"]) |
|
||||||
("|N|" ["ℕ"]) |
|
||||||
("|O|" ["𝕆"]) |
|
||||||
("|P|" ["ℙ"]) |
|
||||||
("|Q|" ["ℚ"]) |
|
||||||
("|R|" ["ℝ"]) |
|
||||||
("|S|" ["𝕊"]) |
|
||||||
("|T|" ["𝕋"]) |
|
||||||
("|U|" ["𝕌"]) |
|
||||||
("|V|" ["𝕍"]) |
|
||||||
("|W|" ["𝕎"]) |
|
||||||
("|X|" ["𝕏"]) |
|
||||||
("|Y|" ["𝕐"]) |
|
||||||
("|Z|" ["ℤ"]) |
|
||||||
("|gamma|" ["ℽ"]) |
|
||||||
("|Gamma|" ["ℾ"]) |
|
||||||
("|pi|" ["ℼ"]) |
|
||||||
("|Pi|" ["ℿ"]) |
|
||||||
|
|
||||||
;; Types |
|
||||||
("::" ["∷"]) |
|
||||||
|
|
||||||
;; Quantifiers |
|
||||||
("forall" ["∀"]) |
|
||||||
("exists" ["∃"]) |
|
||||||
|
|
||||||
;; Arrows |
|
||||||
("->" ["→"]) |
|
||||||
;; ("-->" ["⟶"]) |
|
||||||
("<-" ["←"]) |
|
||||||
;; ("<--" ["⟵"]) |
|
||||||
;; ("<->" ["↔"]) |
|
||||||
;; ("<-->" ["⟷"]) |
|
||||||
|
|
||||||
("=>" ["⇒"]) |
|
||||||
;; ("==>" ["⟹"]) |
|
||||||
;; ("<=" ["⇐"]) |
|
||||||
;; ("<==" ["⟸"]) |
|
||||||
;; ("<=>" ["⇔"]) |
|
||||||
;; ("<==>" ["⟺"]) |
|
||||||
|
|
||||||
;; ("|->" ["↦"]) |
|
||||||
;; ("|-->" ["⟼"]) |
|
||||||
;; ("<-|" ["↤"]) |
|
||||||
;; ("<--|" ["⟻"]) |
|
||||||
|
|
||||||
;; ("|=>" ["⤇"]) |
|
||||||
;; ("|==>" ["⟾"]) |
|
||||||
;; ("<=|" ["⤆"]) |
|
||||||
;; ("<==|" ["⟽"]) |
|
||||||
|
|
||||||
("~>" ["⇝"]) |
|
||||||
;; ("~~>" ["⟿"]) |
|
||||||
("<~" ["⇜"]) |
|
||||||
;; ("<~~" ["⬳"]) |
|
||||||
|
|
||||||
;; (">->" ["↣"]) |
|
||||||
;; ("<-<" ["↢"]) |
|
||||||
;; ("->>" ["↠"]) |
|
||||||
;; ("<<-" ["↞"]) |
|
||||||
|
|
||||||
;; (">->>" ["⤖"]) |
|
||||||
;; ("<<-<" ["⬻"]) |
|
||||||
|
|
||||||
;; ("<|-" ["⇽"]) |
|
||||||
;; ("-|>" ["⇾"]) |
|
||||||
;; ("<|-|>" ["⇿"]) |
|
||||||
|
|
||||||
;; ("<-/-" ["↚"]) |
|
||||||
;; ("-/->" ["↛"]) |
|
||||||
|
|
||||||
;; ("<-|-" ["⇷"]) |
|
||||||
;; ("-|->" ["⇸"]) |
|
||||||
;; ("<-|->" ["⇹"]) |
|
||||||
|
|
||||||
;; ("<-||-" ["⇺"]) |
|
||||||
;; ("-||->" ["⇻"]) |
|
||||||
;; ("<-||->" ["⇼"]) |
|
||||||
|
|
||||||
;; ("-o->" ["⇴"]) |
|
||||||
;; ("<-o-" ["⬰"]) |
|
||||||
|
|
||||||
;; Boolean operators |
|
||||||
;; ("not" ["¬"]) |
|
||||||
("&&" ["∧"]) |
|
||||||
("||" ["∨"]) |
|
||||||
|
|
||||||
;; Relational operators |
|
||||||
("==" ["≡"]) |
|
||||||
("/=" ["≢" "≠"]) |
|
||||||
("<=" ["≤"]) |
|
||||||
(">=" ["≥"]) |
|
||||||
("/<" ["≮"]) |
|
||||||
("/>" ["≯"]) |
|
||||||
|
|
||||||
;; Arithmetic |
|
||||||
;; (" / " [" ÷ "]) |
|
||||||
(" * " [" ⋅ "]) |
|
||||||
|
|
||||||
;; Containers / Collections |
|
||||||
;; ("++" ["⧺"]) |
|
||||||
;; ("+++" ["⧻"]) |
|
||||||
;; ("|||" ["⫴"]) |
|
||||||
;; ("empty" ["∅"]) |
|
||||||
("elem" ["∈"]) |
|
||||||
("notElem" ["∉"]) |
|
||||||
("member" ["∈"]) |
|
||||||
("notMember" ["∉"]) |
|
||||||
("union" ["∪"]) |
|
||||||
("intersection" ["∩"]) |
|
||||||
("isSubsetOf" ["⊆"]) |
|
||||||
("isProperSubsetOf" ["⊂"]) |
|
||||||
|
|
||||||
;; Other |
|
||||||
;; ("<<" ["≪"]) |
|
||||||
;; (">>" ["≫"]) |
|
||||||
("<<<" ["⋘"]) |
|
||||||
(">>>" ["⋙"]) |
|
||||||
("<|" ["⊲"]) |
|
||||||
("|>" ["⊳"]) |
|
||||||
("><" ["⋈"]) |
|
||||||
;; ("mempty" ["∅"]) |
|
||||||
("mappend" ["⊕"]) |
|
||||||
;; ("<*>" ["⊛"]) |
|
||||||
(" . " [" ∘ "]) |
|
||||||
("undefined" ["⊥"]) |
|
||||||
(":=" ["≔"]) |
|
||||||
("=:" ["≕"]) |
|
||||||
("=def" ["≝"]) |
|
||||||
("=?" ["≟"]) |
|
||||||
("..." ["…"]) |
|
||||||
|
|
||||||
;; Braces |
|
||||||
;; ("[|" ["〚"]) |
|
||||||
;; ("|]" ["〛"]) |
|
||||||
|
|
||||||
;; Numeric subscripts |
|
||||||
("_0 " ["₀"]) |
|
||||||
("_1 " ["₁"]) |
|
||||||
("_2 " ["₂"]) |
|
||||||
("_3 " ["₃"]) |
|
||||||
("_4 " ["₄"]) |
|
||||||
("_5 " ["₅"]) |
|
||||||
("_6 " ["₆"]) |
|
||||||
("_7 " ["₇"]) |
|
||||||
("_8 " ["₈"]) |
|
||||||
("_9 " ["₉"]) |
|
||||||
|
|
||||||
;; Numeric superscripts |
|
||||||
("^0 " ["⁰"]) |
|
||||||
("^1 " ["¹"]) |
|
||||||
("^2 " ["²"]) |
|
||||||
("^3 " ["³"]) |
|
||||||
("^4 " ["⁴"]) |
|
||||||
("^5 " ["⁵"]) |
|
||||||
("^6 " ["⁶"]) |
|
||||||
("^7 " ["⁷"]) |
|
||||||
("^8 " ["⁸"]) |
|
||||||
("^9 " ["⁹"]) |
|
||||||
) |
|
||||||
|
|
||||||
(provide 'haskell-unicode-input-method) |
|
||||||
|
|
||||||
;;; haskell-unicode-input-method.el ends here |
|
||||||
@ -1,164 +0,0 @@ |
|||||||
;;; haskell-utils.el --- General utility functions used by haskell-mode modules -*- 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: |
|
||||||
|
|
||||||
;; This module's purpose is to provide a place for helper functions |
|
||||||
;; which are general enough to be usable by multiple modules and/or |
|
||||||
;; to alleviate circular module dependency problems. |
|
||||||
;; |
|
||||||
;; When possible, functions in this module shall be accompanied by |
|
||||||
;; ERT-based unit tests. |
|
||||||
;; |
|
||||||
;; See also `haskell-str.el' for string utility functions. |
|
||||||
;; |
|
||||||
;; All symbols in this module have a `haskell-utils-' prefix. |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
;; NOTE: This module is supposed to be a leaf-module and shall not |
|
||||||
;; require/depend-on any other haskell-mode modules in order to |
|
||||||
;; stay at the bottom of the module dependency graph. |
|
||||||
|
|
||||||
(require 'haskell-customize) |
|
||||||
|
|
||||||
(defvar haskell-utils-async-post-command-flag nil |
|
||||||
"Non-nil means some commands were triggered during async function execution.") |
|
||||||
(make-variable-buffer-local 'haskell-utils-async-post-command-flag) |
|
||||||
|
|
||||||
(defun haskell-utils-read-directory-name (prompt default) |
|
||||||
"Read directory name and normalize to true absolute path. |
|
||||||
Refer to `read-directory-name' for the meaning of PROMPT and |
|
||||||
DEFAULT. If `haskell-process-load-or-reload-prompt' is nil, accept `default'." |
|
||||||
(let ((filename (file-truename (read-directory-name prompt default default)))) |
|
||||||
(concat (replace-regexp-in-string "/$" "" filename) "/"))) |
|
||||||
|
|
||||||
(defun haskell-utils-parse-import-statement-at-point () |
|
||||||
"Return imported module name if on import statement or nil otherwise. |
|
||||||
This currently assumes that the \"import\" keyword and the module |
|
||||||
name are on the same line. |
|
||||||
|
|
||||||
This function supports the SafeHaskell and PackageImports syntax extensions. |
|
||||||
|
|
||||||
Note: doesn't detect if in {--}-style comment." |
|
||||||
(save-excursion |
|
||||||
(goto-char (line-beginning-position)) |
|
||||||
(if (looking-at (concat "[\t ]*import[\t ]+" |
|
||||||
"\\(?:safe[\t ]+\\)?" ;; SafeHaskell |
|
||||||
"\\(?:qualified[\t ]+\\)?" |
|
||||||
"\\(?:\"[^\"]*\"[\t ]+\\)?" ;; PackageImports |
|
||||||
"\\([[:digit:][:upper:][:lower:]_.]+\\)")) |
|
||||||
(match-string-no-properties 1)))) |
|
||||||
|
|
||||||
(defun haskell-utils-async-update-post-command-flag () |
|
||||||
"A special hook which collects triggered commands during async execution. |
|
||||||
This hook pushes value of variable `this-command' to flag variable |
|
||||||
`haskell-utils-async-post-command-flag'." |
|
||||||
(let* ((cmd this-command) |
|
||||||
(updated-flag (cons cmd haskell-utils-async-post-command-flag))) |
|
||||||
(setq haskell-utils-async-post-command-flag updated-flag))) |
|
||||||
|
|
||||||
(defun haskell-utils-async-watch-changes () |
|
||||||
"Watch for triggered commands during async operation execution. |
|
||||||
Resets flag variable |
|
||||||
`haskell-utils-async-update-post-command-flag' to NIL. By chanhges it is |
|
||||||
assumed that nothing happened, e.g. nothing was inserted in |
|
||||||
buffer, point was not moved, etc. To collect data `post-command-hook' is used." |
|
||||||
(setq haskell-utils-async-post-command-flag nil) |
|
||||||
(add-hook |
|
||||||
'post-command-hook #'haskell-utils-async-update-post-command-flag nil t)) |
|
||||||
|
|
||||||
(defun haskell-utils-async-stop-watching-changes (buffer) |
|
||||||
"Clean up after async operation finished. |
|
||||||
This function takes care about cleaning up things made by |
|
||||||
`haskell-utils-async-watch-changes'. The BUFFER argument is a buffer where |
|
||||||
`post-command-hook' should be disabled. This is neccessary, because |
|
||||||
it is possible that user will change buffer during async function |
|
||||||
execusion." |
|
||||||
(with-current-buffer buffer |
|
||||||
(setq haskell-utils-async-post-command-flag nil) |
|
||||||
(remove-hook |
|
||||||
'post-command-hook #'haskell-utils-async-update-post-command-flag t))) |
|
||||||
|
|
||||||
(defun haskell-utils-reduce-string (s) |
|
||||||
"Remove newlines ans extra whitespace from S. |
|
||||||
Removes all extra whitespace at the beginning of each line leaving |
|
||||||
only single one. Then removes all newlines." |
|
||||||
(let ((s_ (replace-regexp-in-string "^\s+" " " s))) |
|
||||||
(replace-regexp-in-string "\n" "" s_))) |
|
||||||
|
|
||||||
(defun haskell-utils-parse-repl-response (r) |
|
||||||
"Parse response R from REPL and return special kind of result. |
|
||||||
The result is response string itself with speacial property |
|
||||||
response-type added. |
|
||||||
|
|
||||||
This property could be of the following: |
|
||||||
|
|
||||||
+ unknown-command |
|
||||||
+ option-missing |
|
||||||
+ interactive-error |
|
||||||
+ success" |
|
||||||
(let ((first-line (car (split-string r "\n")))) |
|
||||||
(cond |
|
||||||
((string-match-p "^unknown command" first-line) 'unknown-command) |
|
||||||
((string-match-p "^Couldn't guess that module name. Does it exist?" |
|
||||||
first-line) |
|
||||||
'option-missing) |
|
||||||
((string-match-p "^<interactive>:" first-line) 'interactive-error) |
|
||||||
(t 'success)))) |
|
||||||
|
|
||||||
(defun haskell-utils-compose-type-at-command (pos) |
|
||||||
"Prepare :type-at command to be send to haskell process. |
|
||||||
POS is a cons cell containing min and max positions, i.e. target |
|
||||||
expression bounds." |
|
||||||
(save-excursion |
|
||||||
(let ((start-p (car pos)) |
|
||||||
(end-p (cdr pos)) |
|
||||||
start-l |
|
||||||
start-c |
|
||||||
end-l |
|
||||||
end-c |
|
||||||
value) |
|
||||||
(goto-char start-p) |
|
||||||
(setq start-l (line-number-at-pos)) |
|
||||||
(setq start-c (1+ (current-column))) |
|
||||||
(goto-char end-p) |
|
||||||
(setq end-l (line-number-at-pos)) |
|
||||||
(setq end-c (1+ (current-column))) |
|
||||||
(setq value (buffer-substring-no-properties start-p end-p)) |
|
||||||
;; supress multiline expressions |
|
||||||
(let ((lines (split-string value "\n" t))) |
|
||||||
(when (and (cdr lines) |
|
||||||
(stringp (car lines))) |
|
||||||
(setq value (format "[ %s … ]" (car lines))))) |
|
||||||
(replace-regexp-in-string |
|
||||||
"\n$" |
|
||||||
"" |
|
||||||
(format ":type-at %s %d %d %d %d %s" |
|
||||||
(buffer-file-name) |
|
||||||
start-l |
|
||||||
start-c |
|
||||||
end-l |
|
||||||
end-c |
|
||||||
value))))) |
|
||||||
|
|
||||||
(provide 'haskell-utils) |
|
||||||
;;; haskell-utils.el ends here |
|
||||||
@ -1,509 +0,0 @@ |
|||||||
;;; haskell.el --- Top-level Haskell package -*- 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-mode) |
|
||||||
(require 'haskell-process) |
|
||||||
(require 'haskell-debug) |
|
||||||
(require 'haskell-interactive-mode) |
|
||||||
(require 'haskell-repl) |
|
||||||
(require 'haskell-load) |
|
||||||
(require 'haskell-commands) |
|
||||||
(require 'haskell-sandbox) |
|
||||||
(require 'haskell-modules) |
|
||||||
(require 'haskell-string) |
|
||||||
(require 'haskell-completions) |
|
||||||
(require 'haskell-utils) |
|
||||||
(require 'haskell-customize) |
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
||||||
;; Basic configuration hooks |
|
||||||
|
|
||||||
(add-hook 'haskell-process-ended-hook 'haskell-process-prompt-restart) |
|
||||||
(add-hook 'kill-buffer-hook 'haskell-interactive-kill) |
|
||||||
|
|
||||||
(defvar interactive-haskell-mode-map |
|
||||||
(let ((map (make-sparse-keymap))) |
|
||||||
(define-key map (kbd "C-c C-l") 'haskell-process-load-or-reload) |
|
||||||
(define-key map (kbd "C-c C-t") 'haskell-process-do-type) |
|
||||||
(define-key map (kbd "C-c C-i") 'haskell-process-do-info) |
|
||||||
(define-key map (kbd "M-.") 'haskell-mode-jump-to-def-or-tag) |
|
||||||
(define-key map (kbd "C-c C-k") 'haskell-interactive-mode-clear) |
|
||||||
(define-key map (kbd "C-c C-c") 'haskell-process-cabal-build) |
|
||||||
(define-key map (kbd "C-c C-x") 'haskell-process-cabal) |
|
||||||
(define-key map [?\C-c ?\C-b] 'haskell-interactive-switch) |
|
||||||
(define-key map [?\C-c ?\C-z] 'haskell-interactive-switch) |
|
||||||
(define-key map (kbd "M-n") 'haskell-goto-next-error) |
|
||||||
(define-key map (kbd "M-p") 'haskell-goto-prev-error) |
|
||||||
map) |
|
||||||
"Keymap for using haskell-interactive-mode.") |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(define-minor-mode interactive-haskell-mode |
|
||||||
"Minor mode for enabling haskell-process interaction." |
|
||||||
:lighter " Interactive" |
|
||||||
:keymap interactive-haskell-mode-map |
|
||||||
(add-hook 'completion-at-point-functions |
|
||||||
#'haskell-completions-sync-completions-at-point |
|
||||||
nil |
|
||||||
t)) |
|
||||||
|
|
||||||
(make-obsolete 'haskell-process-completions-at-point |
|
||||||
'haskell-completions-sync-completions-at-point |
|
||||||
"June 19, 2015") |
|
||||||
(defun haskell-process-completions-at-point () |
|
||||||
"A completion-at-point function using the current haskell process." |
|
||||||
(when (haskell-session-maybe) |
|
||||||
(let ((process (haskell-process)) |
|
||||||
symbol-bounds) |
|
||||||
(cond |
|
||||||
;; ghci can complete module names, but it needs the "import " |
|
||||||
;; string at the beginning |
|
||||||
((looking-back (rx line-start |
|
||||||
"import" (1+ space) |
|
||||||
(? "qualified" (1+ space)) |
|
||||||
(group (? (char upper) ; modid |
|
||||||
(* (char alnum ?' ?.))))) |
|
||||||
(line-beginning-position)) |
|
||||||
(let ((text (match-string-no-properties 0)) |
|
||||||
(start (match-beginning 1)) |
|
||||||
(end (match-end 1))) |
|
||||||
(list start end |
|
||||||
(haskell-process-get-repl-completions process text)))) |
|
||||||
;; Complete OPTIONS, a completion list comes from variable |
|
||||||
;; `haskell-ghc-supported-options' |
|
||||||
((and (nth 4 (syntax-ppss)) |
|
||||||
(save-excursion |
|
||||||
(let ((p (point))) |
|
||||||
(and (search-backward "{-#" nil t) |
|
||||||
(search-forward-regexp "\\_<OPTIONS\\(?:_GHC\\)?\\_>" p t)))) |
|
||||||
(looking-back |
|
||||||
(rx symbol-start "-" (* (char alnum ?-))) |
|
||||||
(line-beginning-position))) |
|
||||||
(list (match-beginning 0) (match-end 0) haskell-ghc-supported-options)) |
|
||||||
;; Complete LANGUAGE, a list of completions comes from variable |
|
||||||
;; `haskell-ghc-supported-options' |
|
||||||
((and (nth 4 (syntax-ppss)) |
|
||||||
(save-excursion |
|
||||||
(let ((p (point))) |
|
||||||
(and (search-backward "{-#" nil t) |
|
||||||
(search-forward-regexp "\\_<LANGUAGE\\_>" p t)))) |
|
||||||
(setq symbol-bounds (bounds-of-thing-at-point 'symbol))) |
|
||||||
(list (car symbol-bounds) (cdr symbol-bounds) |
|
||||||
haskell-ghc-supported-extensions)) |
|
||||||
((setq symbol-bounds (haskell-ident-pos-at-point)) |
|
||||||
(cl-destructuring-bind (start . end) symbol-bounds |
|
||||||
(list start end |
|
||||||
(haskell-process-get-repl-completions |
|
||||||
process (buffer-substring-no-properties start end))))))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-interactive-mode-return () |
|
||||||
"Handle the return key." |
|
||||||
(interactive) |
|
||||||
(cond |
|
||||||
((haskell-interactive-at-compile-message) |
|
||||||
(next-error-internal)) |
|
||||||
(t |
|
||||||
(haskell-interactive-handle-expr)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-kill (&optional leave-interactive-buffer) |
|
||||||
"Kill the session process and buffer, delete the session. |
|
||||||
0. Prompt to kill all associated buffers. |
|
||||||
1. Kill the process. |
|
||||||
2. Kill the interactive buffer. |
|
||||||
3. Walk through all the related buffers and set their haskell-session to nil. |
|
||||||
4. Remove the session from the sessions list." |
|
||||||
(interactive) |
|
||||||
(let* ((session (haskell-session)) |
|
||||||
(name (haskell-session-name session)) |
|
||||||
(also-kill-buffers |
|
||||||
(and haskell-ask-also-kill-buffers |
|
||||||
(y-or-n-p (format "Killing `%s'. Also kill all associated buffers?" name))))) |
|
||||||
(haskell-kill-session-process session) |
|
||||||
(unless leave-interactive-buffer |
|
||||||
(kill-buffer (haskell-session-interactive-buffer session))) |
|
||||||
(cl-loop for buffer in (buffer-list) |
|
||||||
do (with-current-buffer buffer |
|
||||||
(when (and (boundp 'haskell-session) |
|
||||||
(string= (haskell-session-name haskell-session) name)) |
|
||||||
(setq haskell-session nil) |
|
||||||
(when also-kill-buffers |
|
||||||
(kill-buffer))))) |
|
||||||
(setq haskell-sessions |
|
||||||
(cl-remove-if (lambda (session) |
|
||||||
(string= (haskell-session-name session) |
|
||||||
name)) |
|
||||||
haskell-sessions)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-interactive-kill () |
|
||||||
"Kill the buffer and (maybe) the session." |
|
||||||
(interactive) |
|
||||||
(when (eq major-mode 'haskell-interactive-mode) |
|
||||||
(when (and (boundp 'haskell-session) |
|
||||||
haskell-session |
|
||||||
(y-or-n-p "Kill the whole session?")) |
|
||||||
(haskell-session-kill t)))) |
|
||||||
|
|
||||||
(defun haskell-session-make (name) |
|
||||||
"Make a Haskell session." |
|
||||||
(when (haskell-session-lookup name) |
|
||||||
(error "Session of name %s already exists!" name)) |
|
||||||
(let ((session (setq haskell-session |
|
||||||
(list (cons 'name name))))) |
|
||||||
(add-to-list 'haskell-sessions session) |
|
||||||
(haskell-process-start session) |
|
||||||
session)) |
|
||||||
|
|
||||||
(defun haskell-session-new-assume-from-cabal () |
|
||||||
"Prompt to create a new project based on a guess from the nearest Cabal file. |
|
||||||
If `haskell-process-load-or-reload-prompt' is nil, accept `default'." |
|
||||||
(let ((name (haskell-session-default-name))) |
|
||||||
(unless (haskell-session-lookup name) |
|
||||||
(if (or (not haskell-process-load-or-reload-prompt) |
|
||||||
(y-or-n-p (format "Start a new project named “%s”? " name))) |
|
||||||
(haskell-session-make name))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session () |
|
||||||
"Get the Haskell session, prompt if there isn't one or fail." |
|
||||||
(or (haskell-session-maybe) |
|
||||||
(haskell-session-assign |
|
||||||
(or (haskell-session-from-buffer) |
|
||||||
(haskell-session-new-assume-from-cabal) |
|
||||||
(haskell-session-choose) |
|
||||||
(haskell-session-new))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-interactive-switch () |
|
||||||
"Switch to the interactive mode for this session." |
|
||||||
(interactive) |
|
||||||
(let ((initial-buffer (current-buffer)) |
|
||||||
(buffer (haskell-session-interactive-buffer (haskell-session)))) |
|
||||||
(with-current-buffer buffer |
|
||||||
(setq haskell-interactive-previous-buffer initial-buffer)) |
|
||||||
(unless (eq buffer (window-buffer)) |
|
||||||
(switch-to-buffer-other-window buffer)))) |
|
||||||
|
|
||||||
(defun haskell-session-new () |
|
||||||
"Make a new session." |
|
||||||
(let ((name (read-from-minibuffer "Project name: " (haskell-session-default-name)))) |
|
||||||
(when (not (string= name "")) |
|
||||||
(let ((session (haskell-session-lookup name))) |
|
||||||
(if session |
|
||||||
(when (y-or-n-p (format "Session %s already exists. Use it?" name)) |
|
||||||
session) |
|
||||||
(haskell-session-make name)))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-session-change () |
|
||||||
"Change the session for the current buffer." |
|
||||||
(interactive) |
|
||||||
(haskell-session-assign (or (haskell-session-new-assume-from-cabal) |
|
||||||
(haskell-session-choose) |
|
||||||
(haskell-session-new)))) |
|
||||||
|
|
||||||
(defun haskell-process-prompt-restart (process) |
|
||||||
"Prompt to restart the died process." |
|
||||||
(let ((process-name (haskell-process-name process))) |
|
||||||
(if haskell-process-suggest-restart |
|
||||||
(cond |
|
||||||
((string-match "You need to re-run the 'configure' command." |
|
||||||
(haskell-process-response process)) |
|
||||||
(cl-case (read-event |
|
||||||
(concat "The Haskell process ended. Cabal wants you to run " |
|
||||||
(propertize "cabal configure" 'face 'font-lock-keyword-face) |
|
||||||
" because there is a version mismatch. Re-configure (y, n, l: view log)?" |
|
||||||
"\n\n" |
|
||||||
"Cabal said:\n\n" |
|
||||||
(propertize (haskell-process-response process) |
|
||||||
'face 'font-lock-comment-face))) |
|
||||||
(?y (let ((default-directory (haskell-session-cabal-dir (haskell-process-session process)))) |
|
||||||
(message "%s" (shell-command-to-string "cabal configure")))) |
|
||||||
(?l (let* ((response (haskell-process-response process)) |
|
||||||
(buffer (get-buffer "*haskell-process-log*"))) |
|
||||||
(if buffer |
|
||||||
(switch-to-buffer buffer) |
|
||||||
(progn (switch-to-buffer (get-buffer-create "*haskell-process-log*")) |
|
||||||
(insert response))))) |
|
||||||
(?n))) |
|
||||||
(t |
|
||||||
(cl-case (read-event |
|
||||||
(propertize (format "The Haskell process `%s' has died. Restart? (y, n, l: show process log)" |
|
||||||
process-name) |
|
||||||
'face 'minibuffer-prompt)) |
|
||||||
(?y (haskell-process-start (haskell-process-session process))) |
|
||||||
(?l (let* ((response (haskell-process-response process)) |
|
||||||
(buffer (get-buffer "*haskell-process-log*"))) |
|
||||||
(if buffer |
|
||||||
(switch-to-buffer buffer) |
|
||||||
(progn (switch-to-buffer (get-buffer-create "*haskell-process-log*")) |
|
||||||
(insert response))))) |
|
||||||
(?n)))) |
|
||||||
(message (format "The Haskell process `%s' is dearly departed." |
|
||||||
process-name))))) |
|
||||||
|
|
||||||
(defun haskell-process () |
|
||||||
"Get the current process from the current session." |
|
||||||
(haskell-session-process (haskell-session))) |
|
||||||
|
|
||||||
(defun haskell-interactive-buffer () |
|
||||||
"Get the interactive buffer of the session." |
|
||||||
(haskell-session-interactive-buffer (haskell-session))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-kill-session-process (&optional session) |
|
||||||
"Kill the process." |
|
||||||
(interactive) |
|
||||||
(let* ((session (or session (haskell-session))) |
|
||||||
(existing-process (get-process (haskell-session-name session)))) |
|
||||||
(when (processp existing-process) |
|
||||||
(haskell-interactive-mode-echo session "Killing process ...") |
|
||||||
(haskell-process-set (haskell-session-process session) 'is-restarting t) |
|
||||||
(delete-process existing-process)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-interactive-mode-visit-error () |
|
||||||
"Visit the buffer of the current (or last) error message." |
|
||||||
(interactive) |
|
||||||
(with-current-buffer (haskell-session-interactive-buffer (haskell-session)) |
|
||||||
(if (progn (goto-char (line-beginning-position)) |
|
||||||
(looking-at haskell-interactive-mode-error-regexp)) |
|
||||||
(progn (forward-line -1) |
|
||||||
(haskell-interactive-jump-to-error-line)) |
|
||||||
(progn (goto-char (point-max)) |
|
||||||
(haskell-interactive-mode-error-backward) |
|
||||||
(haskell-interactive-jump-to-error-line))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-mode-contextual-space () |
|
||||||
"Contextually do clever stuff when hitting space." |
|
||||||
(interactive) |
|
||||||
(if (or (not (bound-and-true-p interactive-haskell-mode)) |
|
||||||
(not (haskell-session-maybe))) |
|
||||||
(self-insert-command 1) |
|
||||||
(cond ((and haskell-mode-contextual-import-completion |
|
||||||
(save-excursion (forward-word -1) |
|
||||||
(looking-at "^import$"))) |
|
||||||
(insert " ") |
|
||||||
(let ((module (haskell-complete-module-read |
|
||||||
"Module: " |
|
||||||
(haskell-session-all-modules (haskell-session))))) |
|
||||||
(let ((mapping (assoc module haskell-import-mapping))) |
|
||||||
(if mapping |
|
||||||
(progn (delete-region (line-beginning-position) |
|
||||||
(line-end-position)) |
|
||||||
(insert (cdr mapping))) |
|
||||||
(insert module))) |
|
||||||
(haskell-mode-format-imports))) |
|
||||||
(t |
|
||||||
(let ((ident (save-excursion (forward-char -1) (haskell-ident-at-point)))) |
|
||||||
(insert " ") |
|
||||||
(when ident |
|
||||||
(haskell-process-do-try-info ident))))))) |
|
||||||
|
|
||||||
(defvar xref-prompt-for-identifier nil) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-mode-jump-to-tag (&optional next-p) |
|
||||||
"Jump to the tag of the given identifier." |
|
||||||
(interactive "P") |
|
||||||
(let ((ident (haskell-ident-at-point)) |
|
||||||
(tags-file-name (haskell-session-tags-filename (haskell-session))) |
|
||||||
(tags-revert-without-query t)) |
|
||||||
(when (and ident (not (string= "" (haskell-string-trim ident)))) |
|
||||||
(cond ((file-exists-p tags-file-name) |
|
||||||
(let ((xref-prompt-for-identifier next-p)) |
|
||||||
(xref-find-definitions ident))) |
|
||||||
(t (haskell-process-generate-tags ident)))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-mode-after-save-handler () |
|
||||||
"Function that will be called after buffer's saving." |
|
||||||
(when haskell-tags-on-save |
|
||||||
(ignore-errors (when (and (boundp 'haskell-session) haskell-session) |
|
||||||
(haskell-process-generate-tags)))) |
|
||||||
(when haskell-stylish-on-save |
|
||||||
(ignore-errors (haskell-mode-stylish-buffer)) |
|
||||||
(let ((before-save-hook '()) |
|
||||||
(after-save-hook '())) |
|
||||||
(basic-save-buffer)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-mode-tag-find (&optional _next-p) |
|
||||||
"The tag find function, specific for the particular session." |
|
||||||
(interactive "P") |
|
||||||
(cond |
|
||||||
((elt (syntax-ppss) 3) ;; Inside a string |
|
||||||
(haskell-mode-jump-to-filename-in-string)) |
|
||||||
(t (call-interactively 'haskell-mode-jump-to-tag)))) |
|
||||||
|
|
||||||
(defun haskell-mode-jump-to-filename-in-string () |
|
||||||
"Jump to the filename in the current string." |
|
||||||
(let* ((string (save-excursion |
|
||||||
(buffer-substring-no-properties |
|
||||||
(1+ (search-backward-regexp "\"" (line-beginning-position) nil 1)) |
|
||||||
(1- (progn (forward-char 1) |
|
||||||
(search-forward-regexp "\"" (line-end-position) nil 1)))))) |
|
||||||
(fp (expand-file-name string |
|
||||||
(haskell-session-cabal-dir (haskell-session))))) |
|
||||||
(find-file |
|
||||||
(read-file-name |
|
||||||
"" |
|
||||||
fp |
|
||||||
fp)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-interactive-bring () |
|
||||||
"Bring up the interactive mode for this session." |
|
||||||
(interactive) |
|
||||||
(let* ((session (haskell-session)) |
|
||||||
(buffer (haskell-session-interactive-buffer session))) |
|
||||||
(pop-to-buffer buffer))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-process-load-file () |
|
||||||
"Load the current buffer file." |
|
||||||
(interactive) |
|
||||||
(save-buffer) |
|
||||||
(haskell-interactive-mode-reset-error (haskell-session)) |
|
||||||
(haskell-process-file-loadish (format "load \"%s\"" (replace-regexp-in-string |
|
||||||
"\"" |
|
||||||
"\\\\\"" |
|
||||||
(buffer-file-name))) |
|
||||||
nil |
|
||||||
(current-buffer))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-process-reload-file () |
|
||||||
"Re-load the current buffer file." |
|
||||||
(interactive) |
|
||||||
(save-buffer) |
|
||||||
(haskell-interactive-mode-reset-error (haskell-session)) |
|
||||||
(haskell-process-file-loadish "reload" t (current-buffer))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-process-load-or-reload (&optional toggle) |
|
||||||
"Load or reload. Universal argument toggles which." |
|
||||||
(interactive "P") |
|
||||||
(if toggle |
|
||||||
(progn (setq haskell-reload-p (not haskell-reload-p)) |
|
||||||
(message "%s (No action taken this time)" |
|
||||||
(if haskell-reload-p |
|
||||||
"Now running :reload." |
|
||||||
"Now running :load <buffer-filename>."))) |
|
||||||
(if haskell-reload-p (haskell-process-reload-file) (haskell-process-load-file)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-process-cabal-build () |
|
||||||
"Build the Cabal project." |
|
||||||
(interactive) |
|
||||||
(haskell-process-do-cabal "build") |
|
||||||
(haskell-process-add-cabal-autogen)) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-process-cabal (p) |
|
||||||
"Prompts for a Cabal command to run." |
|
||||||
(interactive "P") |
|
||||||
(if p |
|
||||||
(haskell-process-do-cabal |
|
||||||
(read-from-minibuffer "Cabal command (e.g. install): ")) |
|
||||||
(haskell-process-do-cabal |
|
||||||
(funcall haskell-completing-read-function "Cabal command: " |
|
||||||
(append haskell-cabal-commands |
|
||||||
(list "build --ghc-options=-fforce-recomp")))))) |
|
||||||
|
|
||||||
(defun haskell-process-file-loadish (command reload-p module-buffer) |
|
||||||
"Run a loading-ish COMMAND that wants to pick up type errors |
|
||||||
and things like that. RELOAD-P indicates whether the notification |
|
||||||
should say 'reloaded' or 'loaded'. MODULE-BUFFER may be used |
|
||||||
for various things, but is optional." |
|
||||||
(let ((session (haskell-session))) |
|
||||||
(haskell-session-current-dir session) |
|
||||||
(when haskell-process-check-cabal-config-on-load |
|
||||||
(haskell-process-look-config-changes session)) |
|
||||||
(let ((process (haskell-process))) |
|
||||||
(haskell-process-queue-command |
|
||||||
process |
|
||||||
(make-haskell-command |
|
||||||
:state (list session process command reload-p module-buffer) |
|
||||||
:go (lambda (state) |
|
||||||
(haskell-process-send-string |
|
||||||
(cadr state) (format ":%s" (cl-caddr state)))) |
|
||||||
:live (lambda (state buffer) |
|
||||||
(haskell-process-live-build |
|
||||||
(cadr state) buffer nil)) |
|
||||||
:complete (lambda (state response) |
|
||||||
(haskell-process-load-complete |
|
||||||
(car state) |
|
||||||
(cadr state) |
|
||||||
response |
|
||||||
(cl-cadddr state) |
|
||||||
(cl-cadddr (cdr state))))))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun haskell-process-minimal-imports () |
|
||||||
"Dump minimal imports." |
|
||||||
(interactive) |
|
||||||
(unless (> (save-excursion |
|
||||||
(goto-char (point-min)) |
|
||||||
(haskell-navigate-imports-go) |
|
||||||
(point)) |
|
||||||
(point)) |
|
||||||
(goto-char (point-min)) |
|
||||||
(haskell-navigate-imports-go)) |
|
||||||
(haskell-process-queue-sync-request (haskell-process) |
|
||||||
":set -ddump-minimal-imports") |
|
||||||
(haskell-process-load-file) |
|
||||||
(insert-file-contents-literally |
|
||||||
(concat (haskell-session-current-dir (haskell-session)) |
|
||||||
"/" |
|
||||||
(haskell-guess-module-name) |
|
||||||
".imports"))) |
|
||||||
|
|
||||||
(defun haskell-interactive-jump-to-error-line () |
|
||||||
"Jump to the error line." |
|
||||||
(let ((orig-line (buffer-substring-no-properties (line-beginning-position) |
|
||||||
(line-end-position)))) |
|
||||||
(and (string-match "^\\([^:]+\\):\\([0-9]+\\):\\([0-9]+\\)\\(-[0-9]+\\)?:" orig-line) |
|
||||||
(let* ((file (match-string 1 orig-line)) |
|
||||||
(line (match-string 2 orig-line)) |
|
||||||
(col (match-string 3 orig-line)) |
|
||||||
(session (haskell-interactive-session)) |
|
||||||
(cabal-path (haskell-session-cabal-dir session)) |
|
||||||
(src-path (haskell-session-current-dir session)) |
|
||||||
(cabal-relative-file (expand-file-name file cabal-path)) |
|
||||||
(src-relative-file (expand-file-name file src-path))) |
|
||||||
(let ((file (cond ((file-exists-p cabal-relative-file) |
|
||||||
cabal-relative-file) |
|
||||||
((file-exists-p src-relative-file) |
|
||||||
src-relative-file)))) |
|
||||||
(when file |
|
||||||
(other-window 1) |
|
||||||
(find-file file) |
|
||||||
(haskell-interactive-bring) |
|
||||||
(goto-char (point-min)) |
|
||||||
(forward-line (1- (string-to-number line))) |
|
||||||
(goto-char (+ (point) (string-to-number col) -1)) |
|
||||||
(haskell-mode-message-line orig-line) |
|
||||||
t)))))) |
|
||||||
|
|
||||||
(provide 'haskell) |
|
||||||
@ -1,107 +0,0 @@ |
|||||||
;;; highlight-uses-mode.el --- Mode for highlighting uses -*- 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) |
|
||||||
|
|
||||||
(defvar highlight-uses-mode-map |
|
||||||
(let ((map (make-sparse-keymap))) |
|
||||||
(define-key map (kbd "TAB") 'highlight-uses-mode-next) |
|
||||||
(define-key map (kbd "S-TAB") 'highlight-uses-mode-prev) |
|
||||||
(define-key map (kbd "<backtab>") 'highlight-uses-mode-prev) |
|
||||||
(define-key map (kbd "RET") 'highlight-uses-mode-stop-here) |
|
||||||
(define-key map (kbd "C-g") 'highlight-uses-mode) |
|
||||||
map) |
|
||||||
"Keymap for using `highlight-uses-mode'.") |
|
||||||
|
|
||||||
(defvar highlight-uses-mode-point nil) |
|
||||||
(make-variable-buffer-local 'highlight-uses-mode-point) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(define-minor-mode highlight-uses-mode |
|
||||||
"Minor mode for highlighting and jumping between uses." |
|
||||||
:lighter " Uses" |
|
||||||
:keymap highlight-uses-mode-map |
|
||||||
(if highlight-uses-mode |
|
||||||
(setq highlight-uses-mode-point (point)) |
|
||||||
(when highlight-uses-mode-point |
|
||||||
(goto-char highlight-uses-mode-point))) |
|
||||||
(remove-overlays (point-min) (point-max) 'highlight-uses-mode-highlight t)) |
|
||||||
|
|
||||||
(defun highlight-uses-mode-replace () |
|
||||||
"Replace all highlighted instances in the buffer with something |
|
||||||
else." |
|
||||||
(interactive) |
|
||||||
(save-excursion |
|
||||||
(goto-char (point-min)) |
|
||||||
(let ((o (highlight-uses-mode-next))) |
|
||||||
(when o |
|
||||||
(let ((replacement (read-from-minibuffer (format "Replace uses %s with: " |
|
||||||
(buffer-substring |
|
||||||
(overlay-start o) |
|
||||||
(overlay-end o)))))) |
|
||||||
|
|
||||||
(while o |
|
||||||
(goto-char (overlay-start o)) |
|
||||||
(delete-region (overlay-start o) |
|
||||||
(overlay-end o)) |
|
||||||
(insert replacement) |
|
||||||
(setq o (highlight-uses-mode-next)))))))) |
|
||||||
|
|
||||||
(defun highlight-uses-mode-stop-here () |
|
||||||
"Stop at this point." |
|
||||||
(interactive) |
|
||||||
(setq highlight-uses-mode-point (point)) |
|
||||||
(highlight-uses-mode -1)) |
|
||||||
|
|
||||||
(defun highlight-uses-mode-next () |
|
||||||
"Jump to next result." |
|
||||||
(interactive) |
|
||||||
(let ((os (sort (cl-remove-if (lambda (o) |
|
||||||
(or (<= (overlay-start o) (point)) |
|
||||||
(not (overlay-get o 'highlight-uses-mode-highlight)))) |
|
||||||
(overlays-in (point) (point-max))) |
|
||||||
(lambda (a b) |
|
||||||
(< (overlay-start a) |
|
||||||
(overlay-start b)))))) |
|
||||||
(when os |
|
||||||
(goto-char (overlay-start (car os))) |
|
||||||
(car os)))) |
|
||||||
|
|
||||||
(defun highlight-uses-mode-prev () |
|
||||||
"Jump to previous result." |
|
||||||
(interactive) |
|
||||||
(let ((os (sort (cl-remove-if (lambda (o) |
|
||||||
(or (>= (overlay-end o) (point)) |
|
||||||
(not (overlay-get o 'highlight-uses-mode-highlight)))) |
|
||||||
(overlays-in (point-min) (point))) |
|
||||||
(lambda (a b) |
|
||||||
(> (overlay-start a) |
|
||||||
(overlay-start b)))))) |
|
||||||
(when os |
|
||||||
(goto-char (overlay-start (car os))) |
|
||||||
(car os)))) |
|
||||||
|
|
||||||
(defun highlight-uses-mode-highlight (start end) |
|
||||||
"Make a highlight overlay at the given span." |
|
||||||
(let ((o (make-overlay start end))) |
|
||||||
(overlay-put o 'priority 999) |
|
||||||
(overlay-put o 'face 'isearch) |
|
||||||
(overlay-put o 'highlight-uses-mode-highlight t))) |
|
||||||
|
|
||||||
(provide 'highlight-uses-mode) |
|
||||||
@ -1,837 +0,0 @@ |
|||||||
;;; inf-haskell.el --- Interaction with an inferior Haskell process -*- lexical-binding: t -*- |
|
||||||
|
|
||||||
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. |
|
||||||
|
|
||||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
|
||||||
;; Keywords: Haskell |
|
||||||
|
|
||||||
;; 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: |
|
||||||
|
|
||||||
;; The code is made of 2 parts: a major mode for the buffer that holds the |
|
||||||
;; inferior process's session and a minor mode for use in source buffers. |
|
||||||
|
|
||||||
;; Todo: |
|
||||||
|
|
||||||
;; - Check out Shim for ideas. |
|
||||||
;; - i-h-load-buffer and i-h-send-region. |
|
||||||
|
|
||||||
;;; Code: |
|
||||||
|
|
||||||
(require 'comint) |
|
||||||
(require 'shell) ; For directory tracking. |
|
||||||
(require 'etags) |
|
||||||
(require 'haskell-compat) |
|
||||||
(require 'compile) |
|
||||||
(require 'haskell-mode) |
|
||||||
(require 'haskell-decl-scan) |
|
||||||
(require 'haskell-cabal) |
|
||||||
|
|
||||||
;; Dynamically scoped variables. |
|
||||||
(defvar find-tag-marker-ring) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defgroup inferior-haskell nil |
|
||||||
"Settings for REPL interaction via `inferior-haskell-mode'" |
|
||||||
:link '(custom-manual "(haskell-mode)inferior-haskell-mode") |
|
||||||
:prefix "inferior-haskell-" |
|
||||||
:prefix "haskell-" |
|
||||||
:group 'haskell) |
|
||||||
|
|
||||||
;; Here I depart from the inferior-haskell- prefix. |
|
||||||
;; Not sure if it's a good idea. |
|
||||||
;;;###autoload |
|
||||||
(defcustom haskell-program-name |
|
||||||
;; Arbitrarily give preference to hugs over ghci. |
|
||||||
(or (cond |
|
||||||
((executable-find "hugs") "hugs \"+.\"") |
|
||||||
((executable-find "ghci") "ghci")) |
|
||||||
"hugs \"+.\"") |
|
||||||
"The name of the command to start the inferior Haskell process. |
|
||||||
The command can include arguments." |
|
||||||
;; Custom only supports the :options keyword for a few types, e.g. not |
|
||||||
;; for string. |
|
||||||
;; :options '("hugs \"+.\"" "ghci") |
|
||||||
:group 'inferior-haskell |
|
||||||
:type '(choice string (repeat string))) |
|
||||||
|
|
||||||
(defconst inferior-haskell-info-xref-re |
|
||||||
"\t-- Defined at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)\\(?:-\\([0-9]+\\)\\)?$") |
|
||||||
|
|
||||||
(defconst inferior-haskell-module-re |
|
||||||
"\t-- Defined in \\(.+\\)$" |
|
||||||
"Regular expression for matching module names in :info.") |
|
||||||
|
|
||||||
(defvar inferior-haskell-multiline-prompt-re |
|
||||||
"^\\*?[[:upper:]][\\._[:alnum:]]*\\(?: \\*?[[:upper:]][\\._[:alnum:]]*\\)*| " |
|
||||||
"Regular expression for matching multiline prompt (the one inside :{ ... :} blocks).") |
|
||||||
|
|
||||||
(defconst inferior-haskell-error-regexp-alist |
|
||||||
;; The format of error messages used by Hugs. |
|
||||||
`(("^ERROR \"\\(.+?\\)\"\\(:\\| line \\)\\([0-9]+\\) - " 1 3) |
|
||||||
;; Format of error messages used by GHCi. |
|
||||||
("^\\(.+?\\):\\([0-9]+\\):\\(\\([0-9]+\\):\\)?\\( \\|\n *\\)\\(Warning\\)?" |
|
||||||
1 2 4 ,@(if (fboundp 'compilation-fake-loc) |
|
||||||
'((6) nil (5 '(face nil font-lock-multiline t))))) |
|
||||||
;; Runtime exceptions, from ghci. |
|
||||||
("^\\*\\*\\* Exception: \\(.+?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\)): .*" |
|
||||||
1 ,@(if (fboundp 'compilation-fake-loc) '((2 . 4) (3 . 5)) '(2 3))) |
|
||||||
;; GHCi uses two different forms for line/col ranges, depending on |
|
||||||
;; whether it's all on the same line or not :-( In Emacs-23, I could use |
|
||||||
;; explicitly numbered subgroups to merge the two patterns. |
|
||||||
("^\\*\\*\\* Exception: \\(.+?\\):\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\): .*" |
|
||||||
1 2 ,(if (fboundp 'compilation-fake-loc) '(3 . 4) 3)) |
|
||||||
;; Info messages. Not errors per se. |
|
||||||
,@(when (fboundp 'compilation-fake-loc) |
|
||||||
`(;; Other GHCi patterns used in type errors. |
|
||||||
("^[ \t]+at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)$" |
|
||||||
1 2 (3 . 4) 0) |
|
||||||
;; Foo.hs:318:80: |
|
||||||
;; Ambiguous occurrence `Bar' |
|
||||||
;; It could refer to either `Bar', defined at Zork.hs:311:5 |
|
||||||
;; or `Bar', imported from Bars at Frob.hs:32:0-16 |
|
||||||
;; (defined at Location.hs:97:5) |
|
||||||
("[ (]defined at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\))?$" 1 2 3 0) |
|
||||||
("imported from .* at \\(.+\\):\\([0-9]+\\):\\([0-9]+\\)-\\([0-9]+\\)$" |
|
||||||
1 2 (3 . 4) 0) |
|
||||||
;; Info xrefs. |
|
||||||
(,inferior-haskell-info-xref-re 1 2 (3 . 4) 0)))) |
|
||||||
"Regexps for error messages generated by inferior Haskell processes. |
|
||||||
The format should be the same as for `compilation-error-regexp-alist'.") |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom inferior-haskell-find-project-root t |
|
||||||
"If non-nil, try and find the project root directory of this file. |
|
||||||
This will either look for a Cabal file or a \"module\" statement in the file." |
|
||||||
:group 'inferior-haskell |
|
||||||
:type 'boolean) |
|
||||||
|
|
||||||
(define-derived-mode inferior-haskell-mode comint-mode "Inf-Haskell" |
|
||||||
"Major mode for interacting with an inferior Haskell process." |
|
||||||
:group 'inferior-haskell |
|
||||||
(set (make-local-variable 'comint-prompt-regexp) |
|
||||||
;; Whay the backslash in [\\._[:alnum:]]? |
|
||||||
"^\\*?[[:upper:]][\\._[:alnum:]]*\\(?: \\*?[[:upper:]][\\._[:alnum:]]*\\)*\\( λ\\)?> \\|^λ?> $") |
|
||||||
(set (make-local-variable 'comint-input-autoexpand) nil) |
|
||||||
(add-hook 'comint-preoutput-filter-functions |
|
||||||
'inferior-haskell-send-decl-post-filter) |
|
||||||
(add-hook 'comint-output-filter-functions 'inferior-haskell-spot-prompt nil t) |
|
||||||
|
|
||||||
;; Setup directory tracking. |
|
||||||
(set (make-local-variable 'shell-cd-regexp) ":cd") |
|
||||||
(condition-case nil |
|
||||||
(shell-dirtrack-mode 1) |
|
||||||
(error ;The minor mode function may not exist or not accept an arg. |
|
||||||
(set (make-local-variable 'shell-dirtrackp) t) |
|
||||||
(add-hook 'comint-input-filter-functions 'shell-directory-tracker |
|
||||||
nil 'local))) |
|
||||||
|
|
||||||
;; Setup `compile' support so you can just use C-x ` and friends. |
|
||||||
(set (make-local-variable 'compilation-error-regexp-alist) |
|
||||||
inferior-haskell-error-regexp-alist) |
|
||||||
(set (make-local-variable 'compilation-first-column) 0) ;GHCI counts from 0. |
|
||||||
(if (and (not (boundp 'minor-mode-overriding-map-alist)) |
|
||||||
(fboundp 'compilation-shell-minor-mode)) |
|
||||||
;; If we can't remove compilation-minor-mode bindings, at least try to |
|
||||||
;; use compilation-shell-minor-mode, so there are fewer |
|
||||||
;; annoying bindings. |
|
||||||
(compilation-shell-minor-mode 1) |
|
||||||
;; Else just use compilation-minor-mode but without its bindings because |
|
||||||
;; things like mouse-2 are simply too annoying. |
|
||||||
(compilation-minor-mode 1) |
|
||||||
(let ((map (make-sparse-keymap))) |
|
||||||
(dolist (keys '([menu-bar] [follow-link])) |
|
||||||
;; Preserve some of the bindings. |
|
||||||
(define-key map keys (lookup-key compilation-minor-mode-map keys))) |
|
||||||
(add-to-list 'minor-mode-overriding-map-alist |
|
||||||
(cons 'compilation-minor-mode map))))) |
|
||||||
|
|
||||||
(defun inferior-haskell-string-to-strings (string) |
|
||||||
"Split the STRING into a list of strings." |
|
||||||
(let ((i (string-match "[\"]" string))) |
|
||||||
(if (null i) (split-string string) ; no quoting: easy |
|
||||||
(append (unless (eq i 0) (split-string (substring string 0 i))) |
|
||||||
(let ((rfs (read-from-string string i))) |
|
||||||
(cons (car rfs) |
|
||||||
(inferior-haskell-string-to-strings |
|
||||||
(substring string (cdr rfs))))))))) |
|
||||||
|
|
||||||
(defun inferior-haskell-command (arg) |
|
||||||
(inferior-haskell-string-to-strings |
|
||||||
(if (null arg) haskell-program-name |
|
||||||
(read-string "Command to run haskell: " haskell-program-name)))) |
|
||||||
|
|
||||||
(defvar inferior-haskell-buffer nil |
|
||||||
"The buffer in which the inferior process is running.") |
|
||||||
|
|
||||||
(defun inferior-haskell-start-process (command) |
|
||||||
"Start an inferior haskell process. |
|
||||||
With universal prefix \\[universal-argument], prompts for a COMMAND, |
|
||||||
otherwise uses `haskell-program-name'. |
|
||||||
It runs the hook `inferior-haskell-hook' after starting the process and |
|
||||||
setting up the inferior-haskell buffer." |
|
||||||
(interactive (list (inferior-haskell-command current-prefix-arg))) |
|
||||||
(setq inferior-haskell-buffer |
|
||||||
(apply 'make-comint "haskell" (car command) nil (cdr command))) |
|
||||||
(with-current-buffer inferior-haskell-buffer |
|
||||||
(inferior-haskell-mode) |
|
||||||
(run-hooks 'inferior-haskell-hook))) |
|
||||||
|
|
||||||
(defun inferior-haskell-process (&optional arg) |
|
||||||
(or (if (buffer-live-p inferior-haskell-buffer) |
|
||||||
(get-buffer-process inferior-haskell-buffer)) |
|
||||||
(progn |
|
||||||
(let ((current-prefix-arg arg)) |
|
||||||
(call-interactively 'inferior-haskell-start-process)) |
|
||||||
;; Try again. |
|
||||||
(inferior-haskell-process arg)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defalias 'run-haskell 'switch-to-haskell) |
|
||||||
;;;###autoload |
|
||||||
(defun switch-to-haskell (&optional arg) |
|
||||||
"Show the inferior-haskell buffer. Start the process if needed." |
|
||||||
(interactive "P") |
|
||||||
(let ((proc (inferior-haskell-process arg))) |
|
||||||
(pop-to-buffer (process-buffer proc)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom inferior-haskell-wait-and-jump nil |
|
||||||
"If non-nil, wait for file loading to terminate and jump to the error." |
|
||||||
:type 'boolean |
|
||||||
:group 'inferior-haskell) |
|
||||||
|
|
||||||
(defvar inferior-haskell-send-decl-post-filter-on nil) |
|
||||||
(make-variable-buffer-local 'inferior-haskell-send-decl-post-filter-on) |
|
||||||
|
|
||||||
(defun inferior-haskell-send-decl-post-filter (string) |
|
||||||
(when (and inferior-haskell-send-decl-post-filter-on |
|
||||||
#1=(string-match inferior-haskell-multiline-prompt-re string)) |
|
||||||
;; deleting sequence of `%s|' multiline promts |
|
||||||
(while #1# |
|
||||||
(setq string (substring string (match-end 0)))) |
|
||||||
;; deleting regular prompts |
|
||||||
(setq string (replace-regexp-in-string comint-prompt-regexp "" string) |
|
||||||
;; turning off this post-filter |
|
||||||
inferior-haskell-send-decl-post-filter-on nil)) |
|
||||||
string) |
|
||||||
|
|
||||||
(defvar inferior-haskell-seen-prompt nil) |
|
||||||
(make-variable-buffer-local 'inferior-haskell-seen-prompt) |
|
||||||
|
|
||||||
(defun inferior-haskell-spot-prompt (_string) |
|
||||||
(let ((proc (get-buffer-process (current-buffer)))) |
|
||||||
(when proc |
|
||||||
(save-excursion |
|
||||||
(goto-char (process-mark proc)) |
|
||||||
(if (re-search-backward comint-prompt-regexp |
|
||||||
(line-beginning-position) t) |
|
||||||
(setq inferior-haskell-seen-prompt t)))))) |
|
||||||
|
|
||||||
(defun inferior-haskell-wait-for-prompt (proc &optional timeout) |
|
||||||
"Wait until PROC sends us a prompt. |
|
||||||
The process PROC should be associated to a comint buffer." |
|
||||||
(with-current-buffer (process-buffer proc) |
|
||||||
(while (progn |
|
||||||
(goto-char comint-last-input-end) |
|
||||||
(not (or inferior-haskell-seen-prompt |
|
||||||
(setq inferior-haskell-seen-prompt |
|
||||||
(re-search-forward comint-prompt-regexp nil t)) |
|
||||||
(not (accept-process-output proc timeout)))))) |
|
||||||
(unless inferior-haskell-seen-prompt |
|
||||||
(error "Can't find the prompt")))) |
|
||||||
|
|
||||||
(defvar inferior-haskell-cabal-buffer nil) |
|
||||||
|
|
||||||
(defun inferior-haskell-cabal-of-buf (buf) |
|
||||||
(with-current-buffer buf |
|
||||||
(or (and (buffer-live-p inferior-haskell-cabal-buffer) |
|
||||||
inferior-haskell-cabal-buffer) |
|
||||||
(if (local-variable-p 'inferior-haskell-cabal-buffer |
|
||||||
;; XEmacs needs this argument. |
|
||||||
(current-buffer)) |
|
||||||
inferior-haskell-cabal-buffer |
|
||||||
(set (make-local-variable 'inferior-haskell-cabal-buffer) |
|
||||||
(haskell-cabal-find-file)))))) |
|
||||||
|
|
||||||
(defun inferior-haskell-find-project-root (buf) |
|
||||||
(with-current-buffer buf |
|
||||||
(let* ( |
|
||||||
(cabal-file (inferior-haskell-cabal-of-buf buf)) |
|
||||||
(cabal (when cabal-file |
|
||||||
(find-file-noselect cabal-file))) |
|
||||||
) |
|
||||||
(or (when cabal |
|
||||||
(with-current-buffer cabal |
|
||||||
(let ((hsd (haskell-cabal-get-setting "hs-source-dirs"))) |
|
||||||
(if (null hsd) |
|
||||||
;; If there's a Cabal file with no Hs-Source-Dirs, then |
|
||||||
;; just use the Cabal file's directory. |
|
||||||
default-directory |
|
||||||
;; If there is an HSD, then check that it's an existing |
|
||||||
;; dir (otherwise, it may be a list of dirs and we don't |
|
||||||
;; know what to do with those). If it doesn't exist, then |
|
||||||
;; give up. |
|
||||||
(if (file-directory-p hsd) (expand-file-name hsd)))))) |
|
||||||
;; If there's no Cabal file or it's not helpful, try to look for |
|
||||||
;; a "module" statement and count the number of "." in the |
|
||||||
;; module name. |
|
||||||
(save-excursion |
|
||||||
(goto-char (point-min)) |
|
||||||
(let ((case-fold-search nil)) |
|
||||||
(when (re-search-forward |
|
||||||
"^module[ \t]+\\(\\(?:\\sw\\|[.]\\)+\\)" nil t) |
|
||||||
(let* ((dir default-directory) |
|
||||||
(module (match-string 1)) |
|
||||||
(pos 0)) |
|
||||||
(while (string-match "\\." module pos) |
|
||||||
(setq pos (match-end 0)) |
|
||||||
(setq dir (expand-file-name ".." dir))) |
|
||||||
;; Let's check that the module name matches the file name, |
|
||||||
;; otherwise the project root is probably not what we think. |
|
||||||
(if (eq t (compare-strings |
|
||||||
(file-name-sans-extension buffer-file-name) |
|
||||||
nil nil |
|
||||||
(expand-file-name |
|
||||||
(replace-regexp-in-string "\\." "/" module) |
|
||||||
dir) |
|
||||||
nil nil t)) |
|
||||||
dir |
|
||||||
;; If they're not equal, it means the local directory |
|
||||||
;; hierarchy doesn't match the module name. This seems |
|
||||||
;; odd, so let's warn the user about it. May help us |
|
||||||
;; debug this code as well. |
|
||||||
(message "Ignoring inconsistent `module' info: %s in %s" |
|
||||||
module buffer-file-name) |
|
||||||
nil))))))))) |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-load-file (&optional reload) |
|
||||||
"Pass the current buffer's file to the inferior haskell process. |
|
||||||
If prefix arg \\[universal-argument] is given, just reload the previous file." |
|
||||||
(interactive "P") |
|
||||||
;; Save first, so we're sure that `buffer-file-name' is non-nil afterward. |
|
||||||
(save-buffer) |
|
||||||
(let ((buf (current-buffer)) |
|
||||||
(file buffer-file-name) |
|
||||||
(proc (inferior-haskell-process))) |
|
||||||
(if file |
|
||||||
(with-current-buffer (process-buffer proc) |
|
||||||
(compilation-forget-errors) |
|
||||||
(let ((parsing-end (marker-position (process-mark proc))) |
|
||||||
root) |
|
||||||
;; Go to the root of the Cabal project, if applicable. |
|
||||||
(when (and inferior-haskell-find-project-root |
|
||||||
(setq root (inferior-haskell-find-project-root buf))) |
|
||||||
;; Not sure if it's useful/needed and if it actually works. |
|
||||||
(unless (equal default-directory root) |
|
||||||
(setq default-directory root) |
|
||||||
(inferior-haskell-send-command |
|
||||||
proc (concat ":cd " default-directory))) |
|
||||||
(setq file (file-relative-name file))) |
|
||||||
(inferior-haskell-send-command |
|
||||||
proc (if reload ":reload" |
|
||||||
(concat ":load \"" |
|
||||||
;; Espace the backslashes that may occur in file names. |
|
||||||
(replace-regexp-in-string "[\\\"]" "\\\\\&" file) |
|
||||||
"\""))) |
|
||||||
;; Move the parsing-end marker *after* sending the command so |
|
||||||
;; that it doesn't point just to the insertion point. |
|
||||||
;; Otherwise insertion may move the marker (if done with |
|
||||||
;; insert-before-markers) and we'd then miss some errors. |
|
||||||
(if (boundp 'compilation-parsing-end) |
|
||||||
(if (markerp compilation-parsing-end) |
|
||||||
(set-marker compilation-parsing-end parsing-end) |
|
||||||
(setq compilation-parsing-end parsing-end)))) |
|
||||||
(with-selected-window (display-buffer (current-buffer) nil 'visible) |
|
||||||
(goto-char (point-max))) |
|
||||||
;; Use compilation-auto-jump-to-first-error if available. |
|
||||||
;; (if (and (boundp 'compilation-auto-jump-to-first-error) |
|
||||||
;; compilation-auto-jump-to-first-error |
|
||||||
;; (boundp 'compilation-auto-jump-to-next)) |
|
||||||
;; (setq compilation-auto-jump-to-next t) |
|
||||||
(when inferior-haskell-wait-and-jump |
|
||||||
(inferior-haskell-wait-for-prompt proc) |
|
||||||
(ignore-errors ;Don't beep if there were no errors. |
|
||||||
(next-error)))) |
|
||||||
(error "No file associated with buffer")))) |
|
||||||
|
|
||||||
(defvar inferior-haskell-run-command ":main") |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-load-and-run (command) |
|
||||||
"Pass the current buffer's file to haskell and then run a COMMAND." |
|
||||||
(interactive |
|
||||||
(list |
|
||||||
(if (and inferior-haskell-run-command (not current-prefix-arg)) |
|
||||||
inferior-haskell-run-command |
|
||||||
(read-string "Command to run: " nil nil inferior-haskell-run-command)))) |
|
||||||
(setq inferior-haskell-run-command command) |
|
||||||
(let* ((inferior-haskell-errors nil) |
|
||||||
(neh (lambda () (setq inferior-haskell-errors t)))) |
|
||||||
(unwind-protect |
|
||||||
(let ((inferior-haskell-wait-and-jump t)) |
|
||||||
(add-hook 'next-error-hook neh) |
|
||||||
(inferior-haskell-load-file)) |
|
||||||
(remove-hook 'next-error-hook neh)) |
|
||||||
(unless inferior-haskell-errors |
|
||||||
(inferior-haskell-send-command (inferior-haskell-process) command) |
|
||||||
(switch-to-haskell)))) |
|
||||||
|
|
||||||
(defun inferior-haskell-send-command (proc str) |
|
||||||
(setq str (concat str "\n")) |
|
||||||
(with-current-buffer (process-buffer proc) |
|
||||||
(inferior-haskell-wait-for-prompt proc) |
|
||||||
(goto-char (process-mark proc)) |
|
||||||
(insert-before-markers str) |
|
||||||
(move-marker comint-last-input-end (point)) |
|
||||||
(setq inferior-haskell-seen-prompt nil) |
|
||||||
(comint-send-string proc str))) |
|
||||||
|
|
||||||
(defun inferior-haskell-reload-file () |
|
||||||
"Tell the inferior haskell process to reread the current buffer's file." |
|
||||||
(interactive) |
|
||||||
(inferior-haskell-load-file 'reload)) |
|
||||||
|
|
||||||
(defun inferior-haskell-wrap-decl (code) |
|
||||||
"Wrap declaration code into :{ ... :}." |
|
||||||
(setq code (concat code "\n")) |
|
||||||
(concat ":{\n" |
|
||||||
(if (string-match (concat "^\\s-*" |
|
||||||
haskell-ds-start-keywords-re) |
|
||||||
code) |
|
||||||
;; non-fun-decl |
|
||||||
code |
|
||||||
;; fun-decl, wrapping into let { .. (; ..)* } |
|
||||||
(concat "let {\n" |
|
||||||
(mapconcat |
|
||||||
;; adding 2 whitespaces to each line |
|
||||||
(lambda (decl) |
|
||||||
(mapconcat (lambda (s) |
|
||||||
(concat " " s)) |
|
||||||
(split-string decl "\n") |
|
||||||
"\n")) |
|
||||||
;; splitting function case-decls |
|
||||||
(let (decls) |
|
||||||
(while (string-match "^\\(\\w+\\).*\n*\\(?:\\s-+.*\n+\\)*" code) |
|
||||||
(push (match-string 0 code) decls) |
|
||||||
(setq code (substring code (match-end 0)))) |
|
||||||
(reverse decls)) |
|
||||||
"\n;\n") |
|
||||||
"\n}")) |
|
||||||
"\n:}\n")) |
|
||||||
|
|
||||||
(defun inferior-haskell-flash-decl (start end &optional timeout) |
|
||||||
"Temporarily highlight declaration." |
|
||||||
(let ((overlay (make-overlay start end))) |
|
||||||
(overlay-put overlay 'face 'secondary-selection) |
|
||||||
(run-with-timer (or timeout 0.2) nil 'delete-overlay overlay))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-send-decl () |
|
||||||
"Send current declaration to inferior-haskell process." |
|
||||||
(interactive) |
|
||||||
(save-excursion |
|
||||||
(goto-char (1+ (point))) |
|
||||||
(let* ((proc (inferior-haskell-process)) |
|
||||||
(start (or (haskell-ds-backward-decl) (point-min))) |
|
||||||
(end (or (haskell-ds-forward-decl) (point-max))) |
|
||||||
(raw-decl (buffer-substring start end))) |
|
||||||
;; enter multiline-prompt-cutting-mode |
|
||||||
(with-current-buffer (process-buffer proc) |
|
||||||
(setq inferior-haskell-send-decl-post-filter-on t)) |
|
||||||
;; flash decl |
|
||||||
(inferior-haskell-flash-decl start end) |
|
||||||
;; send decl |
|
||||||
(comint-send-string proc (inferior-haskell-wrap-decl raw-decl)) |
|
||||||
;; send preview |
|
||||||
(inferior-haskell-send-command |
|
||||||
proc |
|
||||||
(let* ((str (remove ?\n raw-decl)) |
|
||||||
(len (min 15 (length str)))) |
|
||||||
(concat "-- evaluating {: " |
|
||||||
(substring str 0 len) |
|
||||||
(if (= 15 len) ".." "") |
|
||||||
" :}")))))) |
|
||||||
|
|
||||||
(defun inferior-haskell-get-result (inf-expr) |
|
||||||
"Submit the expression `inf-expr' to ghci and read the result." |
|
||||||
(let ((proc (inferior-haskell-process))) |
|
||||||
(with-current-buffer (process-buffer proc) |
|
||||||
(let ((parsing-end ; Remember previous spot. |
|
||||||
(marker-position (process-mark proc)))) |
|
||||||
(inferior-haskell-send-command proc inf-expr) |
|
||||||
;; Find new point. |
|
||||||
(inferior-haskell-wait-for-prompt proc) |
|
||||||
(goto-char (point-max)) |
|
||||||
;; Back up to the previous end-of-line. |
|
||||||
(end-of-line 0) |
|
||||||
;; Extract the output |
|
||||||
(buffer-substring-no-properties |
|
||||||
(save-excursion (goto-char parsing-end) |
|
||||||
(line-beginning-position 2)) |
|
||||||
(point)))))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-type (expr &optional insert-value) |
|
||||||
"Query the haskell process for the type of the given expression. |
|
||||||
If optional argument `insert-value' is non-nil, insert the type above point |
|
||||||
in the buffer. This can be done interactively with the \\[universal-argument] prefix. |
|
||||||
The returned info is cached for reuse by `haskell-doc-mode'." |
|
||||||
(interactive |
|
||||||
(let ((sym (haskell-ident-at-point))) |
|
||||||
(list (read-string (if sym |
|
||||||
(format "Show type of (default %s): " sym) |
|
||||||
"Show type of: ") |
|
||||||
nil nil sym) |
|
||||||
current-prefix-arg))) |
|
||||||
(if (string-match "\\`\\s_+\\'" expr) (setq expr (concat "(" expr ")"))) |
|
||||||
(let ((type (inferior-haskell-get-result (concat ":type " expr)))) |
|
||||||
(if (not (string-match (concat "^\\(" (regexp-quote expr) |
|
||||||
"[ \t\n]+\\(::\\|∷\\)[ \t\n]*\\(.\\|\n\\)*\\)") |
|
||||||
type)) |
|
||||||
(error "No type info: %s" type) |
|
||||||
(progn |
|
||||||
(setf type (match-string 1 type)) |
|
||||||
;; Cache for reuse by haskell-doc. |
|
||||||
(when (and (boundp 'haskell-doc-mode) haskell-doc-mode |
|
||||||
(boundp 'haskell-doc-user-defined-ids) |
|
||||||
;; Haskell-doc only works for idents, not arbitrary expr. |
|
||||||
(string-match "\\`(?\\(\\s_+\\|\\(\\sw\\|\\s'\\)+\\)?[ \t]*\\(::\\|∷\\)[ \t]*" |
|
||||||
type)) |
|
||||||
(let ((sym (match-string 1 type))) |
|
||||||
(setq haskell-doc-user-defined-ids |
|
||||||
(cons (cons sym (substring type (match-end 0))) |
|
||||||
(delq (assoc sym haskell-doc-user-defined-ids) |
|
||||||
haskell-doc-user-defined-ids))))) |
|
||||||
|
|
||||||
(if (called-interactively-p 'any) (message "%s" type)) |
|
||||||
(when insert-value |
|
||||||
(beginning-of-line) |
|
||||||
(insert type "\n")) |
|
||||||
type)))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-kind (type) |
|
||||||
"Query the haskell process for the kind of the given expression." |
|
||||||
(interactive |
|
||||||
(let ((type (haskell-ident-at-point))) |
|
||||||
(list (read-string (if type |
|
||||||
(format "Show kind of (default %s): " type) |
|
||||||
"Show kind of: ") |
|
||||||
nil nil type)))) |
|
||||||
(let ((result (inferior-haskell-get-result (concat ":kind " type)))) |
|
||||||
(if (called-interactively-p 'any) (message "%s" result)) |
|
||||||
result)) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-info (sym) |
|
||||||
"Query the haskell process for the info of the given expression." |
|
||||||
(interactive |
|
||||||
(let ((sym (haskell-ident-at-point))) |
|
||||||
(list (read-string (if sym |
|
||||||
(format "Show info of (default %s): " sym) |
|
||||||
"Show info of: ") |
|
||||||
nil nil sym)))) |
|
||||||
(let ((result (inferior-haskell-get-result (concat ":info " sym)))) |
|
||||||
(if (called-interactively-p 'any) (message "%s" result)) |
|
||||||
result)) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-find-definition (sym) |
|
||||||
"Attempt to locate and jump to the definition of the given expression." |
|
||||||
(interactive |
|
||||||
(let ((sym (haskell-ident-at-point))) |
|
||||||
(list (read-string (if sym |
|
||||||
(format "Find definition of (default %s): " sym) |
|
||||||
"Find definition of: ") |
|
||||||
nil nil sym)))) |
|
||||||
(let ((info (inferior-haskell-info sym))) |
|
||||||
(if (not (string-match inferior-haskell-info-xref-re info)) |
|
||||||
(error "No source information available") |
|
||||||
(let ((file (match-string-no-properties 1 info)) |
|
||||||
(line (string-to-number |
|
||||||
(match-string-no-properties 2 info))) |
|
||||||
(col (string-to-number |
|
||||||
(match-string-no-properties 3 info)))) |
|
||||||
(when file |
|
||||||
(with-current-buffer (process-buffer (inferior-haskell-process)) |
|
||||||
;; The file name is relative to the process's cwd. |
|
||||||
(setq file (expand-file-name file))) |
|
||||||
;; Push current location marker on the ring used by `find-tag' |
|
||||||
(require 'etags) |
|
||||||
(xref-push-marker-stack) |
|
||||||
(pop-to-buffer (find-file-noselect file)) |
|
||||||
(when line |
|
||||||
(goto-char (point-min)) |
|
||||||
(forward-line (1- line)) |
|
||||||
(when col (move-to-column col)))))))) |
|
||||||
|
|
||||||
;;; Functions to find the documentation of a given function. |
|
||||||
;; |
|
||||||
;; TODO for this section: |
|
||||||
;; |
|
||||||
;; * Support fetching of local Haddock docs pulled directly from source files. |
|
||||||
;; * Display docs locally? w3m? |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom inferior-haskell-use-web-docs |
|
||||||
'fallback |
|
||||||
"Whether to use the online documentation. Possible values: |
|
||||||
`never', meaning always use local documentation, unless the local |
|
||||||
file doesn't exist, when do nothing, `fallback', which means only |
|
||||||
use the online documentation when the local file doesn't exist, |
|
||||||
or `always', meaning always use the online documentation, |
|
||||||
regardless of existance of local files. Default is `fallback'." |
|
||||||
:group 'inferior-haskell |
|
||||||
:type '(choice (const :tag "Never" never) |
|
||||||
(const :tag "As fallback" fallback) |
|
||||||
(const :tag "Always" always))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom inferior-haskell-web-docs-base |
|
||||||
"http://haskell.org/ghc/docs/latest/html/libraries/" |
|
||||||
"The base URL of the online libraries documentation. |
|
||||||
This will only be used if the value of `inferior-haskell-use-web-docs' |
|
||||||
is `always' or `fallback'." |
|
||||||
:group 'inferior-haskell |
|
||||||
:type 'string) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom haskell-package-manager-name "ghc-pkg" |
|
||||||
"Name of the program to consult regarding package details." |
|
||||||
:group 'inferior-haskell |
|
||||||
:type 'string) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom haskell-package-conf-file |
|
||||||
(condition-case nil |
|
||||||
(with-temp-buffer |
|
||||||
(call-process "ghc" nil t nil "--print-libdir") |
|
||||||
(expand-file-name "package.conf" |
|
||||||
(buffer-substring (point-min) (1- (point-max))))) |
|
||||||
;; Don't use `ignore-errors' because this form is not byte-compiled :-( |
|
||||||
(error nil)) |
|
||||||
"Where the package configuration file for the package manager resides. |
|
||||||
By default this is set to `ghc --print-libdir`/package.conf." |
|
||||||
:group 'inferior-haskell |
|
||||||
:type 'string) |
|
||||||
|
|
||||||
(defun inferior-haskell-get-module (sym) |
|
||||||
"Fetch the module in which SYM is defined." |
|
||||||
(let ((info (inferior-haskell-info sym))) |
|
||||||
(unless (string-match inferior-haskell-module-re info) |
|
||||||
(error |
|
||||||
"No documentation information available. Did you forget to C-c C-l?")) |
|
||||||
(let* ((module-name (match-string-no-properties 1 info)) |
|
||||||
(first-character (substring module-name 0 1))) |
|
||||||
;; Handles GHC 7.4.1+ which quotes module names like |
|
||||||
;; `System.Random', whereas previous GHC did not quote at all. |
|
||||||
(if (or (string= "`" first-character) (string= "‘" first-character)) |
|
||||||
|
|
||||||
(substring module-name 1 (- (length module-name) 1)) |
|
||||||
module-name)))) |
|
||||||
|
|
||||||
(defun inferior-haskell-query-ghc-pkg (&rest args) |
|
||||||
"Send ARGS to `haskell-package-manager-name'. |
|
||||||
Insert the output into the current buffer." |
|
||||||
(apply 'call-process haskell-package-manager-name nil t nil args)) |
|
||||||
|
|
||||||
(defun inferior-haskell-get-package-list () |
|
||||||
"Get the list of packages from `haskell-package-manager-name'." |
|
||||||
(with-temp-buffer |
|
||||||
(inferior-haskell-query-ghc-pkg "--simple-output" "list") |
|
||||||
(split-string (buffer-substring (point-min) (point-max))))) |
|
||||||
|
|
||||||
(defun inferior-haskell-compute-module-alist () |
|
||||||
"Compute a list mapping modules to package names and haddock URLs using ghc-pkg." |
|
||||||
(message "Generating module alist...") |
|
||||||
(let ((module-alist ())) |
|
||||||
(with-temp-buffer |
|
||||||
(dolist (package (inferior-haskell-get-package-list)) |
|
||||||
(erase-buffer) |
|
||||||
(inferior-haskell-query-ghc-pkg "describe" package) |
|
||||||
|
|
||||||
(let ((package-w/o-version |
|
||||||
(replace-regexp-in-string "[-.0-9]*\\'" "" package)) |
|
||||||
;; Find the Haddock documentation URL for this package |
|
||||||
(haddock |
|
||||||
(progn |
|
||||||
(goto-char (point-min)) |
|
||||||
(when (re-search-forward "haddock-html:[ \t]+\\(.*[^ \t\n]\\)" |
|
||||||
nil t) |
|
||||||
(match-string 1))))) |
|
||||||
|
|
||||||
;; Fetch the list of exposed modules for this package |
|
||||||
(goto-char (point-min)) |
|
||||||
(when (re-search-forward "^exposed-modules:\\(.*\\(\n[ \t].*\\)*\\)" |
|
||||||
nil t) |
|
||||||
(dolist (module (split-string (match-string 1))) |
|
||||||
(push (list module package-w/o-version haddock) |
|
||||||
module-alist))))) |
|
||||||
|
|
||||||
(message "Generating module alist... done") |
|
||||||
module-alist))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defcustom inferior-haskell-module-alist-file |
|
||||||
;; (expand-file-name "~/.inf-haskell-module-alist") |
|
||||||
(expand-file-name (concat "inf-haskell-module-alist-" |
|
||||||
(number-to-string (user-uid))) |
|
||||||
temporary-file-directory) |
|
||||||
"Where to save the module -> package lookup table. |
|
||||||
Set this to nil to never cache to a file." |
|
||||||
:group 'inferior-haskell |
|
||||||
:type '(choice (const :tag "Don't cache to file" nil) string)) |
|
||||||
|
|
||||||
(defvar inferior-haskell-module-alist nil |
|
||||||
"Association list of modules to their packages. |
|
||||||
Each element is of the form (MODULE PACKAGE HADDOCK), where |
|
||||||
MODULE is the name of a module, |
|
||||||
PACKAGE is the package it belongs to, and |
|
||||||
HADDOCK is the path to that package's Haddock documentation. |
|
||||||
|
|
||||||
This is calculated on-demand using `inferior-haskell-compute-module-alist'. |
|
||||||
It's also cached in the file `inferior-haskell-module-alist-file', |
|
||||||
so that it can be obtained more quickly next time.") |
|
||||||
|
|
||||||
(defun inferior-haskell-module-alist () |
|
||||||
"Get the module alist from cache or ghc-pkg's info." |
|
||||||
(or |
|
||||||
;; If we already have computed the alist, use it... |
|
||||||
inferior-haskell-module-alist |
|
||||||
(setq inferior-haskell-module-alist |
|
||||||
(or |
|
||||||
;; ...otherwise try to read it from the cache file... |
|
||||||
(and |
|
||||||
inferior-haskell-module-alist-file |
|
||||||
(file-readable-p inferior-haskell-module-alist-file) |
|
||||||
(file-newer-than-file-p inferior-haskell-module-alist-file |
|
||||||
haskell-package-conf-file) |
|
||||||
(with-temp-buffer |
|
||||||
(insert-file-contents inferior-haskell-module-alist-file) |
|
||||||
(goto-char (point-min)) |
|
||||||
(prog1 (read (current-buffer)) |
|
||||||
(message "Read module alist from file cache.")))) |
|
||||||
|
|
||||||
;; ...or generate it again and save it in a file for later. |
|
||||||
(let ((alist (inferior-haskell-compute-module-alist))) |
|
||||||
(when inferior-haskell-module-alist-file |
|
||||||
(with-temp-buffer |
|
||||||
(print alist (current-buffer)) |
|
||||||
;; Do the write to a temp file first, then rename it. |
|
||||||
;; This makes it more atomic, and suffers from fewer security |
|
||||||
;; holes related to race conditions if the file is in /tmp. |
|
||||||
(let ((tmp (make-temp-file inferior-haskell-module-alist-file))) |
|
||||||
(write-region (point-min) (point-max) tmp) |
|
||||||
(rename-file tmp inferior-haskell-module-alist-file |
|
||||||
'ok-if-already-exists)))) |
|
||||||
alist))))) |
|
||||||
|
|
||||||
(defvar inferior-haskell-ghc-internal-ident-alist |
|
||||||
;; FIXME: Fill this table, ideally semi-automatically. |
|
||||||
'(("GHC.Base.return" . "Control.Monad.return") |
|
||||||
("GHC.Base.String" . "Data.String.String") |
|
||||||
("GHC.List" . "Data.List"))) |
|
||||||
|
|
||||||
(defun inferior-haskell-map-internal-ghc-ident (ident) |
|
||||||
"Try to translate some internal GHC identifier to its alter ego in haskell docs." |
|
||||||
(let ((head ident) |
|
||||||
(tail "") |
|
||||||
remapped) |
|
||||||
(while (and (not |
|
||||||
(setq remapped |
|
||||||
(cdr (assoc head |
|
||||||
inferior-haskell-ghc-internal-ident-alist)))) |
|
||||||
(string-match "\\.[^.]+\\'" head)) |
|
||||||
(setq tail (concat (match-string 0 head) tail)) |
|
||||||
(setq head (substring head 0 (match-beginning 0)))) |
|
||||||
(concat (or remapped head) tail))) |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(defun inferior-haskell-find-haddock (sym) |
|
||||||
"Find and open the Haddock documentation of SYM. |
|
||||||
Make sure to load the file into GHCi or Hugs first by using C-c C-l. |
|
||||||
Only works for functions in a package installed with ghc-pkg, or |
|
||||||
whatever the value of `haskell-package-manager-name' is. |
|
||||||
|
|
||||||
This function needs to find which package a given module belongs |
|
||||||
to. In order to do this, it computes a module-to-package lookup |
|
||||||
alist, which is expensive to compute (it takes upwards of five |
|
||||||
seconds with more than about thirty installed packages). As a |
|
||||||
result, we cache it across sessions using the cache file |
|
||||||
referenced by `inferior-haskell-module-alist-file'. We test to |
|
||||||
see if this is newer than `haskell-package-conf-file' every time |
|
||||||
we load it." |
|
||||||
(interactive |
|
||||||
(let ((sym (haskell-ident-at-point))) |
|
||||||
(list (read-string (if sym |
|
||||||
(format "Find documentation of (default %s): " sym) |
|
||||||
"Find documentation of: ") |
|
||||||
nil nil sym)))) |
|
||||||
(let* (;; Find the module and look it up in the alist |
|
||||||
(module (inferior-haskell-get-module sym)) |
|
||||||
(full-name (inferior-haskell-map-internal-ghc-ident (concat module "." sym))) |
|
||||||
(_success (string-match "\\(.*\\)\\.\\(.*\\)" full-name)) |
|
||||||
(module (match-string 1 full-name)) |
|
||||||
(sym (match-string 2 full-name)) |
|
||||||
(alist-record (assoc module (inferior-haskell-module-alist))) |
|
||||||
(package (nth 1 alist-record)) |
|
||||||
(file-name (concat (subst-char-in-string ?. ?- module) ".html")) |
|
||||||
(local-path (concat (nth 2 alist-record) "/" file-name)) |
|
||||||
(url (if (or (eq inferior-haskell-use-web-docs 'always) |
|
||||||
(and (not (file-exists-p local-path)) |
|
||||||
(eq inferior-haskell-use-web-docs 'fallback))) |
|
||||||
(concat inferior-haskell-web-docs-base package "/" file-name) |
|
||||||
(and (file-exists-p local-path) |
|
||||||
(concat "file://" local-path)))) |
|
||||||
;; Jump to the symbol within Haddock. |
|
||||||
(url (concat url "#v:" sym))) |
|
||||||
(if url (browse-url url) (error "Local file doesn't exist")))) |
|
||||||
|
|
||||||
(defvar inf-haskell-mode-map |
|
||||||
(let ((map (make-sparse-keymap))) |
|
||||||
;; (define-key map [?\M-C-x] 'inferior-haskell-send-defun) |
|
||||||
;; (define-key map [?\C-x ?\C-e] 'inferior-haskell-send-last-sexp) |
|
||||||
;; (define-key map [?\C-c ?\C-r] 'inferior-haskell-send-region) |
|
||||||
(define-key map [?\C-x ?\C-d] 'inferior-haskell-send-decl) |
|
||||||
(define-key map [?\C-c ?\C-z] 'switch-to-haskell) |
|
||||||
(define-key map [?\C-c ?\C-l] 'inferior-haskell-load-file) |
|
||||||
;; I think it makes sense to bind inferior-haskell-load-and-run to C-c |
|
||||||
;; C-r, but since it used to be bound to `reload' until June 2007, I'm |
|
||||||
;; going to leave it out for now. |
|
||||||
;; (define-key map [?\C-c ?\C-r] 'inferior-haskell-load-and-run) |
|
||||||
(define-key map [?\C-c ?\C-b] 'switch-to-haskell) |
|
||||||
;; (define-key map [?\C-c ?\C-s] 'inferior-haskell-start-process) |
|
||||||
;; That's what M-; is for. |
|
||||||
(define-key map (kbd "C-c C-t") 'inferior-haskell-type) |
|
||||||
(define-key map (kbd "C-c C-i") 'inferior-haskell-info) |
|
||||||
(define-key map (kbd "C-c M-.") 'inferior-haskell-find-definition) |
|
||||||
(define-key map (kbd "C-c C-d") 'inferior-haskell-find-haddock) |
|
||||||
(define-key map [?\C-c ?\C-v] 'haskell-check) |
|
||||||
map) |
|
||||||
"Keymap for using inf-haskell.") |
|
||||||
|
|
||||||
;;;###autoload |
|
||||||
(define-minor-mode inf-haskell-mode |
|
||||||
"Minor mode for enabling inf-haskell process interaction." |
|
||||||
:lighter " Inf-Haskell" |
|
||||||
:keymap inf-haskell-mode-map) |
|
||||||
|
|
||||||
(provide 'inf-haskell) |
|
||||||
|
|
||||||
;;; inf-haskell.el ends here |
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue