Taylor Bockman
10 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