From 924ac7c84fbb56cec26819bb9755a10ae1d7fccb Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Mon, 14 Sep 2015 16:29:59 -0700 Subject: [PATCH] Squashed 'site-lisp/haskell-mode/' changes from 6a4d4bd..47d90c8 47d90c8 Support multiple presentations at once in the same REPL d027f9f Thread hash through presentation functions a0dd740 Split interaction mode into two minor modes a la indentation 591d1a8 Fix inserting of type in haskell-describe 5c817ee Add initial haskell-describe function e300782 Add import suggestions based on haskell-docs 050a119 Support 7.8 in extension completion faf4c56 Support GHC 7.8's message format for extension suggestions d62f51a Improve usefulness of file-relative-name in cycle code 36e39a4 Pick up import cycles as loading errors with fake line numbers 073344e Merge pull request #282 from bergey/cabal-path 52fafce Merge pull request #284 from ryantm/byte-compile-warnings a73cb69 add missing requires in haskell-debug 905faf5 Merge pull request #283 from ryantm/byte-compile-warnings ae0e87c Add try-type 95dbb75 do not require w3m 5ffbf1d stop using goto-line as recommended by emacs help on goto-line 8f02b8c Use haskell-process-path-cabal everywhere ca84191 Make popups disableable (fixes #280) f7f1a17 Show ... if more results in module completion, a la ido-mode 5985f84 Use `haskell-complete-module' for module completions e49c0e5 Satisfy Makefile warnings for haskell-complete-module c285ee3 Fix e reference in haskell-process.el 55b9c7c Add haskell-complete-module a8c4c12 Don't ask about importing the same module more than once d3f3f5b Handle errors and quitting in process commands more gracefully 89917d2 Skip whole module qualification in hoogle import suggestions 76c505d Add kill-whole-line support in REPL (closes #277) 2df11b6 Fix warning detection regex (fixes #275) cda2fc8 Merge pull request #274 from Philonous/master 69ead72 Fix getLine with no stdout output 9f65077 curb process restart spam c2206c9 Remove debug message 976917b Add back padding option in haskell-align-imports (#183) 3d834d4 Fix OverloadedStrings suggester cc161d7 Test cases for haskell-sort-imports (#270) fbdc679 Sort on just module names (#270) 8f2a7e0 Rewrite sort-imports to not be line-based (#270) efe9bbe Make sure to expand filename when getting definition dir c58058e Trivial function for dumping minimal imports 832fcc6 Fix haskell-process-hoogle-ident 02fedeb Experimental refactor of jumping to definition ed148c9 Fix make build for Emacs 23 b180578 Throw error if trying to create a session that already exists ff2f361 Improve session switching c8a72bd Avoid prompting on incomplete sessions when sifting 52b93a6 Fix face references in haskell-debug (fixes #268) ee537a5 Fix Show detection in presence of newline 5df78d2 Fix ill-advised removal of prompt stripping 1eb2b2b Let haskell-process-hoogle-ident fail silently on error 116e66a Add hoogle server commands 88b4091 Modify hoogle-suggest regexes for ghc 7.8 compatibility 23b385b Additional fix for ghci prompt inferior-haskell-mode 8fbc5f6 Support stdin input in the REPL e827a17 Remove redundant newline in colorized output 7fb632a Update README to ref wiki manual cefa9e9 Make showing types of ambiguous/no-show expressions customizable 7102355 Show types for ambiguous type variables in the REPL, too a22f7a1 Make import questioning more persistent at getting an answer 33f0011 Add module template auto-insertion function 8a774c7 Support arbitrary cabal command e9934ab Fix auto-type-showing in presence of :set +t e1a0d86 Show the type of something if no Show instance is available c4dc84f Add require cl c6d22db Fix format of customization of -w3m-haddock-dirs fa0835f Handle unrepresentable things in :present 9073057 Update to present-1.0 (you need to cabal install present==1.0) 007f585 Fix to pass make check 7c1d6b1 Fix missing function reference 254ba72 Handle compile messages from GHC that contain [TH] 9324171 Much better list presentations 18713e6 Indent alg-types with newlines and regular indentation 5f90c1d Support multiple directories in w3m-haddock eddb5c1 Add preliminary :present support f6c4b86 Fix error in haskell-interactive-mode completion (#263) 5e4907f Fix spacing in type info regression (#264) aa07205 Popup error buffer instead of displaying them in the REPL 35527f9 Add sexp-based collapsing support in REPL 099c82c Strip newlines from haskell-process-do-type 5128d4d Fix haskell-debug for recent prompt handling changes. 433c16a Dump complete output if zero compiler messages from cabal b5ca602 Strip out extraneous prompts 58810a1 Declare use of -insert-garbage c2e7dbf Echo extraneous output after prompt has been received 277e8e8 Use end-of-transmission for prompt d9aa484 Only save again after stylish if necessary. 3d1ff09 Print a newline as soon as the command starts to execute. a0a33d3 Make haskell-align-imports-padding a total function 110aa35 Add a command to send cabal macros (#255) e9587d9 Make haskell-interactive-at-prompt return position f1962fe Add back 'break properties to breakpoint list c621a21 Support next/previous properly 0963af4 Reset history and bindings cache after abandoning f0748c2 Re-step after reloading af495c2 Debugger with bindings display d2ba091 Keep hold of the back trace for helpful display at the end 6219ad6 Good progress on debugger stepping d5b3577 fixes #250, haskell-interactive mode broken under certain conditions 92581b1 A bit more of the debugger mode 69fe380 Start of implementation of interactive debugger aec3d05 Add .dump-simpl files to ghc-core auto-mode-alist 6bb7cad More liberal source match 92f2f26 Add customization setting for header color 6bd7c56 Add haskell-w3m-open-haddock c1f982e Remove accidentally left in font-lock experiment 9b43204 Add multi-line support in REPL 5a3a996 Add haskell-process-reload-devel-main interactive command 2684a4f Use marker instead of regexps in haskell-interactive-mode prompt 5ce988e Support continuations in the process loading 6bec474 Add w3m-haddock.el 7ddc44f Disable hoogle suggestion by default 6ca09d0 Replace completing-read-function with custom for haskell-mode 1248ab0 Defvar completing-read-function 4bcb2db Declare 'delete-active-region' in haskell-indentation ec00623 Replace 'ido-completing-read' with 'completing-read-function' 1af6521 Another attempt at removing EOF newline. 2a97e4c Remove EOF newline. These are explicit in snippets. 6615415 Ability to configure the import line on suggestions 17c8a28 Fix dynamic-binding reference 96ffb1f Separate running a line in haskell-interactive-mode into another function 1db9dde Use && instead of ; because this works on Windows, too (refs #232) 1834c3b Option to automatically chmod .ghci files that GHCi ignores 55408fc Make showing debugging tips an option 692afb9 Make errors expanded by default 7b3946d Check for build/install as substring a4a8a09 Allow whitespace before settings. 182e34f Don't use replace-regexp to appease make check 1c6ef10 Support god-mode on SPC key 175c6cc Better "not in scope" detection ab7ee92 Strip out M./S./L. typical module prefixes for suggestion functionality 38e8c06 Make navigate-imports a bit more useful in absense of import list c85219a Ignore package results 5ae3835 Support the case of multiple available modules for auto-import 89b036d Automatically add package to cabal file f44c2d3 Make dummy global binding to avoid not-in-scope warnings ed4d9e8 Automatically add import lines via Hoogle 9292ba1 Fix undefined reference to shm-display-quarantine in haskell-present fa1b365 Support jumping to filenames inside strings 7e74535 Small indentation fix 0ae55ff Quick hack to remove "Compilation failed" line f13eae5 Support commenting out of imports dc3a02f Add a function to guess the module name of the current buffer c910ed0 Don't show shm's display quarantines in presentation mode 3f7747e Fix delete-backward-char in haskell-indentation (fixes #211) 3ade6a8 Merge pull request #214 from brandonw/master 29c0b98 Merge pull request #217 from adimit/patch-1 c9424aa add support for cabal repl build targets 7ae7411 Add haskell-bot.el, for interacting with locally installed lambdabot 54e6ccd Fix import.qualified. 4f87331 Fix internal GHC module translation c925867 Revert "Fix internal GHC module translation" 43f2747 Always use the ident as an anchor 0ff0841 Update internal GHC module translations 53a63a1 Fix internal GHC module translation git-subtree-dir: site-lisp/haskell-mode git-subtree-split: 47d90c83f101596be92a44d98b9ebf8a6089efc0 --- Makefile | 2 + README.md | 22 +- ghc-core.el | 2 +- haskell-align-imports.el | 70 ++- haskell-bot.el | 176 +++++++ haskell-cabal.el | 2 +- haskell-collapse.el | 65 +++ haskell-compile.el | 4 +- haskell-complete-module.el | 113 ++++ haskell-debug.el | 693 +++++++++++++++++++++++++ haskell-indentation.el | 6 +- haskell-interactive-mode.el | 619 ++++++++++++++++++---- haskell-mode.el | 331 ++++++++++-- haskell-navigate-imports.el | 6 +- haskell-presentation-mode.el | 2 + haskell-process.el | 643 ++++++++++++++++++++--- haskell-session.el | 102 +++- haskell-sort-imports.el | 129 +++-- inf-haskell.el | 47 +- snippets/haskell-mode/import.qualified | 2 +- tests/haskell-sort-imports-tests.el | 132 +++++ w3m-haddock.el | 183 +++++++ 22 files changed, 3020 insertions(+), 331 deletions(-) create mode 100644 haskell-bot.el create mode 100644 haskell-collapse.el create mode 100644 haskell-complete-module.el create mode 100644 haskell-debug.el create mode 100644 tests/haskell-sort-imports-tests.el create mode 100644 w3m-haddock.el diff --git a/Makefile b/Makefile index d3608663a3..6717de2ee9 100644 --- a/Makefile +++ b/Makefile @@ -20,12 +20,14 @@ ELFILES = \ haskell-font-lock.el \ haskell-indent.el \ haskell-indentation.el \ + haskell-collapse.el \ haskell-interactive-mode.el \ haskell-menu.el \ haskell-mode.el \ haskell-move-nested.el \ haskell-navigate-imports.el \ haskell-package.el \ + haskell-complete-module.el \ haskell-process.el \ haskell-session.el \ haskell-show.el \ diff --git a/README.md b/README.md index 9ff766134a..1c4ccc1749 100644 --- a/README.md +++ b/README.md @@ -3,8 +3,20 @@ Haskell Mode for Emacs [![Build Status](https://travis-ci.org/haskell/haskell-mode.png?branch=master)](https://travis-ci.org/haskell/haskell-mode) -This is the Haskell mode package for Emacs. Its use should be mostly -self-explanatory if you're accustomed to Emacs. +This is the Haskell mode package for Emacs. + +Please see +[the online haskell-mode manual](https://github.com/haskell/haskell-mode/wiki) +for setup and use guide. + +To report problems or suggestions, please +[open an issue](https://github.com/haskell/haskell-mode/issues?state=open) +in the issue tracker. + +Below is a brief setup guide. + +Quick Emacs rundown +-------------------- When Emacs is started up, it normally loads the [Emacs initialization file](http://www.gnu.org/software/emacs/manual/html_node/emacs/Init-File.html) @@ -110,13 +122,13 @@ $ apt-get install haskell-mode - Invoking `make haskell-mode-autoloads.el`, or `make all` (use this to perform byte-compilation and Info manual generation) - + - From inside Emacs, `M-x update-directory-autoloads` and answering the question for the folder with `~/lib/emacs/haskell-mode/` and the question for the output-file with `~/lib/emacs/haskell-mode/haskell-mode-autoloads.el` - + and then adding the following command to your `.emacs`: - + ```el (add-to-list 'load-path "~/lib/emacs/haskell-mode/") (require 'haskell-mode-autoloads) diff --git a/ghc-core.el b/ghc-core.el index 4f39d79834..03d0a53188 100644 --- a/ghc-core.el +++ b/ghc-core.el @@ -29,7 +29,6 @@ ;; and removal of commonly ignored annotations. ;;; Code: - (require 'haskell-mode) (require 'haskell-font-lock) @@ -112,6 +111,7 @@ in the current buffer." ;;;###autoload (add-to-list 'auto-mode-alist '("\\.hcr\\'" . ghc-core-mode)) +(add-to-list 'auto-mode-alist '("\\.dump-simpl\\'" . ghc-core-mode)) ;;;###autoload (define-derived-mode ghc-core-mode haskell-mode "GHC-Core" diff --git a/haskell-align-imports.el b/haskell-align-imports.el index db0ad72ae6..7ae45ed8f8 100644 --- a/haskell-align-imports.el +++ b/haskell-align-imports.el @@ -48,6 +48,30 @@ ;; 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 @@ -77,7 +101,18 @@ (concat "^\\(import[ ]+\\)" "\\(qualified \\)?" "[ ]*\\(\"[^\"]*\" \\)?" - "[ ]*\\([A-Za-z0-9_.']*.*\\)")) + "[ ]*\\([A-Za-z0-9_.']+\\)" + "[ ]*\\([ ]*as [A-Z][^ ]*\\)?" + "[ ]*\\((.*)\\)?" + "\\([ ]*hiding (.*)\\)?" + "\\( -- .*\\)?[ ]*$") + "Regex used for matching components of an import.") + +(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 () @@ -131,14 +166,23 @@ "") b)) ls)))) - (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)))) + (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." @@ -149,9 +193,11 @@ (defun haskell-align-imports-padding (imports) "Find the padding for each part of the import statements." - (reduce (lambda (a b) (mapcar* #'max a b)) - (mapcar (lambda (x) (mapcar #'length (car x))) - imports))) + (if (null imports) + imports + (reduce (lambda (a b) (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." diff --git a/haskell-bot.el b/haskell-bot.el new file mode 100644 index 0000000000..6969d9413e --- /dev/null +++ b/haskell-bot.el @@ -0,0 +1,176 @@ +;;; haskell-bot.el --- A Lambdabot interaction mode + +;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2001 Chris Webb +;; Copyright (C) 1998, 1999 Guy Lapalme + +;; Keywords: inferior mode, Bot interaction mode, 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; Purpose: +;; +;; To send a Haskell buffer to another buffer running a Bot +;; interpreter. +;; +;; This mode is derived from version 1.1 of Guy Lapalme's +;; haskell-hugs.el, which can be obtained from: +;; +;; http://www.iro.umontreal.ca/~lapalme/Hugs-interaction.html +;; +;; This in turn was adapted from Chris Van Humbeeck's hugs-mode.el, +;; which can be obtained from: +;; +;; http://www-i2.informatik.rwth-aachen.de/Forschung/FP/Haskell/hugs-mode.el +;; +;; +;; Installation: +;; +;; To use with Moss and Thorn's haskell-mode.el +;; +;; http://www.haskell.org/haskell-mode +;; +;; add this to .emacs: +;; +;; (add-hook 'haskell-mode-hook 'turn-on-haskell-bot) +;; +;; +;; Customisation: +;; +;; The name of the Bot interpreter is in haskell-bot-program-name. +;; +;; Arguments can be sent to the Bot interpreter when it is started by +;; setting haskell-bot-program-args (empty by default) to a list of +;; string args to pass it. This value can be set interactively by +;; calling C-c C-s with an argument (i.e. C-u C-c C-s). +;; +;; `haskell-bot-hook' is invoked in the *bot* buffer once Bot is +;; started. +;; +;; All functions/variables start with `turn-{on,off}-haskell-bot' or +;; `haskell-bot-'. + +;;; Code: + +(defgroup haskell-bot nil + "Major mode for interacting with an inferior Bot session." + :group 'haskell + :prefix "haskell-bot-") + +(define-derived-mode haskell-bot-mode comint-mode "Lambdabot") + +;; Bot interface: + +(require 'comint) +(require 'shell) + +(defvar haskell-bot-process nil + "The active Bot subprocess corresponding to current buffer.") + +(defvar haskell-bot-process-buffer nil + "*Buffer used for communication with Bot subprocess for current buffer.") + +(defcustom haskell-bot-program-name "lambdabot" + "*The name of the Bot interpreter program." + :type 'string + :group 'haskell-bot) + +(defcustom haskell-bot-program-args nil + "*A list of string args to pass when starting the Bot interpreter." + :type '(repeat string) + :group 'haskell-bot) + +(defvar haskell-bot-load-end nil + "Position of the end of the last load command.") + +(defvar haskell-bot-error-pos nil + "Position of the end of the last load command.") + +(defvar haskell-bot-send-end nil + "Position of the end of the last send command.") + +(defvar haskell-bot-comint-prompt-regexp + "^lambdabot> " + "A regexp that matches the Bot prompt.") + +(defun haskell-bot-start-process (arg) + "Start a Bot process and invoke `haskell-bot-hook' if not nil. +Prompt for a list of args if called with an argument." + (interactive "P") + (if arg + ;; XXX [CDW] Fix to use more natural 'string' version of the + ;; XXX arguments rather than a sexp. + (setq haskell-bot-program-args + (read-minibuffer (format "List of args for %s:" + haskell-bot-program-name) + (prin1-to-string haskell-bot-program-args)))) + + ;; Start the Bot process in a new comint buffer. + (message "Starting Lambdabot process `%s'." haskell-bot-program-name) + (setq haskell-bot-process-buffer + (apply 'make-comint + "lambdabot" haskell-bot-program-name nil + haskell-bot-program-args)) + (setq haskell-bot-process + (get-buffer-process haskell-bot-process-buffer)) + + ;; Select Bot buffer temporarily. + (set-buffer haskell-bot-process-buffer) + (haskell-bot-mode) + (setq comint-prompt-regexp haskell-bot-comint-prompt-regexp) + + ;; History syntax of comint conflicts with Haskell, e.g. !!, so better + ;; turn it off. + (setq comint-input-autoexpand nil) + (setq comint-process-echoes nil) + (run-hooks 'haskell-bot-hook) + + ;; Clear message area. + (message "")) + +(defun haskell-bot-wait-for-output () + "Wait until output arrives and go to the last input." + (while (progn + (goto-char comint-last-input-end) + (not (re-search-forward comint-prompt-regexp nil t))) + (accept-process-output haskell-bot-process))) + +(defun haskell-bot-send (&rest string) + "Send `haskell-bot-process' the arguments (one or more strings). +A newline is sent after the strings and they are inserted into the +current buffer after the last output." + (haskell-bot-wait-for-output) ; wait for prompt + (goto-char (point-max)) ; position for this input + (apply 'insert string) + (comint-send-input) + (setq haskell-bot-send-end (marker-position comint-last-input-end))) + +(defun haskell-bot-show-bot-buffer () + "Go to the *bot* buffer." + (interactive) + (if (or (not haskell-bot-process-buffer) + (not (buffer-live-p haskell-bot-process-buffer))) + (haskell-bot-start-process nil)) + (pop-to-buffer haskell-bot-process-buffer)) + +(provide 'haskell-bot) + +;;; haskell-bot.el ends here diff --git a/haskell-cabal.el b/haskell-cabal.el index a9bb6fe1a3..f6393960bd 100644 --- a/haskell-cabal.el +++ b/haskell-cabal.el @@ -133,7 +133,7 @@ (let ((case-fold-search t)) (goto-char (point-min)) (when (re-search-forward - (concat "^" (regexp-quote name) + (concat "^[ \t]*" (regexp-quote name) ":[ \t]*\\(.*\\(\n[ \t]+[ \t\n].*\\)*\\)") nil t) (let ((val (match-string 1)) diff --git a/haskell-collapse.el b/haskell-collapse.el new file mode 100644 index 0000000000..e8dc8697b7 --- /dev/null +++ b/haskell-collapse.el @@ -0,0 +1,65 @@ +;;; haskell-collapse.el --- Collapse expressions + +;; 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 . + +;;; 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 (eq (get-text-property (point) 'face) 'font-lock-string-face) + (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) diff --git a/haskell-compile.el b/haskell-compile.el index f2c07096c7..73181accaa 100644 --- a/haskell-compile.el +++ b/haskell-compile.el @@ -35,14 +35,14 @@ :group 'haskell) (defcustom haskell-compile-cabal-build-command - "cd %s; cabal build --ghc-option=-ferror-spans" + "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) (defcustom haskell-compile-cabal-build-alt-command - "cd %s; cabal clean -s; cabal build --ghc-option=-ferror-spans" + "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 diff --git a/haskell-complete-module.el b/haskell-complete-module.el new file mode 100644 index 0000000000..1d1f4f9e26 --- /dev/null +++ b/haskell-complete-module.el @@ -0,0 +1,113 @@ +;;; haskell-complete-module.el --- A fast way to complete Haskell module names + +;; 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 . + +;;; Code: + +(require 'cl) + +(defcustom haskell-complete-module-preferred + '() + "Override ordering of module results by specifying preferred modules." + :group 'haskell + :type '(repeat string)) + +(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 ((continue t) + (stack (list)) + (pattern "") + (result nil)) + (setq candidates + (sort candidates + (lambda (a b) + (if (and (member a haskell-complete-module-preferred) + (not (member b haskell-complete-module-preferred))) + -1 + (string< a b))))) + (while (not result) + (let ((key (read-event (concat (propertize prompt 'face 'minibuffer-prompt) + (propertize pattern 'face 'font-lock-type-face) + "{" + (mapconcat #'identity + (let* ((i 0)) + (loop for candidate in candidates + while (<= i haskell-complete-module-max-display) + do (incf i) + collect (cond ((> i haskell-complete-module-max-display) + "...") + ((= i 1) + (propertize candidate 'face 'ido-first-match-face)) + (t candidate)))) + " | ") + "}")))) + (case key + (backspace + (unless (null stack) + (setq candidates (pop stack))) + (unless (string= "" pattern) + (setq pattern (substring pattern 0 -1)))) + (return (setq result (car candidates))) + (left (setq candidates (append (last candidates) (butlast candidates)))) + (right (setq candidates (append (cdr candidates) (list (car candidates))))) + (t (when (characterp key) + (let ((char (char-to-string key))) + (when (string-match "[A-Za-z0-9_'.]+" char) + (push candidates stack) + (setq pattern (concat pattern char)) + (setq candidates (haskell-complete-module pattern candidates))))))))) + result)) + +(defun haskell-complete-module (pattern candidates) + "Filter the CANDIDATES using PATTERN." + (let ((case-fold-search t)) + (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) diff --git a/haskell-debug.el b/haskell-debug.el new file mode 100644 index 0000000000..4aab803a6e --- /dev/null +++ b/haskell-debug.el @@ -0,0 +1,693 @@ +;;; haskell-debug.el --- Debugging mode via GHCi + +;; 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 . + +;;; Code: + +(require 'cl) + +(require 'haskell-session) +(require 'haskell-process) +(require 'haskell-interactive-mode) + +(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!"))) + +(defgroup haskell-debug nil + "Settings for debugging support." + :link '(custom-manual "(haskell-mode)haskell-debug") + :group 'haskell) + +(defface haskell-debug-warning-face + '((t :inherit 'compilation-warning)) + "Face for warnings." + :group 'haskell-debug) + +(defface haskell-debug-trace-number-face + '((t :weight bold :background "#f5f5f5")) + "Face for numbers in backtrace." + :group 'haskell-debug) + +(defface haskell-debug-newline-face + '((t :weight bold :background "#f0f0f0")) + "Face for newlines in trace steps." + :group 'haskell-debug) + +(defface haskell-debug-keybinding-face + '((t :inherit 'font-lock-type-face :weight bold)) + "Face for keybindings." + :group 'haskell-debug) + +(defface haskell-debug-heading-face + '((t :inherit 'font-lock-keyword-face)) + "Face for headings." + :group 'haskell-debug) + +(defface haskell-debug-muted-face + '((t :foreground "#999")) + "Face for muteds." + :group 'haskell-debug) + +(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 "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) + +(defvar haskell-debug-history-cache nil + "Cache of the tracing history.") + +(defvar haskell-debug-bindings-cache nil + "Cache of the current step's bindings.") + +(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 () + "Start the debugger for the current Haskell (GHCi) session." + (interactive) + (let ((session (haskell-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/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-process) + (format ":delete %d" + (plist-get break :number))) + (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-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 + (set (make-local-variable '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-session)) + (loop for break in breakpoints + do (haskell-process-file-loadish + (concat "load " (plist-get break :path)) + nil + nil)) + (loop for break in breakpoints + do (haskell-debug-break break)) + (haskell-debug/step expr))))))))) + (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/refresh () + "Refresh the debugger buffer." + (interactive) + (with-current-buffer (haskell-debug-buffer-name (haskell-session)) + (let ((inhibit-read-only t) + (p (point))) + (erase-buffer) + (insert (propertize (concat "Debugging " + (haskell-session-name (haskell-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-break (break) + "Set BREAK breakpoint in module at line/col." + (haskell-process-queue-without-filters + (haskell-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-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-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-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") + (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-history (history) + "Insert tracing HISTORY." + (let ((i (length history))) + (loop for span in history + do (let ((string (haskell-debug-get-span-string + (plist-get span :path) + (plist-get span :span))) + (index (plist-get span :index))) + (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-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-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)) + (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-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-insert-bindings (modules breakpoints context) + "Insert a list of bindings." + (if breakpoints + (progn (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-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/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/abandon () + "Abandon the current computation." + (interactive) + (haskell-debug-with-breakpoints + (haskell-process-queue-sync-request (haskell-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-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-process) + (concat ":break " + ident)) + (message "Breaking on function: %s" ident) + (haskell-debug/refresh)))) + +(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/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-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-insert-modules (modules) + "Insert the list of modules." + (haskell-debug-insert-header "Modules") + (if (null modules) + (haskell-debug-insert-muted "No loaded modules.") + (progn (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-insert-header (title) + "Insert a header title." + (insert (propertize title + 'face 'haskell-debug-heading-face) + "\n\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.") + (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-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-buffer-name (session) + "The debug buffer name for the current session." + (format "*debug:%s*" + (haskell-session-name session))) + +(defun haskell-debug-start (session) + "Start the debug mode." + (setq buffer-read-only t) + (haskell-session-assign session) + (haskell-debug/refresh)) + +(defun haskell-debug-split-string (string) + "Split GHCi's line-based output, stripping the trailing newline." + (split-string string "\n" t)) + +(defun haskell-debug-get-modules () + "Get the list of modules currently set." + (let ((string (haskell-process-queue-sync-request + (haskell-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-process) + ":show context"))) + (if (string= string "") + nil + (haskell-debug-parse-context string)))) + +(defun haskell-debug-navigate (direction) + "Navigate in DIRECTION \"back\" or \"forward\"." + (let ((string (haskell-process-queue-sync-request + (haskell-process) + (concat ":" direction)))) + (let ((bindings (haskell-debug-parse-logged string))) + (set (make-local-variable 'haskell-debug-bindings-cache) + bindings) + (when (not bindings) + (message "No more %s results!" direction))) + (haskell-debug/refresh))) + +(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-get-history () + "Get the step history." + (let ((string (haskell-process-queue-sync-request + (haskell-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 + (remove-if (lambda (line) (or (string= "" line) + (string= "..." line))) + (haskell-debug-split-string string))))) + (set (make-local-variable 'haskell-debug-history-cache) + entries) + entries))))) + +(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-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-get-breakpoints () + "Get the list of breakpoints currently set." + (let ((string (haskell-process-queue-sync-request + (haskell-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-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-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))) + +(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)))) + +(provide 'haskell-debug) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/haskell-indentation.el b/haskell-indentation.el index 51efee6fad..795e8ede98 100644 --- a/haskell-indentation.el +++ b/haskell-indentation.el @@ -35,6 +35,8 @@ (require 'syntax) (with-no-warnings (require 'cl)) +(defvar delete-active-region) + ;; Dynamically scoped variables. (defvar following-token) (defvar current-token) @@ -378,8 +380,8 @@ Preserves indentation and removes extra whitespace" (cond ((haskell-indentation-outside-bird-line) (delete-char (- n))) - ((and delete-selection-mode - mark-active + ((and (use-region-p) + delete-active-region (not (= (point) (mark)))) (delete-region (mark) (point))) ((or (= (haskell-current-column) 0) diff --git a/haskell-interactive-mode.el b/haskell-interactive-mode.el index bf8db02b4a..2763ba24a1 100644 --- a/haskell-interactive-mode.el +++ b/haskell-interactive-mode.el @@ -28,10 +28,30 @@ ;;; Code: (require 'haskell-process) +(require 'haskell-collapse) (require 'haskell-session) (require 'haskell-show) (with-no-warnings (require 'cl)) +(defcustom haskell-interactive-popup-errors + t + "Popup errors in a separate buffer." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-interactive-mode-collapse + nil + "Collapse printed results." + :type 'boolean + :group 'haskell-interactive) + +(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) + (defcustom haskell-interactive-mode-eval-pretty nil "Print eval results that can be parsed as Show instances prettily. Requires sexp-show (on Hackage)." @@ -47,6 +67,19 @@ at the beginning of the line. This should prevent any interference with prompts that look like haskell expressions." (concat "^" (regexp-quote haskell-interactive-prompt))) +(defvar haskell-interactive-mode-prompt-start + nil + "Mark used for the beginning of the prompt.") + +(defvar haskell-interactive-mode-result-end + nil + "Mark used to figure out where the end of the current result + output is. Used to distinguish betwen user input.") + +(defvar haskell-interactive-mode-old-prompt-start + nil + "Mark used for the old beginning of the prompt.") + (defcustom haskell-interactive-mode-eval-mode nil "Use the given mode's font-locking to render some text." @@ -54,7 +87,7 @@ interference with prompts that look like haskell expressions." :group 'haskell-interactive) (defcustom haskell-interactive-mode-hide-multi-line-errors - t + nil "Hide collapsible multi-line compile messages by default." :type 'boolean :group 'haskell-interactive) @@ -87,6 +120,7 @@ printing compilation messages." (define-key map (kbd "C-") 'haskell-interactive-mode-history-previous) (define-key map (kbd "C-") 'haskell-interactive-mode-history-next) (define-key map (kbd "TAB") 'haskell-interactive-mode-tab) + (define-key map (kbd "") 'haskell-interactive-mode-kill-whole-line) map) "Interactive Haskell mode map.") @@ -114,7 +148,6 @@ Key bindings: (haskell-interactive-mode-prompt)) - (defface haskell-interactive-face-prompt '((t :inherit 'font-lock-function-name-face)) "Face for the prompt." @@ -135,10 +168,22 @@ Key bindings: "Face for the result." :group 'haskell-interactive) +(defface haskell-interactive-face-garbage + '((t :inherit 'font-lock-string-face)) + "Face for trailing garbage after a command has completed." + :group 'haskell-interactive) + (defun haskell-interactive-mode-newline-indent () "Make newline and indent." (interactive) - (insert "\n" (make-string (length haskell-interactive-prompt) ? ))) + (newline) + (indent-according-to-mode)) + +(defun haskell-interactive-mode-kill-whole-line () + "Kill the whole REPL line." + (interactive) + (kill-region haskell-interactive-mode-prompt-start + (line-end-position))) ;;;###autoload (defun haskell-interactive-bring () @@ -164,62 +209,227 @@ Key bindings: (defun haskell-interactive-mode-return () "Handle the return key." (interactive) - (if (haskell-interactive-at-compile-message) - (next-error-internal) - (haskell-interactive-handle-line))) + (cond + ((haskell-interactive-at-compile-message) + (next-error-internal)) + (t + (haskell-interactive-handle-expr)))) (defun haskell-interactive-mode-space (n) "Handle the space key." (interactive "p") - (if (haskell-interactive-at-compile-message) - (next-error-no-select 0) - (self-insert-command n))) + (if (and (bound-and-true-p god-local-mode) + (fboundp 'god-mode-self-insert)) + (call-interactively 'god-mode-self-insert) + (if (haskell-interactive-at-compile-message) + (next-error-no-select 0) + (self-insert-command n)))) (defun haskell-interactive-at-prompt () "If at prompt, returns start position of user-input, otherwise returns nil." - (let ((current-point (point))) - (save-excursion (goto-char (point-max)) - (search-backward-regexp (haskell-interactive-prompt-regex)) - (when (> current-point (point)) - (+ (length haskell-interactive-prompt) (point)))))) + (if (>= (point) + haskell-interactive-mode-prompt-start) + haskell-interactive-mode-prompt-start + nil)) -(defun haskell-interactive-handle-line () +(defun haskell-interactive-handle-expr () + "Handle an inputted expression at the REPL." (when (haskell-interactive-at-prompt) - (let ((expr (haskell-interactive-mode-input)) - (session (haskell-session)) - (process (haskell-process))) - (when (not (string= "" (replace-regexp-in-string " " "" expr))) - (haskell-interactive-mode-history-add expr) - (goto-char (point-max)) - (haskell-process-queue-command - process - (make-haskell-command - :state (list session process expr 0) - :go (lambda (state) - (haskell-process-send-string (cadr state) - (caddr state))) - :live (lambda (state buffer) - (unless (and (string-prefix-p ":q" (caddr state)) - (string-prefix-p (caddr state) ":quit")) - (let* ((cursor (cadddr state)) - (next (replace-regexp-in-string - haskell-process-prompt-regex - "\n" - (substring buffer cursor)))) - (when (= 0 cursor) (insert "\n")) - (haskell-interactive-mode-eval-result (car state) next) - (setf (cdddr state) (list (length buffer))) - nil))) - :complete (lambda (state response) - (cond - (haskell-interactive-mode-eval-mode - (haskell-interactive-mode-eval-as-mode (car state) response)) - ((haskell-interactive-mode-line-is-query (elt state 2)) - (let ((haskell-interactive-mode-eval-mode 'haskell-mode)) - (haskell-interactive-mode-eval-as-mode (car state) response))) - (haskell-interactive-mode-eval-pretty - (haskell-interactive-mode-eval-pretty-result (car state) response))) - (haskell-interactive-mode-prompt (car state))))))))) + (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-process)) + (= (line-end-position) (point-max))) + (goto-char (point-max)) + (let ((process (haskell-process)) + (string (buffer-substring-no-properties + haskell-interactive-mode-result-end + (point)))) + (insert "\n") + (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-session)) + (process (haskell-process)) + (lines (length (split-string expr "\n")))) + (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 (caddr state))) + (haskell-process-set-evaluating (cadr state) t)) + :live (lambda (state buffer) + (unless (and (string-prefix-p ":q" (caddr state)) + (string-prefix-p (caddr state) ":quit")) + (let* ((cursor (cadddr state)) + (next (replace-regexp-in-string + haskell-process-prompt-regex + "" + (substring buffer cursor)))) + (haskell-interactive-mode-eval-result (car state) next) + (setf (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-trigger-compile-error (state response) + "Look for an compile error; if there is one, pop + that up in a buffer, similar to `debug-on-error'." + (when (and haskell-interactive-types-for-show-ambiguous + (string-match "^\n:[0-9]+:[0-9]+:" response) + (not (string-match "^\n:[0-9]+:[0-9]+:[\n ]+Warning:" response))) + (let ((inhibit-read-only t)) + (delete-region haskell-interactive-mode-prompt-start (point)) + (set-marker haskell-interactive-mode-prompt-start + haskell-interactive-mode-old-prompt-start) + (goto-char (point-max))) + (cond + ((and (not (haskell-interactive-mode-line-is-query (elt state 2))) + (or (string-match "No instance for (?Show[ \n]" response) + (string-match "Ambiguous type variable " response))) + (haskell-process-reset (haskell-process)) + (let ((resp (haskell-process-queue-sync-request + (haskell-process) + (concat ":t " + (buffer-substring-no-properties + haskell-interactive-mode-prompt-start + (point-max)))))) + (cond + ((not (string-match ":" resp)) + (haskell-interactive-mode-insert-error resp)) + (t (haskell-interactive-popup-error response))))) + (t (haskell-interactive-popup-error response) + t)) + t)) + +(defun haskell-interactive-popup-error (response) + "Popup an error." + (if haskell-interactive-popup-errors + (let ((buf (get-buffer-create "*HS-Error*"))) + (pop-to-buffer buf nil t) + (with-current-buffer buf + + (haskell-error-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (propertize response + 'face + 'haskell-interactive-face-compile-error)) + (goto-char (point-min)) + (delete-blank-lines) + (insert (propertize "-- Hit `q' to close this window.\n\n" + 'face 'font-lock-comment-face)) + (save-excursion + (goto-char (point-max)) + (insert (propertize "\n-- To disable popups, customize `haskell-interactive-popup-errors'.\n\n" + 'face 'font-lock-comment-face)))))) + (haskell-interactive-mode-insert-error response))) + +(defun haskell-interactive-mode-insert-error (response) + "Insert an error message." + (insert "\n" + (haskell-fontify-as-mode + response + 'haskell-mode)) + (haskell-interactive-mode-prompt)) + +(define-derived-mode haskell-error-mode + special-mode "Error" + "Major mode for viewing Haskell compile errors.") + +;; (define-key haskell-error-mode-map (kbd "q") 'quit-window) + +(defun haskell-interactive-mode-expr-result (state response) + "Print the result of evaluating the expression." + (let ((response (haskell-interactive-mode-cleanup-response + (caddr state) response))) + (cond + (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-line-is-query (elt state 2)) + (let ((haskell-interactive-mode-eval-mode 'haskell-mode)) + (haskell-interactive-mode-eval-as-mode (car state) response))))) + (haskell-interactive-mode-prompt (car state))) + +(defun haskell-interactive-mode-cleanup-response (expr response) + "Ignore the mess that GHCi outputs on multi-line input." + (if (not (string-match "\n" expr)) + response + (let ((i 0) + (out "") + (lines (length (split-string expr "\n")))) + (loop for part in (split-string response "| ") + do (setq out + (concat out + (if (> i lines) + (concat (if (or (= i 0) (= i (1+ lines))) "" "| ") part) + ""))) + do (setq i (1+ i))) + out))) + +(defun haskell-interactive-mode-multi-line (expr) + "If a multi-line expression has been entered, then reformat it to be: + +:{ +do the + multi-liner + expr +:} +" + (if (not (string-match "\n" expr)) + expr + (let* ((i 0) + (lines (split-string expr "\n")) + (len (length lines)) + (indent (make-string (length haskell-interactive-prompt) + ? ))) + (mapconcat 'identity + (loop for line in lines + collect (cond ((= i 0) + (concat ":{" "\n" line)) + ((= i (1- len)) + (concat (haskell-interactive-trim line) "\n" ":}")) + (t + (haskell-interactive-trim line))) + do (setq i (1+ i))) + "\n")))) + +(defun haskell-interactive-trim (line) + "Trim indentation off of lines in the REPL." + (if (and (string-match "^[ ]+" line) + (> (length line) + (length haskell-interactive-prompt))) + (substring line + (length haskell-interactive-prompt)) + line)) (defun haskell-interactive-mode-line-is-query (line) "Is LINE actually a :t/:k/:i?" @@ -256,8 +466,8 @@ Key bindings: (defun haskell-interactive-mode-beginning () "Go to the start of the line." (interactive) - (if (search-backward-regexp (haskell-interactive-prompt-regex) (line-beginning-position) t 1) - (search-forward-regexp (haskell-interactive-prompt-regex) (line-end-position) t 1) + (if (haskell-interactive-at-prompt) + (goto-char haskell-interactive-mode-prompt-start) (move-beginning-of-line nil))) (defun haskell-interactive-mode-clear () @@ -268,7 +478,7 @@ Key bindings: (let ((inhibit-read-only t)) (set-text-properties (point-min) (point-max) nil)) (delete-region (point-min) (point-max)) - (mapc 'delete-overlay (overlays-in (point-min) (point-max))) + (remove-overlays) (haskell-interactive-mode-prompt session) (haskell-session-set session 'next-error-region nil) (haskell-session-set session 'next-error-locus nil)))) @@ -282,13 +492,9 @@ Key bindings: (defun haskell-interactive-mode-input () "Get the interactive mode input." - (substring - (buffer-substring-no-properties - (save-excursion - (goto-char (point-max)) - (search-backward-regexp (haskell-interactive-prompt-regex))) - (line-end-position)) - (length haskell-interactive-prompt))) + (buffer-substring-no-properties + haskell-interactive-mode-prompt-start + (point-max))) (defun haskell-interactive-mode-prompt (&optional session) "Show a prompt at the end of the REPL buffer. @@ -303,7 +509,16 @@ SESSION, otherwise operate on the current buffer. 'face 'haskell-interactive-face-prompt 'read-only t 'rear-nonsticky t - 'prompt t)))) + 'prompt t)) + (let ((marker (set (make-local-variable 'haskell-interactive-mode-prompt-start) + (make-marker)))) + (set-marker marker + (point) + (current-buffer)) + (when nil + (let ((o (make-overlay (point) (point-max) nil nil t))) + (overlay-put o 'line-prefix (make-string (length haskell-interactive-prompt) + ? ))))))) (defun haskell-interactive-mode-eval-result (session text) "Insert the result of an eval as plain text." @@ -314,32 +529,24 @@ SESSION, otherwise operate on the current buffer. 'rear-nonsticky t 'read-only t 'prompt t - 'result t)))) + 'result t)) + (let ((marker (set (make-local-variable 'haskell-interactive-mode-result-end) + (make-marker)))) + (set-marker marker + (point) + (current-buffer))))) (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 ((start-point (save-excursion (search-backward-regexp (haskell-interactive-prompt-regex)) - (forward-line 1) - (point))) - (inhibit-read-only t)) - (delete-region start-point (point)) - (goto-char (point-max)) - (insert (haskell-fontify-as-mode (concat text "\n") - haskell-interactive-mode-eval-mode))))) - -(defun haskell-interactive-mode-eval-pretty-result (session text) - "Insert the result of an eval as a pretty printed Showable, if - parseable, or otherwise just as-is." - (with-current-buffer (haskell-session-interactive-buffer session) - (let ((start-point (save-excursion (search-backward-regexp (haskell-interactive-prompt-regex)) - (forward-line 1) - (point))) - (inhibit-read-only t)) - (delete-region start-point (point)) + (let ((inhibit-read-only t)) + (delete-region (1+ haskell-interactive-mode-prompt-start) (point)) (goto-char (point-max)) - (haskell-show-parse-and-insert text) - (insert "\n")))) + (let ((start (point))) + (insert (haskell-fontify-as-mode text + haskell-interactive-mode-eval-mode)) + (when haskell-interactive-mode-collapse + (haskell-collapse start (point))))))) ;;;###autoload (defun haskell-interactive-mode-echo (session message &optional mode) @@ -391,6 +598,16 @@ SESSION, otherwise operate on the current buffer. 'read-only t 'rear-nonsticky t))))))) +(defun haskell-interactive-mode-insert-garbage (session message) + "Echo a read only piece of text before the prompt." + (with-current-buffer (haskell-session-interactive-buffer session) + (save-excursion + (haskell-interactive-mode-goto-end-point) + (insert (propertize message + 'face 'haskell-interactive-face-garbage + 'read-only t + 'rear-nonsticky t))))) + (defun haskell-interactive-mode-insert (session message) "Echo a read only piece of text before the prompt." (with-current-buffer (haskell-session-interactive-buffer session) @@ -402,8 +619,8 @@ SESSION, otherwise operate on the current buffer. (defun haskell-interactive-mode-goto-end-point () "Go to the 'end' of the buffer (before the prompt.)" - (goto-char (point-max)) - (when (search-backward-regexp (haskell-interactive-prompt-regex) (point-min) t 1))) + (goto-char haskell-interactive-mode-prompt-start) + (goto-char (line-beginning-position))) (defun haskell-interactive-mode-history-add (input) "Add item to the history." @@ -448,24 +665,25 @@ SESSION, otherwise operate on the current buffer. (defun haskell-interactive-mode-set-prompt (p) "Set (and overwrite) the current prompt." (with-current-buffer (haskell-session-interactive-buffer (haskell-session)) - (goto-char (point-max)) - (goto-char (line-beginning-position)) - (search-forward-regexp (haskell-interactive-prompt-regex)) - (delete-region (point) (line-end-position)) + (goto-char haskell-interactive-mode-prompt-start) + (delete-region (point) (point-max)) (insert p))) (defun haskell-interactive-buffer () "Get the interactive buffer of the session." (haskell-session-interactive-buffer (haskell-session))) -(defun haskell-interactive-show-load-message (session type module-name file-name echo) +(defun haskell-interactive-show-load-message (session type module-name file-name echo th) "Show the '(Compiling|Loading) X' message." - (let ((msg (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))))) + (let ((msg (concat + (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)) @@ -603,11 +821,16 @@ FILE-NAME only." (with-current-buffer (haskell-session-interactive-buffer session) (save-excursion (goto-char (point-min)) + (when (search-forward-regexp "^Compilation failed.$" nil t 1) + (let ((inhibit-read-only t)) + (delete-region (line-beginning-position) + (1+ (line-end-position)))) + (goto-char (point-min))) (while (when (re-search-forward haskell-interactive-mode-error-regexp nil t) (let ((msg-file-name (match-string-no-properties 1)) (msg-startpos (line-beginning-position))) ;; skip over hanging continuation message lines - (while (progn (forward-line) (looking-at "^ "))) + (while (progn (forward-line) (looking-at "^[ ]+"))) (when (or (not file-name) (string= file-name msg-file-name)) (let ((inhibit-read-only t)) @@ -648,6 +871,210 @@ FILE-NAME only." (y-or-n-p "Kill the whole session?")) (haskell-session-kill t)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Presentation + +(defun haskell-interactive-mode-do-presentation (expr) + "Present the given expression. Requires the `present` package + to be installed. Will automatically import it qualified as Present." + (let ((p (haskell-process))) + ;; If Present.code isn't available, we probably need to run the + ;; setup. + (unless (string-match "^Present" (haskell-process-queue-sync-request p ":t Present.encode")) + (haskell-interactive-mode-setup-presentation p)) + ;; Happily, let statements don't affect the `it' binding in any + ;; way, so we can fake it, no pun intended. + (let ((error (haskell-process-queue-sync-request + p (concat "let it = Present.asData (" expr ")")))) + (if (not (string= "" error)) + (haskell-interactive-mode-eval-result (haskell-session) (concat error "\n")) + (let ((hash (haskell-interactive-mode-presentation-hash))) + (haskell-process-queue-sync-request + p (format "let %s = Present.asData (%s)" hash expr)) + (let* ((presentation (haskell-interactive-mode-present-id + hash + (list 0)))) + (insert "\n") + (haskell-interactive-mode-insert-presentation hash presentation) + (haskell-interactive-mode-eval-result (haskell-session) "\n")))) + (haskell-interactive-mode-prompt (haskell-session))))) + +(defvar haskell-interactive-mode-presentation-hash 0 + "Counter for the hash.") + +(defun haskell-interactive-mode-presentation-hash () + "Generate a presentation hash." + (format "_present_%s" + (setq haskell-interactive-mode-presentation-hash + (1+ haskell-interactive-mode-presentation-hash)))) + +(define-button-type 'haskell-presentation-slot-button + 'action 'haskell-presentation-present-slot + 'follow-link t + 'help-echo "Click to expand…") + +(defun haskell-presentation-present-slot (btn) + "The callback to evaluate the slot and present it in place of the button." + (let ((id (button-get btn 'presentation-id)) + (hash (button-get btn 'hash)) + (parent-rep (button-get btn 'parent-rep)) + (continuation (button-get btn 'continuation))) + (let ((point (point))) + (button-put btn 'invisible t) + (delete-region (button-start btn) (button-end btn)) + (haskell-interactive-mode-insert-presentation + hash + (haskell-interactive-mode-present-id hash id) + parent-rep + continuation) + (when (> (point) point) + (goto-char (1+ point)))))) + +(defun haskell-interactive-mode-presentation-slot (hash slot parent-rep &optional continuation) + "Make a slot at point, pointing to ID." + (let ((type (car slot)) + (id (cadr slot))) + (if (member (intern type) '(Integer Char Int Float Double)) + (haskell-interactive-mode-insert-presentation + hash + (haskell-interactive-mode-present-id hash id) + parent-rep + continuation) + (haskell-interactive-mode-presentation-slot-button slot parent-rep continuation hash)))) + +(defun haskell-interactive-mode-presentation-slot-button (slot parent-rep continuation hash) + (let ((start (point)) + (type (car slot)) + (id (cadr slot))) + (insert (propertize type 'face '(:height 0.8 :underline t :inherit 'font-lock-comment-face))) + (let ((button (make-text-button start (point) + :type 'haskell-presentation-slot-button))) + (button-put button 'hide-on-click t) + (button-put button 'presentation-id id) + (button-put button 'parent-rep parent-rep) + (button-put button 'continuation continuation) + (button-put button 'hash hash)))) + +(defun haskell-interactive-mode-insert-presentation (hash presentation &optional parent-rep continuation) + "Insert the presentation, hooking up buttons for each slot." + (let* ((rep (cadr (assoc 'rep presentation))) + (text (cadr (assoc 'text presentation))) + (type (cadr (assoc 'type presentation))) + (slots (cadr (assoc 'slots presentation))) + (nullary (null slots))) + (cond + ((string= "integer" rep) + (insert (propertize text 'face 'font-lock-constant))) + ((string= "floating" rep) + (insert (propertize text 'face 'font-lock-constant))) + ((string= "char" rep) + (insert (propertize + (if (string= "string" parent-rep) + (replace-regexp-in-string "^'\\(.+\\)'$" "\\1" text) + text) + 'face 'font-lock-string-face))) + ((string= "tuple" rep) + (insert "(") + (let ((first t)) + (loop for slot in slots + do (unless first (insert ",")) + do (haskell-interactive-mode-presentation-slot hash slot rep) + do (setq first nil))) + (insert ")")) + ((string= "list" rep) + (if (null slots) + (if continuation + (progn (delete-char -1) + (delete-indentation)) + (insert "[]")) + (let ((i 0)) + (unless continuation + (insert "[")) + (let ((start-column (current-column))) + (loop for slot in slots + do (haskell-interactive-mode-presentation-slot + hash + slot + rep + (= i (1- (length slots)))) + do (when (not (= i (1- (length slots)))) + (insert "\n") + (indent-to (1- start-column)) + (insert ",")) + do (setq i (1+ i)))) + (unless continuation + (insert "]"))))) + ((string= "string" rep) + (unless (string= "string" parent-rep) + (insert (propertize "\"" 'face 'font-lock-string-face))) + (loop for slot in slots + do (haskell-interactive-mode-presentation-slot hash slot rep)) + (unless (string= "string" parent-rep) + (insert (propertize "\"" 'face 'font-lock-string-face)))) + ((string= "alg" rep) + (when (and parent-rep + (not nullary) + (not (string= "list" parent-rep))) + (insert "(")) + (let ((start-column (current-column))) + (insert (propertize text 'face 'font-lock-type-face)) + (loop for slot in slots + do (insert "\n") + do (indent-to (+ 2 start-column)) + do (haskell-interactive-mode-presentation-slot hash slot rep))) + (when (and parent-rep + (not nullary) + (not (string= "list" parent-rep))) + (insert ")"))) + ((eq rep nil) + (insert (propertize "?" 'face 'font-lock-warning))) + (t + (let ((err "Unable to present! This very likely means Emacs +is out of sync with the `present' package. You should make sure +they're both up to date, or report a bug.")) + (insert err) + (error err)))))) + +(defun haskell-interactive-mode-present-id (hash id) + "Generate a presentation for the current expression at ID." + ;; See below for commentary of this statement. + (let ((p (haskell-process))) + (haskell-process-queue-without-filters + p "let _it = it") + (let* ((text (haskell-process-queue-sync-request + p + (format "Present.putStr (Present.encode (Present.fromJust (Present.present (Present.fromJust (Present.fromList [%s])) %s)))" + (mapconcat 'identity (mapcar 'number-to-string id) ",") + hash))) + (reply + (if (string-match "^*** " text) + '((rep nil)) + (read text)))) + ;; Not necessary, but nice to restore it to the expression that + ;; the user actually typed in. + (haskell-process-queue-without-filters + p "let it = _it") + reply))) + +(defun haskell-interactive-mode-setup-presentation (p) + "Setup the GHCi REPL for using presentations. + +Using asynchronous queued commands as opposed to sync at this +stage, as sync would freeze up the UI a bit, and we actually +don't care when the thing completes as long as it's soonish." + ;; Import dependencies under Present.* namespace + (haskell-process-queue-without-filters p "import qualified Data.Maybe as Present") + (haskell-process-queue-without-filters p "import qualified Data.ByteString.Lazy as Present") + (haskell-process-queue-without-filters p "import qualified Data.AttoLisp as Present") + (haskell-process-queue-without-filters p "import qualified Present.ID as Present") + (haskell-process-queue-without-filters p "import qualified Present as Present") + ;; Make a dummy expression to avoid "Loading package" nonsense + (haskell-process-queue-without-filters + p "Present.present (Present.fromJust (Present.fromList [0])) ()")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Misc + (add-hook 'kill-buffer-hook 'haskell-interactive-kill) (provide 'haskell-interactive-mode) diff --git a/haskell-mode.el b/haskell-mode.el index b65543d99b..c26a68045d 100644 --- a/haskell-mode.el +++ b/haskell-mode.el @@ -128,6 +128,8 @@ (require 'compile) (require 'flymake) (require 'outline) +(require 'haskell-complete-module) +(require 'haskell-compat) (require 'haskell-align-imports) (require 'haskell-sort-imports) (require 'haskell-string) @@ -135,11 +137,13 @@ ;; FIXME: code-smell: too many forward decls for haskell-session are required here (defvar haskell-session) +(declare-function haskell-process "haskell-process" ()) (declare-function haskell-process-do-try-info "haskell-process" (sym)) +(declare-function haskell-process-queue-sync-request (process reqstr)) (declare-function haskell-process-generate-tags "haskell-process" (&optional and-then-find-this-tag)) (declare-function haskell-session "haskell-session" ()) (declare-function haskell-session-all-modules "haskell-session" (&optional DONTCREATE)) -(declare-function haskell-session-cabal-dir "haskell-session" (session)) +(declare-function haskell-session-cabal-dir "haskell-session" (session &optional no-prompt)) (declare-function haskell-session-maybe "haskell-session" ()) (declare-function haskell-session-tags-filename "haskell-session" (session)) (declare-function haskell-session-current-dir "haskell-session" (session)) @@ -223,36 +227,25 @@ be set to the preferred literate style." ;;;###autoload (defvar haskell-mode-map (let ((map (make-sparse-keymap))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; For inferior haskell mode, use the below bindings - ;; (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 "\C-c\C-c" 'comment-region) - (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) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Editing-specific commands (define-key map (kbd "C-c C-.") 'haskell-mode-format-imports) (define-key map [remap delete-indentation] 'haskell-delete-indentation) - + (define-key map (kbd "C-c C-l") 'haskell-mode-enable-process-minor-mode) + (define-key map (kbd "C-c C-b") 'haskell-mode-enable-process-minor-mode) + (define-key map (kbd "C-c C-v") 'haskell-mode-enable-process-minor-mode) + (define-key map (kbd "C-c C-t") 'haskell-mode-enable-process-minor-mode) + (define-key map (kbd "C-c C-i") 'haskell-mode-enable-process-minor-mode) map) "Keymap used in Haskell mode.") +(defun haskell-mode-enable-process-minor-mode () + "Tell the user to choose a minor mode for process interaction." + (interactive) + (error "You tried to do an indentation command, but an interaction mode has not been enabled yet. + +Run M-x describe-variable haskell-mode-hook for a list of such modes.")) + (easy-menu-define haskell-mode-menu haskell-mode-map "Menu for the Haskell major mode." ;; Suggestions from Pupeno : @@ -263,8 +256,8 @@ be set to the preferred literate style." ["Indent region" indent-region mark-active] ["(Un)Comment region" comment-region mark-active] "---" - ["Start interpreter" switch-to-haskell] - ["Load file" inferior-haskell-load-file] + ["Start interpreter" haskell-process-switch] + ["Load file" haskell-process-load-file] "---" ["Load tidy core" ghc-core-create-core] "---" @@ -403,27 +396,47 @@ May return a qualified name." (defcustom haskell-mode-hook nil "Hook run after entering `haskell-mode'. -Some of the supported modules that can be activated via this hook: +You may be looking at this documentation because you haven't +configured indentation or process interaction. - `haskell-decl-scan', Graeme E Moss - Scans top-level declarations, and places them in a menu. +Indentation modes: - `haskell-doc', Hans-Wolfgang Loidl - Echoes types of functions or syntax of keywords when the cursor is idle. - - `haskell-indentation', Kristof Bastiaensen + `haskell-indentation-mode', Kristof Bastiaensen Intelligent semi-automatic indentation Mk2 - `haskell-indent', Guy Lapalme + `haskell-indent-mode', Guy Lapalme Intelligent semi-automatic indentation. - `haskell-simple-indent', Graeme E Moss and Heribert Schuetz + `haskell-simple-indent-mode', Graeme E Moss and Heribert Schuetz Simple indentation. -Module X is activated using the command `turn-on-X'. For example, -`haskell-doc' is activated using `turn-on-haskell-doc'. -For more information on a specific module, see the help for its `X-mode' -function. Some modules can be deactivated using `turn-off-X'. +Interaction modes: + + `interactive-haskell-mode' + Interact with per-project GHCi processes through a REPL and + directory-aware sessions. + + `inf-haskell-mode' + Interact with a GHCi process using comint-mode. Deprecated. + +Other modes: + + `haskell-decl-scan-mode', Graeme E Moss + Scans top-level declarations, and places them in a menu. + + `haskell-doc-mode', Hans-Wolfgang Loidl + Echoes types of functions or syntax of keywords when the cursor is idle. + +To activate a minor-mode, simply run the interactive command. For +example, `M-x haskell-doc-mode'. Run it again to disable it. + +To enable a mode for every haskell-mode buffer, add a hook in +your Emacs configuration. For example, to enable +haskell-indent-mode and interactive-haskell-mode, use the +following: + +(add-hook 'haskell-mode-hook 'haskell-indent-mode) +(add-hook 'haskell-mode-hook 'interactive-haskell-mode) See Info node `(haskell-mode)haskell-mode-hook' for more details. @@ -617,6 +630,45 @@ If nil, use the Hoogle web-site." ;;;###autoload (defalias 'hoogle 'haskell-hoogle) +(defvar hoogle-server-process-name "emacs-local-hoogle") +(defvar hoogle-server-buffer-name (format "*%s*" hoogle-server-process-name)) +(defvar hoogle-port-number 49513 "Port number.") + +(defun hoogle-start-server () + "Start hoogle local server." + (interactive) + (unless (hoogle-server-live-p) + (start-process + hoogle-server-process-name + (get-buffer-create hoogle-server-buffer-name) "/bin/sh" "-c" + (format "hoogle server -p %i" hoogle-port-number)))) + +(defun hoogle-server-live-p () + "Whether hoogle server is live or not." + (condition-case err + (process-live-p (get-buffer-create hoogle-server-buffer-name)) + (error nil))) + +(defun hoogle-kill-server () + "Kill hoogle server if it is live." + (interactive) + (when (hoogle-server-live-p) + (kill-process (get-buffer-create hoogle-server-buffer-name)))) + +;;;###autoload +(defun hoogle-lookup-from-local () + "Lookup by local hoogle." + (interactive) + (if (hoogle-server-live-p) + (browse-url (format "http://localhost:%i/?hoogle=%s" + hoogle-port-number + (read-string "hoogle: " (haskell-ident-at-point)))) + (when (y-or-n-p + "hoogle server not found, start hoogle server?") + (if (executable-find "hoogle") + (hoogle-start-server) + (error "hoogle is not installed"))))) + ;;;###autoload (defun haskell-hayoo (query) "Do a Hayoo search for QUERY." @@ -639,6 +691,15 @@ If nil, use the Hoogle web-site." (const "ghc -fno-code") (string :tag "Other command"))) +(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"))) + (defcustom haskell-stylish-on-save nil "Whether to run stylish-haskell on the buffer before saving." :group 'haskell @@ -685,8 +746,11 @@ To be added to `flymake-init-create-temp-buffer-copy'." (defun haskell-mode-suggest-indent-choice () "Ran when the user tries to indent in the buffer but no indentation mode has been selected. -Brings up the documentation for haskell-mode-hook." - (describe-variable 'haskell-mode-hook)) +Explains what has happened and suggests reading docs for `haskell-mode-hook'." + (interactive) + (error "You tried to do an interaction command, but an indentation mode has not been enabled yet. + +Run M-x describe-variable haskell-mode-hook for a list of such modes.")) (defun haskell-mode-format-imports () "Format the imports by aligning and sorting them." @@ -715,7 +779,7 @@ Brings up the documentation for haskell-mode-hook." (cond ((save-excursion (forward-word -1) (looking-at "^import$")) (insert " ") - (let ((module (ido-completing-read "Module: " (haskell-session-all-modules)))) + (let ((module (haskell-complete-module-read "Module: " (haskell-session-all-modules)))) (insert module) (haskell-mode-format-imports))) ((not (string= "" (save-excursion (forward-char -1) (haskell-ident-at-point)))) @@ -734,11 +798,10 @@ Brings up the documentation for haskell-mode-hook." (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)) - ) + (ignore-errors (haskell-mode-stylish-buffer)) + (let ((before-save-hook '()) + (after-save-hook '())) + (basic-save-buffer)))) (defun haskell-mode-buffer-apply-command (cmd) "Execute shell command CMD with current buffer as input and @@ -797,17 +860,119 @@ remains unchanged." (forward-line (1- line)) (goto-char (+ column (point))))) +(defun haskell-mode-jump-to-def-or-tag (&optional next-p) + "Jump to the definition (by consulting GHCi), or (fallback) +jump to the tag. + +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." + (interactive "P") + (let ((loc (haskell-mode-find-def (haskell-ident-at-point)))) + (if loc + (haskell-mode-handle-generic-loc loc) + (call-interactively 'haskell-mode-tag-find)))) + (defun haskell-mode-tag-find (&optional next-p) "The tag find function, specific for the particular session." (interactive "P") - (let ((tags-file-name (haskell-session-tags-filename (haskell-session))) - (tags-revert-without-query t) - (ident (haskell-ident-at-point))) + (cond + ((eq 'font-lock-string-face + (get-text-property (point) 'face)) + (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)))) + +(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 (not (string= "" (haskell-trim ident))) (cond ((file-exists-p tags-file-name) (find-tag ident next-p)) (t (haskell-process-generate-tags ident)))))) +(defun haskell-mode-jump-to-def (ident) + "Jump to definition of identifier 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 display a generic location. Either a file or +a library." + (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-jump-to-loc (loc) + "Jump to the given location. +LOC = (list FILE LINE COL)" + (find-file (elt loc 0)) + (goto-char (point-min)) + (forward-line (1- (elt loc 1))) + (goto-char (+ (line-beginning-position) + (1- (elt loc 2))))) + +(defun haskell-mode-find-def (ident) + "Find definition location of identifier. Uses the GHCi process +to find the location. + +Returns: + + (library ) + (file ) + (module ) +" + (let ((reply (haskell-process-queue-sync-request + (haskell-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-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)))))))))))))) + ;; From Bryan O'Sullivan's blog: ;; http://www.serpentine.com/blog/2007/10/09/using-emacs-to-insert-scc-annotations-in-haskell-code/ (defun haskell-mode-insert-scc-at-point () @@ -863,6 +1028,72 @@ given a prefix arg." (font-lock-fontify-buffer) (buffer-substring (point-min) (point-max)))) +(defun haskell-guess-module-name () + "Guess the current module name of the buffer." + (interactive) + (let ((components (loop for part + in (reverse (split-string (buffer-file-name) "/")) + while (let ((case-fold-search nil)) + (string-match "^[A-Z]+" part)) + collect (replace-regexp-in-string "\\.l?hs$" "" part)))) + (mapconcat 'identity (reverse components) "."))) + +(defun haskell-auto-insert-module-template () + "Insert a module template for the newly created buffer." + (interactive) + (when (and (= (point-min) + (point-max)) + (buffer-file-name)) + (insert + "-- | " + "\n" + "\n" + "module " + ) + (let ((name (haskell-guess-module-name))) + (if (string= name "") + (insert "") + (insert name))) + (insert " where" + "\n" + "\n") + (goto-char (point-min)) + (forward-char 4))) + +(defun haskell-describe (ident) + "Describe the given identifier." + (interactive (list (read-from-minibuffer "Describe identifier: "))) + (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 + (loop for result in results + do (insert (propertize ident '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)))) + (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))))))) + ;; Provide ourselves: diff --git a/haskell-navigate-imports.el b/haskell-navigate-imports.el index f84d72ac5d..5725422748 100644 --- a/haskell-navigate-imports.el +++ b/haskell-navigate-imports.el @@ -79,8 +79,10 @@ (if point (goto-char point) (progn (goto-char (point-min)) - (when (haskell-navigate-imports-find-forward-line) - (haskell-navigate-imports-go-internal))))))) + (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." diff --git a/haskell-presentation-mode.el b/haskell-presentation-mode.el index a322b3b93b..b43151d9b4 100644 --- a/haskell-presentation-mode.el +++ b/haskell-presentation-mode.el @@ -42,6 +42,8 @@ SESSION as the current haskell-session." (buffer (get-buffer-create name))) (with-current-buffer buffer (haskell-presentation-mode) + (if (boundp 'shm-display-quarantine) + (set (make-local-variable 'shm-display-quarantine) nil)) (let ((buffer-read-only nil)) (erase-buffer) (insert (propertize "-- Hit `q' to close this window.\n\n" diff --git a/haskell-process.el b/haskell-process.el index a49ca9390b..1314e0e04a 100644 --- a/haskell-process.el +++ b/haskell-process.el @@ -27,20 +27,24 @@ ;;; Code: +(require 'haskell-complete-module) (require 'haskell-mode) (require 'haskell-session) (require 'haskell-compat) (require 'haskell-str) (require 'haskell-utils) (require 'haskell-presentation-mode) +(require 'haskell-navigate-imports) (with-no-warnings (require 'cl)) ;; FIXME: haskell-process shouldn't depend on haskell-interactive-mode to avoid module-dep cycles (declare-function haskell-interactive-mode-echo "haskell-interactive-mode" (session message &optional mode)) (declare-function haskell-interactive-mode-compile-error "haskell-interactive-mode" (session message)) +(declare-function haskell-interactive-mode-compile-warning "haskell-interactive-mode" (session message)) (declare-function haskell-interactive-mode-insert "haskell-interactive-mode" (session message)) (declare-function haskell-interactive-mode-reset-error "haskell-interactive-mode" (session)) -(declare-function haskell-interactive-show-load-message "haskell-interactive-mode" (session type module-name file-name echo)) +(declare-function haskell-interactive-show-load-message "haskell-interactive-mode" (session type module-name file-name echo th)) +(declare-function haskell-interactive-mode-insert-garbage "haskell-interactive-mode" (session message)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Configuration @@ -110,6 +114,12 @@ See `haskell-process-do-cabal' for more details." :type 'boolean :group 'haskell-interactive) +(defcustom haskell-process-show-debug-tips + t + "Show debugging tips when starting the process." + :type 'boolean + :group 'haskell-interactive) + (defcustom haskell-notify-p nil "Notify using notifications.el (if loaded)?" @@ -122,6 +132,25 @@ See `haskell-process-do-cabal' for more details." :type 'boolean :group 'haskell-interactive) +(defcustom haskell-process-suggest-hoogle-imports + nil + "Suggest to add import statements using Hoogle as a backend." + :type 'boolean + :group 'haskell-interactive) + +(defcustom haskell-process-suggest-haskell-docs-imports + nil + "Suggest to add import statements using haskell-docs as a backend." + :type 'boolean + :group 'haskell-interactive) + +(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) + (defcustom haskell-process-suggest-language-pragmas t "Suggest adding LANGUAGE pragmas recommended by GHC." @@ -175,7 +204,13 @@ imports become available?" :type 'boolean :group 'haskell-interactive) -(defvar haskell-process-prompt-regex "\\(^[> ]*> $\\|\n[> ]*> $\\)") +(defcustom haskell-process-suggest-restart + t + "Suggest restarting the process when it has died" + :type 'boolean + :group 'haskell-interactive) + +(defvar haskell-process-prompt-regex "\4") (defvar haskell-reload-p nil) (defvar haskell-process-greetings @@ -190,6 +225,30 @@ imports become available?" (expand-file-name "logo.svg" haskell-mode-pkg-base-dir) "Haskell logo for notifications.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Accessing commands -- using cl 'defstruct' +(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) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Accessing commands + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Specialised commands @@ -260,7 +319,7 @@ possible, using GHCi's :type." (t (with-current-buffer (nth 2 state) (goto-char (line-beginning-position)) - (insert (format "%s\n" response)))))))))) + (insert (format "%s\n" (replace-regexp-in-string "\n$" "" response))))))))))) ;;;###autoload (defun haskell-process-do-info (&optional prompt-value) @@ -300,6 +359,24 @@ If PROMPT-VALUE is non-nil, request identifier via mini-buffer." (string-match "^" 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-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 "^" response)) + (haskell-mode-message-line response))))))) + (defun haskell-process-do-simple-echo (line &optional mode) "Send LINE to the GHCi process and echo the result in some fashion, such as printing in the minibuffer, or using @@ -406,12 +483,15 @@ for various things, but is optional." (haskell-process-add-cabal-autogen)) ;;;###autoload -(defun haskell-process-cabal () +(defun haskell-process-cabal (p) "Prompts for a Cabal command to run." - (interactive) - (haskell-process-do-cabal - (ido-completing-read "Cabal command: " - haskell-cabal-commands))) + (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: " + haskell-cabal-commands)))) (defun haskell-process-add-cabal-autogen () "Add /dist/build/autogen/ to the ghci search @@ -442,19 +522,22 @@ to be loaded by ghci." (haskell-session-cabal-dir (car state)) (format "%s %s" (ecase haskell-process-type - ('ghci "cabal") - ('cabal-repl "cabal") - ('cabal-ghci "cabal") - ('cabal-dev "cabal-dev")) + ('ghci haskell-process-path-cabal) + ('cabal-repl haskell-process-path-cabal) + ('cabal-ghci haskell-process-path-cabal) + ('cabal-dev haskell-process-path-cabal-dev)) (caddr state))))) :live (lambda (state buffer) - (cond ((or (string= (caddr state) "build") - (string= (caddr state) "install")) - (haskell-process-live-build (cadr state) buffer t)) - (t - (haskell-process-cabal-live state buffer)))) + (let ((cmd (replace-regexp-in-string "^\\([a-z]+\\).*" + "\\1" + (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) @@ -470,6 +553,11 @@ to be loaded by ghci." (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)) @@ -477,10 +565,10 @@ to be loaded by ghci." :title (format "*%s*" (haskell-session-name (car state))) :body msg :app-name (ecase haskell-process-type - ('ghci "cabal") - ('cabal-repl "cabal") - ('cabal-ghci "cabal") - ('cabal-dev "cabal-dev")) + ('ghci haskell-process-path-cabal) + ('cabal-repl haskell-process-path-cabal) + ('cabal-ghci haskell-process-path-cabal) + ('cabal-dev haskell-process-path-cabal-dev)) :app-icon haskell-process-logo ))))))))) @@ -495,7 +583,7 @@ to be loaded by ghci." (setf (cdddr state) (list (length buffer))) nil) -(defun haskell-process-load-complete (session process buffer reload module-buffer) +(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." @@ -512,7 +600,12 @@ actual Emacs buffer of the module being loaded." (haskell-process-reload-with-fbytecode process module-buffer) (haskell-process-import-modules process (car modules))) (haskell-mode-message-line - (if reload "Reloaded OK." "OK."))))) + (if reload "Reloaded OK." "OK.")) + (when cont + (condition-case e + (funcall cont t) + (error (message "%S" e)) + (quit nil)))))) ((haskell-process-consume process "Failed, modules loaded: \\(.+\\)\\.$") (let* ((modules (haskell-process-extract-modules buffer)) (cursor (haskell-process-response-cursor process))) @@ -522,7 +615,12 @@ actual Emacs buffer of the module being loaded." (if (and (not reload) haskell-process-reload-with-fbytecode) (haskell-process-reload-with-fbytecode process module-buffer) (haskell-process-import-modules process (car modules))) - (haskell-interactive-mode-compile-error session "Compilation failed."))))) + (haskell-interactive-mode-compile-error session "Compilation failed.") + (when cont + (condition-case e + (funcall cont nil) + (error (message "%S" e)) + (quit nil))))))) (defun haskell-process-reload-with-fbytecode (process module-buffer) "Reload FILE-NAME with -fbyte-code set, and then restore -fobject-code." @@ -576,15 +674,14 @@ from `module-buffer'." (concat "\\[[ ]*\\([0-9]+\\) of \\([0-9]+\\)\\]" " Compiling \\([^ ]+\\)[ ]+" "( \\([^ ]+\\), \\([^ ]+\\) )[^\r\n]*[\r\n]+")) - (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)) + (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 @@ -610,9 +707,44 @@ from `module-buffer'." msg) (haskell-mode-message-line msg))))) +(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-errors-warnings (session process buffer) "Trigger handling type errors or warnings." (cond + ((haskell-process-consume + process + "\\(Module imports form a cycle:[ \n]+module [^ ]+ ([^)]+)[[:unibyte:][:nonascii:]]+?\\)\nFailed") + (let ((err (match-string 1 buffer))) + (when (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))) + (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))))) + t) ((haskell-process-consume process (concat "[\r\n]\\([^ \r\n:][^:\n\r]+\\):\\([0-9]+\\):\\([0-9]+\\)\\(-[0-9]+\\)?:" @@ -642,10 +774,13 @@ from `module-buffer'." (defun haskell-process-trigger-suggestions (session msg file line) "Trigger prompting to add any extension suggestions." - (cond ((let ((case-fold-search nil)) (string-match " -X\\([A-Z][A-Za-z]+\\)" msg)) + (cond ((let ((case-fold-search nil)) + (or (string-match " -X\\([A-Z][A-Za-z]+\\)" msg) + (string-match "Use \\([A-Z][A-Za-z]+\\) to permit this" msg) + (string-match "use \\([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) + ((string-match " The \\(qualified \\)?import of[ ][‘`‛]\\([^ ]+\\)['’] is redundant" msg) (when haskell-process-suggest-remove-import-lines (haskell-process-suggest-remove-import session file @@ -654,19 +789,192 @@ from `module-buffer'." ((string-match "Warning: orphan instance: " msg) (when haskell-process-suggest-no-warn-orphans (haskell-process-suggest-pragma session "OPTIONS" "-fno-warn-orphans" file))) - ((string-match "against inferred type `\\[Char\\]'" msg) + ((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))))) + (haskell-process-suggest-pragma session "LANGUAGE" "OverloadedStrings" file))) + ((string-match "^Not in scope: .*[‘`‛]\\(.+\\)['’]$" msg) + (when haskell-process-suggest-hoogle-imports + (haskell-process-suggest-hoogle-imports session msg file)) + (when haskell-process-suggest-haskell-docs-imports + (haskell-process-suggest-haskell-docs-imports session msg file))) + ((string-match "^[ ]+It is a member of the hidden package [‘`‛]\\(.+\\)['’].$" msg) + (when haskell-process-suggest-add-package + (haskell-process-suggest-add-package session msg))))) + +(defun haskell-process-suggest-add-package (session msg) + "Add the (matched) module to your cabal file." + (let* ((suggested-package (match-string 1 msg)) + (package-name (replace-regexp-in-string "-[^-]+$" "" suggested-package)) + (version (progn (string-match "\\([^-]+\\)$" suggested-package) + (match-string 1 suggested-package))) + (cabal-file (concat (haskell-session-name session) + ".cabal"))) + (when (y-or-n-p + (format "Add `%s' to %s?" + package-name + cabal-file)) + (haskell-process-add-dependency package-name version)))) + +(defun haskell-process-add-dependency (package &optional version no-prompt) + "Add PACKAGE (and optionally suffix -VERSION) to the cabal +file. Prompts the user before doing so." + (interactive + (list (read-from-minibuffer "Package entry: ") + nil + t)) + (let ((buffer (current-buffer))) + (find-file (haskell-cabal-find-file)) + (let ((entry (if no-prompt + package + (read-from-minibuffer "Package entry: " + (concat package + (if version + (concat " >= " + version) + "")))))) + (save-excursion + (goto-char (point-min)) + (when (search-forward-regexp "^library$" nil t 1) + (search-forward-regexp "build-depends:[ ]+") + (let ((column (current-column))) + (when (y-or-n-p "Add to library?") + (insert entry ",\n") + (indent-to column)))) + (goto-char (point-min)) + (while (search-forward-regexp "^executable " nil t 1) + (let ((name (buffer-substring-no-properties (point) (line-end-position)))) + (search-forward-regexp "build-depends:[ ]+") + (let ((column (current-column))) + (when (y-or-n-p (format "Add to executable `%s'?" name)) + (insert entry ",\n") + (indent-to column))))) + (save-buffer) + (switch-to-buffer buffer))))) + +(defun haskell-process-suggest-hoogle-imports (session msg file) + "Given an out of scope identifier, Hoogle for that identifier, +and if a result comes back, suggest to import that identifier +now." + (let* ((process (haskell-session-process session)) + (suggested-already (haskell-process-suggested-imports process)) + (ident (let ((i (match-string 1 msg))) + ;; Skip qualification. + (if (string-match "^[A-Za-z0-9_'.]+\\.\\(.+\\)$" i) + (match-string 1 i) + i))) + (modules (haskell-process-hoogle-ident ident)) + (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) + (save-excursion + (goto-char (point-max)) + (haskell-navigate-imports) + (insert (read-from-minibuffer "Import line: " (concat "import " module)) + "\n") + (haskell-sort-imports) + (haskell-align-imports))))) + +(defun haskell-process-suggest-haskell-docs-imports (session msg file) + "Given an out of scope identifier, haskell-docs search for that identifier, +and if a result comes back, suggest to import that identifier +now." + (let* ((process (haskell-session-process session)) + (suggested-already (haskell-process-suggested-imports process)) + (ident (let ((i (match-string 1 msg))) + ;; Skip qualification. + (if (string-match "^[A-Za-z0-9_'.]+\\.\\(.+\\)$" i) + (match-string 1 i) + i))) + (modules (haskell-process-haskell-docs-ident ident)) + (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) + (save-excursion + (goto-char (point-max)) + (haskell-navigate-imports) + (insert (read-from-minibuffer "Import line: " (concat "import " module)) + "\n") + (haskell-sort-imports) + (haskell-align-imports))))) + +(defun haskell-process-haskell-docs-ident (ident) + "Search with haskell-docs for IDENT, returns a list of modules." + (remove-if (lambda (a) (string= "" a)) + (split-string (shell-command-to-string (concat "haskell-docs --modules " ident)) + "\n"))) + +(defun haskell-process-hoogle-ident (ident) + "Hoogle for IDENT, returns 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)) + (remove-if (lambda (a) (string= "" a)) + (split-string (buffer-string) + "\n")))))) (defun haskell-process-suggest-remove-import (session file import line) - (when (y-or-n-p (format "The import line `%s' is redundant. Remove? " import)) - (haskell-process-find-file session file) - (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (line-beginning-position)) - (delete-region (line-beginning-position) - (line-end-position))))) + "Suggest removing or commenting out IMPORT on LINE." + (let ((continue t) + (first t)) + (while continue + (setq continue nil) + (case (read-key (propertize (format "%sThe import line `%s' is redundant. Remove? (y, n, c: comment out) " + (if (not first) + "Please answer n, y or c: " + "") + import) + 'face 'minibuffer-prompt)) + (?y + (haskell-process-find-file session file) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (line-beginning-position)) + (delete-region (line-beginning-position) + (line-end-position)))) + (?n + (message "Ignoring redundant import %s" import)) + (?c + (haskell-process-find-file session file) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (line-beginning-position)) + (insert "-- "))) + (t (setq first nil) + (setq continue t)))))) (defun haskell-process-suggest-pragma (session pragma extension file) "Suggest to add something to the top of the file." @@ -725,7 +1033,9 @@ from `module-buffer'." (append (list (haskell-session-name session) nil haskell-process-path-cabal) - '("repl") haskell-process-args-cabal-repl))) + '("repl") haskell-process-args-cabal-repl + (let ((target (haskell-session-target session))) + (if target (list target) nil))))) ('cabal-ghci (haskell-process-log (format "Starting inferior cabal-ghci process using %s ..." haskell-process-path-cabal-ghci)) @@ -849,16 +1159,37 @@ from `module-buffer'." :state process :go (lambda (process) - (haskell-process-send-string process ":set prompt \"> \"") + (haskell-process-send-string process ":set prompt \"\\4\"") (haskell-process-send-string process "Prelude.putStrLn \"\"") (haskell-process-send-string process ":set -v1")) + :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) + (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) - " (if I break, run M-x haskell-process-restart; config via M-x customize-mode)")))))) + (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-process-sentinel (proc event) "The sentinel for the process pipe." @@ -875,10 +1206,13 @@ from `module-buffer'." (haskell-process-log (format "<- %S\n" response)) (let ((session (haskell-process-project-by-proc proc))) (when session - (when (haskell-process-cmd (haskell-session-process session)) - (haskell-process-collect session - response - (haskell-session-process session)))))) + (if (haskell-process-cmd (haskell-session-process session)) + (haskell-process-collect session + response + (haskell-session-process session)) + (haskell-interactive-mode-insert-garbage + session + (replace-regexp-in-string "\4" "" response)))))) (defun haskell-process-log (msg) "Write MSG to the process log (if enabled)." @@ -936,9 +1270,13 @@ from `module-buffer'." (defun haskell-process-prompt-restart (process) "Prompt to restart the died process." - (when (y-or-n-p (format "The Haskell process `%s' has died. Restart? " - (haskell-process-name process))) - (haskell-process-start (haskell-process-session process)))) + (let ((process-name (haskell-process-name process))) + (if haskell-process-suggest-restart + (when (y-or-n-p (format "The Haskell process `%s' has died. Restart? " + process-name)) + (haskell-process-start (haskell-process-session process))) + (message (format "The Haskell process `%s' is dearly departed." + process-name))))) (defun haskell-process-live-updates (process) "Process live updates." @@ -1006,7 +1344,7 @@ This uses `accept-process-output' internally." (rawstr (haskell-process-queue-sync-request process reqstr))) (if (string-prefix-p "unknown command " rawstr) (error "GHCi lacks `:complete' support") - (let* ((s1 (split-string rawstr "\r?\n")) + (let* ((s1 (split-string rawstr "\r?\n" t)) (cs (mapcar #'haskell-str-literal-decode (cdr s1))) (h0 (car s1))) ;; " " (unless (string-match "\\`\\([0-9]+\\) \\([0-9]+\\) \\(\".*\"\\)\\'" h0) @@ -1039,6 +1377,31 @@ Returns newly set VALUE." ;; 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)) @@ -1058,6 +1421,9 @@ Return nil if no 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) @@ -1113,27 +1479,96 @@ Returns nil if queue is empty." (haskell-process-set process 'command-queue (cdr queue)) (car queue)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Accessing commands -- using cl 'defstruct' -(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) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Accessing commands +(defun haskell-process-unignore () + "Unignore any files that were specified as being ignored by the + inferior GHCi process." + (interactive) + (let ((session (haskell-session)) + (changed nil)) + (if (null (haskell-session-get session + 'ignored-files)) + (message "Nothing to unignore!") + (loop for file in (haskell-session-get session + 'ignored-files) + do (case (read-key + (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) + (return)))) + (when (and changed + (y-or-n-p "Restart GHCi process now? ")) + (haskell-process-restart))))) + +(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 (get-buffer "DevelMain.hs") + (let ((session (haskell-session))) + (let ((process (haskell-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-process) + "DevelMain.update") + (message "DevelMain updated."))))))))))) + +(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 + (haskell-session) + 'ignored-files + (lambda (files) + (remove-if (lambda (path) + (string= path file)) + files)))) (defun haskell-command-exec-go (command) "Call the command's go function." @@ -1145,9 +1580,12 @@ Returns nil if queue is empty." "Call the command's complete function." (let ((comp-func (haskell-command-complete command))) (when comp-func - (funcall comp-func - (haskell-command-state command) - response)))) + (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." @@ -1157,6 +1595,51 @@ Returns nil if queue is empty." (haskell-command-state command) response)))) +(defun haskell-process-cabal-macros () + "Send the cabal macros string." + (interactive) + (haskell-process-queue-without-filters (haskell-process) + ":set -optP-include -optPdist/build/autogen/cabal_macros.h")) + +(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"))) + +(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") 'haskell-process-cabal) + (define-key map [?\C-c ?\C-b] 'haskell-interactive-switch) + (define-key map [?\C-c ?\C-z] 'haskell-interactive-switch) + 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) + (provide 'haskell-process) ;; Local Variables: diff --git a/haskell-session.el b/haskell-session.el index cbc3848bde..709cc2f641 100644 --- a/haskell-session.el +++ b/haskell-session.el @@ -29,6 +29,7 @@ (require 'haskell-cabal) (require 'haskell-string) +(require 'haskell-mode) (with-no-warnings (require 'cl)) (declare-function haskell-interactive-mode "haskell-interactive-mode" ()) @@ -157,25 +158,30 @@ If DONTCREATE is non-nil don't create a new session." (defun haskell-session-new-assume-from-cabal () "Prompt to create a new project based on a guess from the nearest Cabal file." - (when (y-or-n-p (format "Start a new project named “%s”? " - (haskell-session-default-name))) - (haskell-session-make (haskell-session-default-name)))) + (let ((name (haskell-session-default-name))) + (unless (haskell-session-lookup name) + (when (y-or-n-p (format "Start a new project named “%s”? " + name)) + (haskell-session-make name))))) (defun haskell-session-from-buffer () "Get the session based on the buffer." (when (and (buffer-file-name) (consp haskell-sessions)) (reduce (lambda (acc a) - (if (haskell-is-prefix-of (haskell-session-cabal-dir a) - (file-name-directory (buffer-file-name))) - (if acc - (if (and - (> (length (haskell-session-cabal-dir a)) - (length (haskell-session-cabal-dir acc)))) - a - acc) - a) - acc)) + (let ((dir (haskell-session-cabal-dir a t))) + (if dir + (if (haskell-is-prefix-of dir + (file-name-directory (buffer-file-name))) + (if acc + (if (and + (> (length (haskell-session-cabal-dir a t)) + (length (haskell-session-cabal-dir acc t)))) + a + acc) + a) + acc) + acc))) haskell-sessions :initial-value nil))) @@ -183,7 +189,11 @@ If DONTCREATE is non-nil don't create a new session." "Make a new session." (let ((name (read-from-minibuffer "Project name: " (haskell-session-default-name)))) (when (not (string= name "")) - (haskell-session-make 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)))))) (defun haskell-session-default-name () "Generate a default project name for the new project prompt." @@ -200,9 +210,13 @@ If DONTCREATE is non-nil don't create a new session." (defun haskell-session-choose () "Find a session by choosing from a list of the current sessions." (when haskell-sessions - (let* ((session-name (ido-completing-read - "Choose Haskell session: " - (mapcar 'haskell-session-name haskell-sessions))) + (let* ((session-name (funcall haskell-completing-read-function + "Choose Haskell session: " + (remove-if (lambda (name) + (and haskell-session + (string= (haskell-session-name haskell-session) + name))) + (mapcar 'haskell-session-name haskell-sessions)))) (session (find-if (lambda (session) (string= (haskell-session-name session) session-name)) @@ -216,11 +230,21 @@ If DONTCREATE is non-nil don't create a new session." (defun haskell-session-change () "Change the session for the current buffer." (interactive) - (haskell-session-clear) (haskell-session-assign (or (haskell-session-new-assume-from-cabal) (haskell-session-choose) (haskell-session-new)))) +(defun haskell-session-change-target (target) + "Set the build target for cabal repl" + (interactive "sNew build target:") + (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))))) + (defun haskell-session-strip-dir (session file) "Strip the load dir from the file path." (let ((cur-dir (haskell-session-current-dir session))) @@ -234,11 +258,19 @@ If DONTCREATE is non-nil don't create a new session." file) file))) +(defun haskell-session-lookup (name) + "Get the session by name." + (remove-if-not (lambda (s) + (string= name (haskell-session-name s))) + haskell-sessions)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Building the session (defun haskell-session-make (name) "Make a Haskell session." + (when (haskell-session-lookup name) + (error "Session of name %s already exists!" name)) (let ((session (set (make-local-variable 'haskell-session) (list (cons 'name name))))) (add-to-list 'haskell-sessions session) @@ -252,6 +284,19 @@ If DONTCREATE is non-nil don't create a new session." "Get the session name." (haskell-session-get s 'name)) +(defun haskell-session-target (s) + "Get the session build target." + (let* ((maybe-target (haskell-session-get s 'target)) + (target (if maybe-target maybe-target + (let ((new-target + (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-interactive-buffer (s) "Get the session interactive buffer." (let ((buffer (haskell-session-get s 'interactive-buffer))) @@ -300,16 +345,25 @@ If DONTCREATE is non-nil don't create a new session." (or dir (haskell-process-cd t)))) -(defun haskell-session-cabal-dir (s) +(defun haskell-session-cabal-dir (s &optional no-prompt) "Get the session cabal-dir." (let ((dir (haskell-session-get s 'cabal-dir))) (if dir dir - (let ((set-dir (haskell-cabal-get-dir))) - (if set-dir - (progn (haskell-session-set-cabal-dir s set-dir) - set-dir) - (haskell-session-cabal-dir s)))))) + (unless no-prompt + (let ((set-dir (haskell-cabal-get-dir))) + (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. diff --git a/haskell-sort-imports.el b/haskell-sort-imports.el index f9bd13749a..d167cba452 100644 --- a/haskell-sort-imports.el +++ b/haskell-sort-imports.el @@ -31,62 +31,95 @@ ;;; Code: (defvar haskell-sort-imports-regexp - (concat "^\\(import[ ]+\\)" + (concat "^import[ ]+" "\\(qualified \\)?" "[ ]*\\(\"[^\"]*\" \\)?" "[ ]*\\([A-Za-z0-9_.']*.*\\)")) ;;;###autoload (defun haskell-sort-imports () - "Sort the import list at the point." (interactive) - (when (haskell-sort-imports-line-match) - (let ((current-line (buffer-substring-no-properties - (line-beginning-position) - (line-end-position))) - (col (current-column))) - (if (use-region-p) - (haskell-sort-imports-sort-imports-at (region-beginning) - (region-end) - t - current-line - col) - (haskell-sort-imports-sort-imports-at - (save-excursion (haskell-sort-imports-goto-modules-start/end - 'previous-line) - (point)) - (save-excursion (haskell-sort-imports-goto-modules-start/end - 'next-line) - (point)) - nil - current-line - col))))) - -(defun haskell-sort-imports-sort-imports-at (begin end region current-line col) + "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." + (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))) + (delete-region start (point)) + (mapc (lambda (import) + (insert import "\n")) + (sort imports (lambda (a b) + (string< (haskell-sort-imports-normalize a) + (haskell-sort-imports-normalize b))))) + (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)))) + 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 - (sort-regexp-fields nil - haskell-sort-imports-regexp - "\\4" - begin end)) - (when (not region) - (let ((line (save-excursion (goto-char end) - (search-backward current-line)))) - (goto-char (+ line col))))) - -(defun haskell-sort-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-sort-imports-goto-modules-start/end (direction) - "Skip a bunch of consequtive import lines up/down." - (while (not (or (equal (point) - (point-max)) - (not (haskell-sort-imports-line-match)))) - (funcall direction))) + (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) diff --git a/inf-haskell.el b/inf-haskell.el index 5675863ab4..8c9217431b 100644 --- a/inf-haskell.el +++ b/inf-haskell.el @@ -119,7 +119,7 @@ This will either look for a Cabal file or a \"module\" statement in the file." :group 'inferior-haskell (set (make-local-variable 'comint-prompt-regexp) ;; Whay the backslash in [\\._[:alnum:]]? - "^\\*?[[:upper:]][\\._[:alnum:]]*\\(?: \\*?[[:upper:]][\\._[: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) @@ -734,7 +734,8 @@ so that it can be obtained more quickly next time.") (defvar inferior-haskell-ghc-internal-ident-alist ;; FIXME: Fill this table, ideally semi-automatically. '(("GHC.Base.return" . "Control.Monad.return") - ("GHC.List" . "Data.List"))) + ("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." @@ -771,9 +772,12 @@ we load it." (format "Find documentation of (default %s): " sym) "Find documentation of: ") nil nil sym)))) - (setq sym (inferior-haskell-map-internal-ghc-ident 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")) @@ -781,13 +785,42 @@ we load it." (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 - ;; Jump to the symbol anchor within Haddock. - "#v:" sym) + (concat inferior-haskell-web-docs-base package "/" file-name) (and (file-exists-p local-path) - (concat "file://" 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) ;; Local Variables: diff --git a/snippets/haskell-mode/import.qualified b/snippets/haskell-mode/import.qualified index 776d87e913..a8f728ffa5 100644 --- a/snippets/haskell-mode/import.qualified +++ b/snippets/haskell-mode/import.qualified @@ -5,5 +5,5 @@ # contributor: Luke Hoersten # -- import qualified ${1:Module} as ${2:${1:$(let ((name (car (last (split-string yas-text "\\\."))))) - (if (not (nil-blank-string name)) "" + (if (= 0 (length name)) "" (subseq name 0 1)))}}$0 \ No newline at end of file diff --git a/tests/haskell-sort-imports-tests.el b/tests/haskell-sort-imports-tests.el new file mode 100644 index 0000000000..771fb61cb9 --- /dev/null +++ b/tests/haskell-sort-imports-tests.el @@ -0,0 +1,132 @@ +;;; haskell-sort-imports-tests.el --- Unit tests for haskell-sort-imports + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'haskell-sort-imports) + +(ert-deftest empty-buffer () + (should (with-temp-buffer + (haskell-sort-imports) + t))) + +(ert-deftest single-line () + (should (with-temp-buffer + (insert "import A\n") + (goto-char (point-min)) + (haskell-sort-imports) + (string= (buffer-string) + "import A\n")))) + +(ert-deftest two-idem () + (should (with-temp-buffer + (insert "import A +import B +") + (goto-char (point-min)) + (haskell-sort-imports) + (string= (buffer-string) + "import A +import B +"))) + (should (with-temp-buffer + (insert "import qualified A +import B +") + (goto-char (point-min)) + (haskell-sort-imports) + (string= (buffer-string) + "import qualified A +import B +"))) + (should (with-temp-buffer + (insert "import qualified \"mtl\" A +import B +") + (goto-char (point-min)) + (haskell-sort-imports) + (string= (buffer-string) + "import qualified \"mtl\" A +import B +")))) + +(ert-deftest two-rev () + (should (with-temp-buffer + (insert "import B +import A +") + (goto-char (point-min)) + (haskell-sort-imports) + (string= (buffer-string) + "import A +import B +")))) + +(ert-deftest file-structure () + (should (with-temp-buffer + (insert "module A where +import B +import A +") + (goto-char (point-min)) + (forward-line) + (haskell-sort-imports) + (string= (buffer-string) + "module A where +import A +import B +"))) + (should (with-temp-buffer + (insert "module C where + +import B +import A +") + (goto-char (point-min)) + (forward-line 2) + (haskell-sort-imports) + (string= (buffer-string) + "module C where + +import A +import B +")))) + +(ert-deftest bos-270 () + (should (with-temp-buffer + (insert "import Data.Aeson.Encode (encode) +import Data.Aeson.Types +import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, + eitherDecodeWith, eitherDecodeStrictWith, + jsonEOF, json, jsonEOF', json') +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +") + (goto-char (point-min)) + (haskell-sort-imports) + (string= (buffer-string) + "import Data.Aeson.Encode (encode) +import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, + eitherDecodeWith, eitherDecodeStrictWith, + jsonEOF, json, jsonEOF', json') +import Data.Aeson.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +")))) + +(provide 'haskell-sort-imports-tests) diff --git a/w3m-haddock.el b/w3m-haddock.el new file mode 100644 index 0000000000..615ff02dff --- /dev/null +++ b/w3m-haddock.el @@ -0,0 +1,183 @@ +;;; w3m-haddock.el --- Make browsing haddocks with w3m-mode better. + +;; Copyright (C) 2014 Chris Done + +;; Author: Chris Done + +;; 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. + +(require 'cl) +(declare-function w3m-buffer-title "w3m") +(declare-function w3m-browse-url "w3m") +(defvar w3m-current-url) + + +(add-hook 'w3m-display-hook 'w3m-haddock-display) + +(defface w3m-haddock-heading-face + '((((class color)) :background "#eeeeee")) + "Face for quarantines." + :group 'shm) + +(defcustom haskell-w3m-haddock-dirs + '("~/.cabal/share/doc/") + "The path to your cabal documentation dir. It should contain +directories of package-name-x.x. + +You can rebind this if you're using hsenv by adding it to your +.dir-locals.el in your project root. E.g. + + ((haskell-mode . ((haskell-w3m-haddock-dirs . (\"/home/chris/Projects/foobar/.hsenv/cabal/share/doc\"))))) + +" + :group 'shm + :type 'list) + +(defvar w3m-haddock-entry-regex "^\\(\\(data\\|type\\) \\|[a-z].* :: \\)" + "Regex to match entry headings.") + +(defun haskell-w3m-open-haddock () + "Open a haddock page in w3m." + (interactive) + (let* ((entries (remove-if (lambda (s) (string= s "")) + (apply 'append (mapcar (lambda (dir) + (split-string (shell-command-to-string (concat "ls -1 " dir)) + + "\n")) + haskell-w3m-haddock-dirs)))) + (package-dir (ido-completing-read + "Package: " + entries))) + (cond + ((member package-dir entries) + (loop for dir in haskell-w3m-haddock-dirs + when (w3m-haddock-find-index dir package-dir) + do (progn (w3m-browse-url (w3m-haddock-find-index dir package-dir) + t) + (return)))) + (t + (w3m-browse-url (concat "http://hackage.haskell.org/package/" + package-dir) + t))))) + +(defun w3m-haddock-find-index (dir package) + (let ((html-index (concat dir "/" package "/html/index.html")) + (index (concat dir "/" package "/index.html"))) + (cond + ((file-exists-p html-index) + html-index) + ((file-exists-p index) + index)))) + +(defun w3m-haddock-page-p () + "Haddock general page?" + (save-excursion + (goto-char (point-max)) + (forward-line -2) + (looking-at "[ ]*Produced by Haddock"))) + +(defun w3m-haddock-source-p () + "Haddock source page?" + (save-excursion + (goto-char (point-min)) + (or (looking-at "Location: https?://hackage.haskell.org/package/.*/docs/src/") + (looking-at "Location: file://.*cabal/share/doc/.*/html/src/") + (looking-at "Location: .*src/.*.html$")))) + +(defun w3m-haddock-p () + "Any haddock page?" + (or (w3m-haddock-page-p) + (w3m-haddock-source-p))) + +(defun w3m-haddock-find-tag () + "Find a tag by jumping to the \"All\" index and doing a + search-forward." + (interactive) + (when (w3m-haddock-p) + (let ((ident (haskell-ident-at-point))) + (when ident + (w3m-browse-url + (replace-regexp-in-string "docs/.*" "docs/doc-index-All.html" w3m-current-url)) + (search-forward ident))))) + +(defun w3m-haddock-display (url) + "To be ran by w3m's display hook. This takes a normal w3m + buffer containing hadddock documentation and reformats it to be + more usable and look like a dedicated documentation page." + (when (w3m-haddock-page-p) + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (delete-region (point) + (line-end-position)) + (w3m-haddock-next-heading) + ;; Start formatting entries + (while (looking-at w3m-haddock-entry-regex) + (when (w3m-haddock-valid-heading) + (w3m-haddock-format-heading)) + (w3m-haddock-next-heading)))) + (rename-buffer (concat "*haddock: " (w3m-buffer-title (current-buffer)) "*"))) + (when (w3m-haddock-source-p) + (font-lock-mode -1) + (let ((n (line-number-at-pos))) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (let ((text (buffer-substring (point) + (point-max))) + (inhibit-read-only t)) + (delete-region (point) + (point-max)) + (insert + (haskell-fontify-as-mode text + 'haskell-mode)))) + (goto-char (point-min)) + (forward-line (1- n))))) + +(defun w3m-haddock-format-heading () + "Format a haddock entry." + (let ((o (make-overlay (line-beginning-position) + (1- (save-excursion (w3m-haddock-header-end)))))) + (overlay-put o 'face 'w3m-haddock-heading-face)) + (let ((end (save-excursion + (w3m-haddock-next-heading) + (when (w3m-haddock-valid-heading) + (point))))) + (when end + (save-excursion + (w3m-haddock-header-end) + (indent-rigidly (point) + end + 4))))) + +(defun w3m-haddock-next-heading () + "Go to the next heading, or end of the buffer." + (forward-line 1) + (or (search-forward-regexp w3m-haddock-entry-regex nil t 1) + (goto-char (point-max))) + (goto-char (line-beginning-position))) + +(defun w3m-haddock-valid-heading () + "Is this a valid heading?" + (not (get-text-property (point) 'face))) + +(defun w3m-haddock-header-end () + "Go to the end of the header." + (search-forward-regexp "\n[ \n]")) + +(provide 'w3m-haddock)