summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAnthonyCowley <>2017-08-12 17:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-08-12 17:31:00 (GMT)
commit6251705d006f1314ca2e2eab9246c45f718e1afe (patch)
treeaf3644f03e940b0b47e3140a196777fca5c4f2b4
parent2d0469ef33e4da7e131809fe6a019618ad9787ca (diff)
version 0.1.21HEAD0.1.21master
-rw-r--r--README.md42
-rw-r--r--cbits/hschooks.c2
-rw-r--r--elisp/intero.el1252
-rw-r--r--intero.cabal9
-rw-r--r--src/GhciFind.hs67
-rw-r--r--src/GhciInfo.hs15
-rw-r--r--src/GhciMonad.hs25
-rw-r--r--src/GhciTypes.hs2
-rw-r--r--src/InteractiveUI.hs169
-rw-r--r--src/Main.hs70
-rw-r--r--src/test/Main.hs33
11 files changed, 1338 insertions, 348 deletions
diff --git a/README.md b/README.md
index e4994c8..b1f8e8d 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,4 @@
-# <img src="https://github.com/commercialhaskell/intero/raw/master/images/intero.svg" height=25> intero [![Build Status](https://travis-ci.org/commercialhaskell/intero.png)](https://travis-ci.org/commercialhaskell/intero) <a href="https://melpa.org/#/intero"><img alt="MELPA" src="https://melpa.org/packages/intero-badge.svg"/></a>
+# <img src="https://github.com/commercialhaskell/intero/raw/master/images/intero.svg" height=25> intero [![Build Status](https://travis-ci.org/commercialhaskell/intero.png)](https://travis-ci.org/commercialhaskell/intero) [![MELPA](https://melpa.org/packages/intero-badge.svg)](https://melpa.org/#/intero) [![MELPA Stable](https://stable.melpa.org/packages/intero-badge.svg)](https://stable.melpa.org/#/intero) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/commercialhaskell/path?svg=true)](https://ci.appveyor.com/project/commercialhaskell/intero)
Complete interactive development program for Haskell
@@ -16,35 +16,37 @@ Key binding | Description
`C-c C-t` | Show the type of thing at point, or the selection
`C-u C-c C-t` | Insert a type signature for the thing at point
`C-c C-l` | Load this module in the REPL
+`C-c C-c` | Evaluate the selected region in the REPL
`C-c C-r` | Apply suggestions from GHC
`C-c C-k` | Clear REPL
`C-c C-z` | Switch to and from the REPL
-## Whitelisting/blacklisting projects
-
-Typically Intero will enable for all projects, and for files
-without a stack.yaml, it will assume the "global" project. Some users
-prefer to enable Intero selectively. See below how to do that.
+## Enabling intero
-Find this line in your Emacs configuration and remove it:
+To enable `intero` in all `haskell-mode` buffers by default, enable
+`intero-global-mode`, by using `M-x customize` or by adding
+`(intero-global-mode 1)` to your Emacs start-up files.
-``` lisp
-(add-hook 'haskell-mode-hook 'intero-mode)
-```
+Intero will then activate for all projects, and for files without a
+stack.yaml, it will assume the "global" project. If you want to use an
+alternate stack yaml configuration file (for example, when developing
+for multiple GHC versions), use `M-x intero-stack-yaml` to switch
+file. When switching configuration, you will asked whether you want to
+preserve this choice across emacs sessions for the given project.
-To whitelist specific directories (and ignore everything else), use:
+## Whitelisting/blacklisting projects
-``` lisp
-(setq intero-whitelist '("/work/directories/" "/my/directories/"))
-(add-hook 'haskell-mode-hook 'intero-mode-whitelist)
-```
+Some users prefer to enable Intero selectively. The custom variables
+`intero-blacklist` and `intero-whitelist` are provided for this
+purpose, and are honoured by `intero-global-mode`:
-To blacklist specific directories (and allow everything else), use:
+If the parent directory of a Haskell file is listed in
+`intero-blacklist`, then `intero` will not be enabled for that file,
+unless a parent directory of that file is also listed in
+`intero-whitelist`. In other words, whitelist entries take
+precedence. You can therefore blacklist `/` to disable `intero` in all
+projects unless they are whitelisted.
-``` lisp
-(setq intero-blacklist '("/path/to/bad/project" "/path/to/ignore/me"))
-(add-hook 'haskell-mode-hook 'intero-mode-blacklist)
-```
## Intero for IDE writers
diff --git a/cbits/hschooks.c b/cbits/hschooks.c
index 7a36965..2be91a0 100644
--- a/cbits/hschooks.c
+++ b/cbits/hschooks.c
@@ -30,7 +30,7 @@ initGCStatistics(void)
void
defaultsHook (void)
{
-#if __GLASGOW_HASKELL__ >= 707
+#if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 802
// This helps particularly with large compiles, but didn't work
// very well with earlier GHCs because it caused large amounts of
// fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().
diff --git a/elisp/intero.el b/elisp/intero.el
index 682439b..8a5e770 100644
--- a/elisp/intero.el
+++ b/elisp/intero.el
@@ -1,6 +1,7 @@
;;; intero.el --- Complete development mode for Haskell
;; Copyright (c) 2016 Chris Done
+;; Copyright (c) 2016 Steve Purcell
;; Copyright (C) 2016 Артур Файзрахманов
;; Copyright (c) 2015 Athur Fayzrakhmanov
;; Copyright (C) 2015 Gracjan Polak
@@ -13,7 +14,7 @@
;; Created: 3rd June 2016
;; Version: 0.1.13
;; Keywords: haskell, tools
-;; Package-Requires: ((flycheck "0.25") (company "0.8") (emacs "24.3") (haskell-mode "13.0"))
+;; Package-Requires: ((flycheck "0.25") (company "0.8") (emacs "24.4") (haskell-mode "13.0"))
;; 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
@@ -59,6 +60,7 @@
(require 'eldoc)
(eval-when-compile
(require 'wid-edit))
+(require 'tramp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Configuration
@@ -68,7 +70,7 @@
:group 'haskell)
(defcustom intero-package-version
- "0.1.20"
+ "0.1.21"
"Package version to auto-install.
This version does not necessarily have to be the latest version
@@ -86,7 +88,6 @@ pointlessly."
This causes it to skip loading the files from the selected target."
:group 'intero
:type 'boolean)
-(make-variable-buffer-local 'intero-repl-no-load)
(defcustom intero-repl-no-build
t
@@ -94,7 +95,6 @@ This causes it to skip loading the files from the selected target."
This causes it to skip building the target."
:group 'intero
:type 'boolean)
-(make-variable-buffer-local 'intero-repl-no-build)
(defcustom intero-debug nil
"Show debug output."
@@ -123,6 +123,12 @@ To use this, use the following mode hook:
:group 'intero
:type 'string)
+(defcustom intero-stack-executable
+ "stack"
+ "Name or path to the Stack executable to use."
+ :group 'intero
+ :type 'string)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Modes
@@ -134,7 +140,7 @@ To use this, use the following mode hook:
;;;###autoload
(define-minor-mode intero-mode
- "Minor mode for Intero
+ "Minor mode for Intero.
\\{intero-mode-map}"
:lighter intero-lighter
@@ -144,55 +150,84 @@ To use this, use the following mode hook:
(message "Disabling interactive-haskell-mode ...")
(interactive-haskell-mode -1)))
(if intero-mode
- (progn (flycheck-select-checker 'intero)
- (flycheck-mode)
- (add-to-list (make-local-variable 'company-backends) 'company-intero)
- (company-mode)
- (setq-local eldoc-documentation-function 'eldoc-intero))
- (message "Intero mode disabled.")))
+ (progn
+ (intero-flycheck-enable)
+ (add-hook 'completion-at-point-functions 'intero-completion-at-point nil t)
+ (add-to-list (make-local-variable 'company-backends) 'intero-company)
+ (company-mode)
+ (unless eldoc-documentation-function
+ (setq-local eldoc-documentation-function #'ignore))
+ (add-function :before-until (local 'eldoc-documentation-function) #'intero-eldoc)
+ )
+ (progn
+ (remove-function (local 'eldoc-documentation-function) #'intero-eldoc)
+ (message "Intero mode disabled."))))
+;;;###autoload
(defun intero-mode-whitelist ()
"Run intero-mode when the current project is in `intero-whitelist'."
(interactive)
- (let ((file (buffer-file-name)))
- (when (cl-remove-if-not (lambda (directory)
- (file-in-directory-p file directory))
- intero-whitelist)
- (intero-mode))))
+ (when (intero-directories-contain-file (buffer-file-name) intero-whitelist)
+ (intero-mode)))
+;;;###autoload
(defun intero-mode-blacklist ()
"Run intero-mode unless the current project is in `intero-blacklist'."
(interactive)
- (let ((file (buffer-file-name)))
- (unless (cl-remove-if-not (lambda (directory)
- (file-in-directory-p file directory))
- intero-blacklist)
- (intero-mode))))
+ (unless (intero-directories-contain-file (buffer-file-name) intero-blacklist)
+ (intero-mode)))
+
+(dolist (f '(intero-mode-whitelist intero-mode-blacklist))
+ (make-obsolete
+ f
+ "use `intero-global-mode', which honours `intero-whitelist' and `intero-blacklist'."
+ "2017-05-13"))
+
(define-key intero-mode-map (kbd "C-c C-t") 'intero-type-at)
+(define-key intero-mode-map (kbd "M-?") 'intero-uses-at)
(define-key intero-mode-map (kbd "C-c C-i") 'intero-info)
(define-key intero-mode-map (kbd "M-.") 'intero-goto-definition)
(define-key intero-mode-map (kbd "C-c C-l") 'intero-repl-load)
+(define-key intero-mode-map (kbd "C-c C-c") 'intero-repl-eval-region)
(define-key intero-mode-map (kbd "C-c C-z") 'intero-repl)
(define-key intero-mode-map (kbd "C-c C-r") 'intero-apply-suggestions)
+(define-key intero-mode-map (kbd "C-c C-e") 'intero-expand-splice-at-point)
+
+(defun intero-directories-contain-file (file dirs)
+ "Return non-nil if FILE is contained in at least one of DIRS."
+ (cl-some (lambda (directory)
+ (file-in-directory-p file directory))
+ dirs))
+
+(defun intero-mode-maybe ()
+ "Enable `intero-mode' in all Haskell mode buffers.
+The buffer's filename (or working directory) is checked against
+`intero-whitelist' and `intero-blacklist'. If both the whitelist
+and blacklist match, then the whitelist entry wins, and
+`intero-mode' is enabled."
+ (when (and (derived-mode-p 'haskell-mode)
+ (let* ((file (or (buffer-file-name) default-directory))
+ (blacklisted (intero-directories-contain-file
+ file intero-blacklist))
+ (whitelisted (intero-directories-contain-file
+ file intero-whitelist)))
+ (or whitelisted (not blacklisted))))
+ (intero-mode 1)))
+
+;;;###autoload
+(define-globalized-minor-mode intero-global-mode
+ intero-mode intero-mode-maybe)
+
+(define-obsolete-function-alias 'global-intero-mode 'intero-global-mode)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global variables/state
-(defvar intero-global-mode nil
- "Global mode is enabled?")
-
-(defun global-intero-mode ()
- "Enable Intero on all Haskell mode buffers."
- (interactive)
- (setq intero-global-mode (not intero-global-mode))
- (if intero-global-mode
- (add-hook 'haskell-mode-hook 'intero-mode)
- (remove-hook 'haskell-mode-hook 'intero-mode))
- (when (eq this-command 'global-intero-mode)
- (message "Intero mode is now %s on all future Haskell buffers."
- (if intero-global-mode
- "enabled" "disabled"))))
+(defvar intero-temp-file-buffer-mapping
+ (make-hash-table)
+ "A mapping from file names to buffers.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Buffer-local variables/state
@@ -207,6 +242,9 @@ LIST is a FIFO.")
(defvar-local intero-targets (list)
"Targets used for the stack process.")
+(defvar-local intero-start-time nil
+ "Start time of the stack process.")
+
(defvar-local intero-source-buffer (list)
"Buffer from which Intero was first requested to start.")
@@ -242,18 +280,45 @@ This is slower, but will build required dependencies.")
(defvar-local intero-extensions nil
"Extensions supported by the compiler.")
-(defvar intero-ghc-version nil
+(defvar-local intero-ghc-version nil
"GHC version used by the project.")
(defvar-local intero-repl-last-loaded
nil
"The last loaded thing with `intero-repl-load`.")
+(defvar-local intero-buffer-host nil
+ "The hostname of the box hosting the intero process for the current buffer.")
+
+(defvar-local intero-stack-yaml nil
+ "The yaml file that intero should tell stack to use. When nil,
+ intero relies on stack's default, usually the 'stack.yaml' in
+ the project root.")
+
+(defun intero-inherit-local-variables (buffer)
+ "Make the current buffer inherit values of certain local variables from BUFFER."
+ (let ((variables '(intero-stack-executable
+ intero-repl-no-build
+ intero-repl-no-load
+ intero-stack-yaml
+ ;; TODO: shouldn’t more of the above be here?
+ )))
+ (cl-loop for v in variables do
+ (set (make-local-variable v) (buffer-local-value v buffer)))))
+
+(defmacro intero-with-temp-buffer (&rest body)
+ "Run BODY in `with-temp-buffer', but inherit certain local variables from the current buffer first."
+ (declare (indent 0) (debug t))
+ `(let ((initial-buffer (current-buffer)))
+ (with-temp-buffer
+ (intero-inherit-local-variables initial-buffer)
+ ,@body)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interactive commands
(defun intero-add-package (package)
- "Add a package dependency to the currently running project backend."
+ "Add a dependency on PACKAGE to the currently-running project backend."
(interactive "sPackage: ")
(intero-blocking-call 'backend (concat ":set -package " package))
(flycheck-buffer))
@@ -290,7 +355,7 @@ You can use this to kill them or look inside."
(defun intero-fontify-expression (expression)
"Return a haskell-fontified version of EXPRESSION."
- (with-temp-buffer
+ (intero-with-temp-buffer
(when (fboundp 'haskell-mode)
(let ((flycheck-checkers nil)
(haskell-mode-hook nil))
@@ -301,17 +366,73 @@ You can use this to kill them or look inside."
(font-lock-fontify-buffer))
(buffer-string)))
+(defun intero-uses-at ()
+ "Highlight where the identifier at point is used."
+ (interactive)
+ (let* ((thing (intero-thing-at-point))
+ (uses (split-string (apply #'intero-get-uses-at thing)
+ "\n"
+ t)))
+ (unless (null uses)
+ (let ((highlighted nil))
+ (cl-loop
+ for use in uses
+ when (string-match
+ "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$"
+ use)
+ do (let* ((fp (match-string 1 use))
+ (sline (string-to-number (match-string 2 use)))
+ (scol (string-to-number (match-string 3 use)))
+ (eline (string-to-number (match-string 4 use)))
+ (ecol (string-to-number (match-string 5 use)))
+ (start (save-excursion (goto-char (point-min))
+ (forward-line (1- sline))
+ (forward-char (1- scol))
+ (point))))
+ (when (string= fp (intero-temp-file-name))
+ (unless highlighted
+ (intero-highlight-uses-mode))
+ (setq highlighted t)
+ (intero-highlight-uses-mode-highlight
+ start
+ (save-excursion (goto-char (point-min))
+ (forward-line (1- eline))
+ (forward-char (1- ecol))
+ (point))
+ (= start (car thing))))))))))
+
(defun intero-type-at (insert)
"Get the type of the thing or selection at point.
With prefix argument INSERT, inserts the type above the current
line as a type signature."
(interactive "P")
- (let ((ty (apply #'intero-get-type-at (intero-thing-at-point))))
+ (let* ((thing (intero-thing-at-point))
+ (origin-buffer (current-buffer))
+ (origin (buffer-name))
+ (package (intero-package-name))
+ (ty (apply #'intero-get-type-at thing))
+ (string (buffer-substring (nth 0 thing) (nth 1 thing))))
(if insert
(save-excursion
(goto-char (line-beginning-position))
(insert (intero-fontify-expression ty) "\n"))
+ (with-current-buffer (intero-help-buffer)
+ (let ((buffer-read-only nil)
+ (help-string
+ (concat
+ (intero-fontify-expression string)
+ " in `"
+ (propertize origin 'origin-buffer origin-buffer)
+ "'"
+ " (" package ")"
+ "\n\n"
+ (intero-fontify-expression ty))))
+ (erase-buffer)
+ (intero-help-push-history origin-buffer help-string)
+ (intero-help-pagination)
+ (insert help-string)
+ (goto-char (point-min))))
(message
"%s" (intero-fontify-expression ty)))))
@@ -321,23 +442,23 @@ line as a type signature."
(let ((origin-buffer (current-buffer))
(package (intero-package-name))
(info (intero-get-info-of ident))
- (help-xref-following nil)
(origin (buffer-name)))
- (help-setup-xref (list #'intero-call-in-buffer origin-buffer 'intero-info ident)
- (called-interactively-p 'interactive))
- (save-excursion
- (let ((help-xref-following nil))
- (with-help-window (help-buffer)
- (with-current-buffer (help-buffer)
- (insert
- (intero-fontify-expression ident)
- " in `"
- origin
- "'"
- " (" package ")"
- "\n\n"
- (intero-fontify-expression info))
- (goto-char (point-min))))))))
+ (with-current-buffer (pop-to-buffer (intero-help-buffer))
+ (let ((buffer-read-only nil)
+ (help-string
+ (concat
+ (intero-fontify-expression ident)
+ " in `"
+ (propertize origin 'origin-buffer origin-buffer)
+ "'"
+ " (" package ")"
+ "\n\n"
+ (intero-fontify-expression info))))
+ (erase-buffer)
+ (intero-help-push-history origin-buffer help-string)
+ (intero-help-pagination)
+ (insert help-string)
+ (goto-char (point-min))))))
(defun intero-goto-definition ()
"Jump to the definition of the thing at point.
@@ -350,48 +471,126 @@ Returns nil when unable to find definition."
(xref-push-marker-stack)
(with-no-warnings
(ring-insert find-tag-marker-ring (point-marker))))
- (let ((file (match-string 1 result))
- (line (string-to-number (match-string 2 result)))
- (col (string-to-number (match-string 3 result))))
- (unless (string= file (intero-temp-file-name))
- (find-file file))
+ (let* ((returned-file (match-string 1 result))
+ (line (string-to-number (match-string 2 result)))
+ (col (string-to-number (match-string 3 result)))
+ (loaded-file (intero-extend-path-by-buffer-host returned-file)))
+ (if (intero-temp-file-p loaded-file)
+ (let ((original-buffer (intero-temp-file-origin-buffer loaded-file)))
+ (if original-buffer
+ (switch-to-buffer original-buffer)
+ (error "Attempted to load temp file. Try restarting Intero.
+If the problem persists, please report this as a bug!")))
+ (find-file loaded-file))
(pop-mark)
(goto-char (point-min))
(forward-line (1- line))
(forward-char (1- col))
t))))
+(defmacro intero-with-dump-splices (exp)
+ "Run EXP but with dump-splices enabled in the intero backend process."
+ `(when (intero-blocking-call 'backend ":set -ddump-splices")
+ (let ((result ,exp))
+ (progn
+ nil ; Disable dump-splices here in future
+ result))))
+
+(defun intero-expand-splice-at-point ()
+ "Show the expansion of the template haskell splice at point."
+ (interactive)
+ (unless (intero-gave-up 'backend)
+ (intero-with-dump-splices
+ (let* ((output (intero-blocking-call
+ 'backend
+ (concat ":l " (intero-localize-path (intero-temp-file-name)))))
+ (msgs (intero-parse-errors-warnings-splices nil (current-buffer) output))
+ (line (line-number-at-pos))
+ (column (if (save-excursion
+ (forward-char 1)
+ (looking-back "$(" 1))
+ (+ 2 (current-column))
+ (if (looking-at "$(")
+ (+ 3 (current-column))
+ (1+ (current-column)))))
+ (expansion-msg
+ (cl-loop for msg in msgs
+ when (and (eq (flycheck-error-level msg) 'splice)
+ (= (flycheck-error-line msg) line)
+ (<= (flycheck-error-column msg) column))
+ return (flycheck-error-message msg)))
+ (expansion
+ (when expansion-msg
+ (string-trim
+ (replace-regexp-in-string "^Splicing expression" "" expansion-msg)))))
+ (when expansion
+ (message "%s" (intero-fontify-expression expansion)))))))
+
(defun intero-restart ()
"Simply restart the process with the same configuration as before."
(interactive)
(when (intero-buffer-p 'backend)
(let ((targets (with-current-buffer (intero-buffer 'backend)
- intero-targets)))
+ intero-targets))
+ (stack-yaml (with-current-buffer (intero-buffer 'backend)
+ intero-stack-yaml)))
(intero-destroy 'backend)
- (intero-get-worker-create 'backend targets (current-buffer))
+ (intero-get-worker-create 'backend targets (current-buffer) stack-yaml)
(intero-repl-restart))))
-(defun intero-targets ()
- "Set the targets to use for stack ghci."
- (interactive)
- (let* ((old-targets
- (with-current-buffer (intero-buffer 'backend)
- intero-targets))
- (available-targets (intero-get-targets))
- (targets (if available-targets
- (intero-multiswitch
- "Targets:"
- (mapcar (lambda (target)
- (list :key target
- :title target
- :default (member target old-targets)))
- available-targets))
- (split-string (read-from-minibuffer "Targets: " nil nil nil nil old-targets)
- " "
- t))))
- (intero-destroy)
- (intero-get-worker-create 'backend targets (current-buffer))
- (intero-repl-restart)))
+(defun intero-read-targets ()
+ "Read a list of stack targets."
+ (let ((old-targets
+ (with-current-buffer (intero-buffer 'backend)
+ intero-targets))
+ (available-targets (intero-get-targets)))
+ (if available-targets
+ (intero-multiswitch
+ "Set the targets to use for stack ghci:"
+ (mapcar (lambda (target)
+ (list :key target
+ :title target
+ :default (member target old-targets)))
+ available-targets))
+ (split-string (read-from-minibuffer "Targets: " nil nil nil nil old-targets)
+ " "
+ t))))
+
+(defun intero-targets (targets save-dir-local)
+ "Set the TARGETS to use for stack ghci.
+When SAVE-DIR-LOCAL is non-nil, save TARGETS as the
+directory-local value for `intero-targets'."
+ (interactive (list (intero-read-targets)
+ (y-or-n-p "Save selected target(s) in directory local variables for future sessions? ")))
+ (intero-destroy)
+ (intero-get-worker-create 'backend targets (current-buffer))
+ (intero-repl-restart)
+ (when save-dir-local
+ (save-window-excursion
+ (let ((default-directory (intero-project-root)))
+ (add-dir-local-variable 'haskell-mode 'intero-targets targets)
+ (save-buffer)))))
+
+(defun intero-stack-yaml (file save-dir-local)
+ "Change the yaml FILE that intero should tell stack to use.
+Intero will be restarted with the new configuration. When
+SAVE-DIR-LOCAL is non-nil, save FILE as the directory-local value
+for `intero-stack-yaml'."
+ (interactive (list (read-file-name
+ "Select YAML config: "
+ (file-name-as-directory (intero-project-root)))
+ (y-or-n-p "Save selected stack yaml config in directory local variable for future sessions? ")))
+ (let ((stack-yaml (expand-file-name file)))
+ (setq intero-stack-yaml stack-yaml)
+ (with-current-buffer (intero-buffer 'backend)
+ (setq intero-stack-yaml stack-yaml))
+ (intero-restart)
+ (intero-repl-restart)
+ (when save-dir-local
+ (save-window-excursion
+ (let ((default-directory (intero-project-root)))
+ (add-dir-local-variable 'haskell-mode 'intero-stack-yaml stack-yaml)
+ (save-buffer))))))
(defun intero-destroy (&optional worker)
"Stop WORKER and kill its associated process buffer.
@@ -443,6 +642,35 @@ running context across :load/:reloads in Intero."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Flycheck integration
+(defvar-local intero-check-last-hash nil
+ "Most recent hash for the current buffer when flycheck was last triggered.")
+
+(defvar-local intero-check-last-results nil
+ "Most recent flycheck results for the current buffer.")
+
+(defun intero-check-reuse-last-results (hash cont)
+ "If HASH is not new, return non-nil and call CONT with `intero-check-last-results'."
+ (let ((reuse (and intero-check-last-hash
+ (equal hash intero-check-last-hash))))
+ (progn
+ (when reuse
+ (funcall cont 'finished intero-check-last-results))
+ reuse)))
+
+(defun intero-flycheck-enable ()
+ "Enable intero's flycheck support in this buffer."
+ (flycheck-select-checker 'intero)
+ (setq intero-check-last-mod-time nil
+ intero-check-last-results nil)
+ (flycheck-mode))
+
+(defun intero-check-calculate-hash ()
+ "Calculate a hash for the current buffer that will change when it needs re-checking."
+ (secure-hash
+ 'md5
+ (concat (prin1-to-string intero-start-time) ; Force re-check after intero-restart
+ (buffer-substring-no-properties (point-min) (point-max)))))
+
(defun intero-check (checker cont)
"Run a check with CHECKER and pass the status onto CONT."
(if (intero-gave-up 'backend)
@@ -450,47 +678,55 @@ running context across :load/:reloads in Intero."
nil
cont
'interrupted)
- (let ((file-buffer (current-buffer)))
- (intero-async-call
- 'backend
- (concat ":l " (intero-temp-file-name))
- (list :cont cont
- :file-buffer file-buffer
- :checker checker)
- (lambda (state string)
- (let ((compile-ok (string-match "OK, modules loaded: \\(.*\\)\\.$" string)))
+ (let* ((file-buffer (current-buffer))
+ (temp-file (intero-localize-path (intero-temp-file-name)))
+ (hash (intero-check-calculate-hash)))
+ (unless (intero-check-reuse-last-results hash cont)
+ (intero-async-call
+ 'backend
+ (concat ":l " temp-file)
+ (list :cont cont
+ :file-buffer file-buffer
+ :hash hash
+ :checker checker)
+ (lambda (state string)
(with-current-buffer (plist-get state :file-buffer)
- (let ((modules (match-string 1 string))
- (msgs (intero-parse-errors-warnings-splices
- (plist-get state :checker)
- (current-buffer)
- string)))
- (intero-collect-compiler-messages msgs)
- (funcall (plist-get state :cont)
- 'finished
- (cl-remove-if (lambda (msg)
- (eq 'splice (flycheck-error-level msg)))
- msgs))
- (when compile-ok
- (intero-async-call 'backend
- (concat ":m + "
- (replace-regexp-in-string modules "," ""))
- nil
- (lambda (_st _))))))))))))
+ (unless (intero-check-reuse-last-results (plist-get state :hash)
+ (plist-get state :cont))
+ (let* ((compile-ok (string-match "OK, modules loaded: \\(.*\\)\\.$" string))
+ (modules (match-string 1 string))
+ (msgs (intero-parse-errors-warnings-splices
+ (plist-get state :checker)
+ (current-buffer)
+ string)))
+ (intero-collect-compiler-messages msgs)
+ (let ((results (cl-remove-if (lambda (msg)
+ (eq 'splice (flycheck-error-level msg)))
+ msgs)))
+ (setq intero-check-last-hash (plist-get state :hash)
+ intero-check-last-results results)
+ (funcall (plist-get state :cont) 'finished results))
+ (when compile-ok
+ (intero-async-call 'backend
+ (concat ":m + "
+ (replace-regexp-in-string modules "," ""))
+ nil
+ (lambda (_st _)))))))))))))
(flycheck-define-generic-checker 'intero
"A syntax and type checker for Haskell using an Intero worker
process."
:start 'intero-check
- :modes '(haskell-mode literate-haskell-mode))
+ :modes '(haskell-mode literate-haskell-mode)
+ :predicate (lambda () intero-mode))
(add-to-list 'flycheck-checkers 'intero)
(defun intero-parse-errors-warnings-splices (checker buffer string)
"Parse flycheck errors and warnings.
CHECKER and BUFFER are added to each item parsed from STRING."
- (with-temp-buffer
+ (intero-with-temp-buffer
(insert string)
(goto-char (point-min))
(let ((messages (list))
@@ -499,7 +735,8 @@ CHECKER and BUFFER are added to each item parsed from STRING."
(concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):"
"[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")
nil t 1)
- (let* ((file (intero-canonicalize-path (match-string 1)))
+ (let* ((local-file (intero-canonicalize-path (match-string 1)))
+ (file (intero-extend-path-by-buffer-host local-file buffer))
(location-raw (match-string 2))
(msg (match-string 3)) ;; Replace gross bullet points.
(type (cond ((string-match "^Warning:" msg)
@@ -510,7 +747,7 @@ CHECKER and BUFFER are added to each item parsed from STRING."
((string-match "^Splicing " msg) 'splice)
(t 'error)))
(location (intero-parse-error
- (concat file ":" location-raw ": x")))
+ (concat local-file ":" location-raw ": x")))
(line (plist-get location :line))
(column (plist-get location :col)))
(setq messages
@@ -518,7 +755,7 @@ CHECKER and BUFFER are added to each item parsed from STRING."
line column type
msg
:checker checker
- :buffer (when (string= temp-file file)
+ :buffer (when (intero-paths-for-same-file temp-file file)
buffer)
:filename (intero-buffer-file-name buffer))
messages)))
@@ -567,6 +804,23 @@ CHECKER and BUFFER are added to each item parsed from STRING."
(apply func args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Traditional completion-at-point function
+
+(defun intero-completion-at-point ()
+ "A (blocking) function suitable for use in `completion-at-point-functions'."
+ (let ((prefix-info (intero-completions-grab-prefix)))
+ (when prefix-info
+ (cl-destructuring-bind
+ (beg end prefix _type) prefix-info
+ (let ((completions
+ (intero-completion-response-to-list
+ (intero-blocking-call
+ 'backend
+ (format ":complete repl %S" prefix)))))
+ (when completions
+ (list beg end completions)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Company integration (auto-completion)
(defconst intero-pragmas
@@ -576,12 +830,12 @@ CHECKER and BUFFER are added to each item parsed from STRING."
"UNPACK" "WARNING")
"Pragmas that GHC supports.")
-(defun company-intero (command &optional arg &rest ignored)
+(defun intero-company (command &optional arg &rest ignored)
"Company source for intero, with the standard COMMAND and ARG args.
Other arguments are IGNORED."
(interactive (list 'interactive))
(cl-case command
- (interactive (company-begin-backend 'company-intero))
+ (interactive (company-begin-backend 'intero-company))
(prefix
(unless (intero-gave-up 'backend)
(let ((prefix-info (intero-completions-grab-prefix)))
@@ -598,6 +852,8 @@ Other arguments are IGNORED."
(current-buffer)
prefix-info))))))))
+(define-obsolete-function-alias 'company-intero 'intero-company)
+
(defun intero-company-callback (source-buffer prefix-info cont)
"Generate completions for SOURCE-BUFFER based on PREFIX-INFO and call CONT on the results."
(cl-destructuring-bind
@@ -760,13 +1016,13 @@ pragma is supported also."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ELDoc integration
-(defvar-local eldoc-intero-cache (make-hash-table :test 'equal)
- "Cache for types of regions, used by `eldoc-intero'.
+(defvar-local intero-eldoc-cache (make-hash-table :test 'equal)
+ "Cache for types of regions, used by `intero-eldoc'.
This is not for saving on requests (we make a request even if
something is in cache, overwriting the old entry), but rather for
making types show immediately when we do have them cached.")
-(defun eldoc-intero-maybe-print (msg)
+(defun intero-eldoc-maybe-print (msg)
"Print MSG with eldoc if eldoc would display a message now.
Like `eldoc-print-current-symbol-info', but just printing MSG
instead of using `eldoc-documentation-function'."
@@ -778,7 +1034,7 @@ instead of using `eldoc-documentation-function'."
nil))
(eldoc-message msg))))
-(defun eldoc-intero ()
+(defun intero-eldoc ()
"ELDoc backend for intero."
(let ((buffer (intero-buffer 'backend)))
(when (and buffer (process-live-p (get-buffer-process buffer)))
@@ -791,13 +1047,13 @@ instead of using `eldoc-documentation-function'."
;; Got an updated type-at-point, cache and print now:
(puthash (list beg end)
msg
- eldoc-intero-cache)
- (eldoc-intero-maybe-print msg))
+ intero-eldoc-cache)
+ (intero-eldoc-maybe-print msg))
;; But if we're seeing errors, invalidate cache-at-point:
- (remhash (list beg end) eldoc-intero-cache))))
+ (remhash (list beg end) intero-eldoc-cache))))
(intero-thing-at-point))))
;; If we have something cached at point, print that first:
- (gethash (intero-thing-at-point) eldoc-intero-cache))
+ (gethash (intero-thing-at-point) intero-eldoc-cache))
(defun intero-haskell-utils-repl-response-error-status (response)
"Parse response REPL's RESPONSE for errors.
@@ -848,21 +1104,43 @@ This is set by `intero-repl-buffer', and should otherwise be nil.")
(let ((comint-buffer-maximum-size 0))
(comint-truncate-buffer)))
+(defmacro intero-with-repl-buffer (prompt-options &rest body)
+ "Evaluate given forms with the REPL as the current buffer.
+The REPL will be started if necessary, and the REPL buffer will
+be activated after evaluation. PROMPT-OPTIONS are passed to
+`intero-repl-buffer'. BODY is the forms to be evaluated."
+ (declare (indent defun))
+ (let ((repl-buffer (cl-gensym)))
+ `(let ((,repl-buffer (intero-repl-buffer ,prompt-options t)))
+ (with-current-buffer ,repl-buffer
+ ,@body)
+ (pop-to-buffer ,repl-buffer))))
+
(defun intero-repl-load (&optional prompt-options)
"Load the current file in the REPL.
If PROMPT-OPTIONS is non-nil, prompt with an options list."
(interactive "P")
(save-buffer)
- (let ((file (intero-temp-file-name))
- (repl-buffer (intero-repl-buffer prompt-options t)))
- (with-current-buffer repl-buffer
+ (let ((file (intero-localize-path (intero-temp-file-name))))
+ (intero-with-repl-buffer prompt-options
+ (comint-simple-send
+ (get-buffer-process (current-buffer))
+ (concat ":l " file))
+ (setq intero-repl-last-loaded file))))
+
+(defun intero-repl-eval-region (begin end &optional prompt-options)
+ "Evaluate the code in region from BEGIN to END in the REPL.
+If the region is unset, the current line will be used.
+PROMPT-OPTIONS are passed to `intero-repl-buffer' if supplied."
+ (interactive "r")
+ (unless (use-region-p)
+ (setq begin (line-beginning-position)
+ end (line-end-position)))
+ (let ((text (buffer-substring-no-properties begin end)))
+ (intero-with-repl-buffer prompt-options
(comint-simple-send
(get-buffer-process (current-buffer))
- (if (string= intero-repl-last-loaded file)
- ":r"
- (concat ":l " file)))
- (setq intero-repl-last-loaded file))
- (pop-to-buffer repl-buffer)))
+ text))))
(defun intero-repl (&optional prompt-options)
"Start up the REPL for this stack project.
@@ -886,7 +1164,8 @@ If PROMPT-OPTIONS is non-nil, prompt with an options list."
(when process (kill-process process)))
(intero-repl-mode-start backend-buffer
(buffer-local-value 'intero-targets backend-buffer)
- nil)))))
+ nil
+ (buffer-local-value 'intero-stack-yaml backend-buffer))))))
(defun intero-repl-buffer (prompt-options &optional store-previous)
"Start the REPL buffer.
@@ -901,16 +1180,23 @@ STORE-PREVIOUS is non-nil, note the caller's buffer in
(initial-buffer (current-buffer))
(backend-buffer (intero-buffer 'backend)))
(with-current-buffer
- (if (get-buffer name)
- (get-buffer name)
- (with-current-buffer
- (get-buffer-create name)
- (cd root)
- (intero-repl-mode)
- (intero-repl-mode-start backend-buffer
- (buffer-local-value 'intero-targets backend-buffer)
- prompt-options)
- (current-buffer)))
+ (or (get-buffer name)
+ (with-current-buffer
+ (get-buffer-create name)
+ ;; The new buffer doesn't know if the initial buffer was hosted
+ ;; remotely or not, so we need to extend by the host of the
+ ;; initial buffer to cd. We could also achieve this by setting the
+ ;; buffer's intero-buffer-host, but intero-repl-mode wipes this, so
+ ;; we defer setting that until after.
+ (cd (intero-extend-path-by-buffer-host root initial-buffer))
+ (intero-repl-mode) ; wipes buffer-local variables
+ (intero-inherit-local-variables initial-buffer)
+ (setq intero-buffer-host (intero-buffer-host initial-buffer))
+ (intero-repl-mode-start backend-buffer
+ (buffer-local-value 'intero-targets backend-buffer)
+ prompt-options
+ (buffer-local-value 'intero-stack-yaml backend-buffer))
+ (current-buffer)))
(progn
(when store-previous
(setq intero-repl-previous-buffer initial-buffer))
@@ -918,12 +1204,12 @@ STORE-PREVIOUS is non-nil, note the caller's buffer in
(defvar intero-hyperlink-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-1] 'intero-find-file-with-line:char)
- (define-key map [C-return] 'intero-find-file-with-line:char)
+ (define-key map [mouse-1] 'intero-find-file-with-line-and-char)
+ (define-key map [C-return] 'intero-find-file-with-line-and-char)
map)
"Keymap for clicking on links in REPL.")
-(defun intero-find-file-with-line:char ()
+(defun intero-find-file-with-line-and-char ()
"Jump to the file and location indicated by text properties at point."
(interactive)
(let ((file (get-text-property (point) 'file))
@@ -951,6 +1237,10 @@ STORE-PREVIOUS is non-nil, note the caller's buffer in
(char (match-string-no-properties 3))
(link-start (1+ (match-beginning 1)))
(link-end (1+ (match-end 2))))
+ (let ((unmangled-file (intero-unmangle-file-path file)))
+ (when unmangled-file
+ (setq file unmangled-file)
+ (replace-match unmangled-file nil nil nil 1)))
(add-text-properties
link-start link-end
(list 'keymap intero-hyperlink-map
@@ -992,29 +1282,41 @@ function is subsequently applied to each line, once."
(setq-local warning-suppress-types (cons '(undo discard-info) warning-suppress-types))
(add-hook 'comint-output-filter-functions
'intero-linkify-process-output
- t)
+ t t)
(setq-local comint-prompt-read-only t)
- (add-to-list (make-local-variable 'company-backends) 'company-intero)
+ (add-hook 'completion-at-point-functions 'intero-completion-at-point nil t)
+ (add-to-list (make-local-variable 'company-backends) 'intero-company)
(company-mode))
-(defun intero-repl-mode-start (backend-buffer targets prompt-options)
+(defun intero-repl-mode-start (backend-buffer targets prompt-options stack-yaml)
"Start the process for the repl in the current buffer.
-BACKEND-BUFFER is used for options.
-TARGETS is the targets to load.
-If PROMPT-OPTIONS is non-nil, prompt with an options list."
+BACKEND-BUFFER is used for options. TARGETS is the targets to
+load. If PROMPT-OPTIONS is non-nil, prompt with an options list.
+STACK-YAML is the stack yaml config to use. When nil, tries to
+use project-wide intero-stack-yaml when nil, otherwise uses
+stack's default)."
+ (setq intero-repl-last-loaded nil)
(setq intero-targets targets)
+ (when stack-yaml
+ (setq intero-stack-yaml stack-yaml))
(when prompt-options
(intero-repl-options backend-buffer))
- (let ((arguments (intero-make-options-list
+ (let ((stack-yaml (if stack-yaml
+ stack-yaml
+ (buffer-local-value 'intero-stack-yaml backend-buffer)))
+ (arguments (intero-make-options-list
(or targets
(let ((package-name (buffer-local-value 'intero-package-name
backend-buffer)))
(unless (equal "" package-name)
(list package-name))))
(buffer-local-value 'intero-repl-no-build backend-buffer)
- (buffer-local-value 'intero-repl-no-load backend-buffer))))
+ (buffer-local-value 'intero-repl-no-load backend-buffer)
+ nil
+ stack-yaml)))
(insert (propertize
- (format "Starting:\n stack ghci %s\n" (combine-and-quote-strings arguments))
+ (format "Starting:\n %s ghci %s\n" intero-stack-executable
+ (combine-and-quote-strings arguments))
'face 'font-lock-comment-face))
(let* ((script-buffer
(with-current-buffer (find-file-noselect (intero-make-temp-file "intero-script"))
@@ -1026,10 +1328,10 @@ If PROMPT-OPTIONS is non-nil, prompt with an options list."
(current-buffer)))
(script
(with-current-buffer script-buffer
- (intero-buffer-file-name))))
+ (intero-localize-path (intero-buffer-file-name)))))
(let ((process
(get-buffer-process
- (apply #'make-comint-in-buffer "intero" (current-buffer) "stack" nil "ghci"
+ (apply #'make-comint-in-buffer "intero" (current-buffer) intero-stack-executable nil "ghci"
(append arguments
(list "--verbosity" "silent")
(list "--ghci-options"
@@ -1054,8 +1356,8 @@ changes in the BACKEND-BUFFER."
:default (not (buffer-local-value 'intero-repl-no-build backend-buffer)))))
(new-options (intero-multiswitch "Start REPL with options:" old-options)))
(with-current-buffer backend-buffer
- (setq intero-repl-no-load (not (member "load-all" new-options)))
- (setq intero-repl-no-build (not (member "build-first" new-options))))))
+ (setq-local intero-repl-no-load (not (member "load-all" new-options)))
+ (setq-local intero-repl-no-build (not (member "build-first" new-options))))))
(font-lock-add-keywords
'intero-repl-mode
@@ -1246,9 +1548,66 @@ The path returned is canonicalized and stripped of any text properties."
(when name
(intero-canonicalize-path (substring-no-properties name)))))
+(defun intero-paths-for-same-file (path-1 path-2)
+ "Compare PATH-1 and PATH-2 to see if they represent the same file."
+ (let ((simplify-path #'(lambda (path)
+ (if (tramp-tramp-file-p path)
+ (let* ((dissection (tramp-dissect-file-name path))
+ (host (tramp-file-name-host dissection))
+ (localname (tramp-file-name-localname dissection)))
+ (concat host ":" localname))
+ path))))
+ (string= (funcall simplify-path path-1) (funcall simplify-path path-2))))
+
+(defun intero-buffer-host (&optional buffer)
+ "Get the hostname of the box hosting the file behind the BUFFER."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((file (intero-buffer-file-name)))
+ (if intero-buffer-host
+ intero-buffer-host
+ (setq intero-buffer-host
+ (when file
+ (if (tramp-tramp-file-p file)
+ (tramp-file-name-host (tramp-dissect-file-name file))
+ "")))))))
+
+(defun intero-extend-path-by-buffer-host (path &optional buffer)
+ "Take a PATH, and extend it by the host of the provided BUFFER (default to current buffer). Return PATH unchanged if the file is local, or the BUFFER has no host."
+ (with-current-buffer (or buffer (current-buffer))
+ (if (or (eq nil (intero-buffer-host)) (eq "" (intero-buffer-host)))
+ path
+ (concat "/"
+ (intero-buffer-host)
+ ":"
+ path))))
+
(defvar-local intero-temp-file-name nil
"The name of a temporary file to which the current buffer's content is copied.")
+(defun intero-temp-file-p (path)
+ "Is PATH a temp file?"
+ (string= (file-name-directory path)
+ (file-name-directory (intero-temp-file-dir))))
+
+(defun intero-temp-file-origin-buffer (temp-file)
+ "Get the original buffer that TEMP-FILE was created for."
+ (or
+ (gethash (intero-canonicalize-path temp-file)
+ intero-temp-file-buffer-mapping)
+ (cl-loop
+ for buffer in (buffer-list)
+ when (string= (intero-canonicalize-path temp-file)
+ (buffer-local-value 'intero-temp-file-name buffer))
+ return buffer)))
+
+(defun intero-unmangle-file-path (file)
+ "If FILE is an intero temp file, return the original source path, otherwise FILE."
+ (or (when (intero-temp-file-p file)
+ (let ((origin-buffer (intero-temp-file-origin-buffer file)))
+ (when origin-buffer
+ (buffer-file-name origin-buffer))))
+ file))
+
(defun intero-make-temp-file (prefix &optional dir-flag suffix)
"Like `make-temp-file', but using a different temp directory.
PREFIX, DIR-FLAG and SUFFIX are all passed to `make-temp-file'
@@ -1256,26 +1615,51 @@ unmodified. A different directory is applied so that if docker
is used with stack, the commands run inside docker can find the
path."
(let ((temporary-file-directory
- (expand-file-name ".stack-work/intero/"
- (intero-project-root))))
+ (intero-temp-file-dir)))
(make-directory temporary-file-directory t)
(make-temp-file prefix dir-flag suffix)))
+(defun intero-temp-file-dir ()
+ "Get the temporary file directory for the current intero project."
+ (let* ((intero-absolute-project-root
+ (intero-extend-path-by-buffer-host (intero-project-root)))
+ (temporary-file-directory
+ (expand-file-name ".stack-work/intero/"
+ intero-absolute-project-root)))
+ temporary-file-directory))
+
(defun intero-temp-file-name (&optional buffer)
"Return the name of a temp file containing an up-to-date copy of BUFFER's contents."
(with-current-buffer (or buffer (current-buffer))
(prog1
(or intero-temp-file-name
- (setq intero-temp-file-name
- (intero-canonicalize-path
- (intero-make-temp-file
- "intero" nil
- (concat "." (if (buffer-file-name)
- (file-name-extension (buffer-file-name))
- "hs"))))))
- (let ((contents (buffer-string)))
- (with-temp-file intero-temp-file-name
- (insert contents))))))
+ (progn (setq intero-temp-file-name
+ (intero-canonicalize-path
+ (intero-make-temp-file
+ "intero" nil
+ (concat "." (if (buffer-file-name)
+ (file-name-extension (buffer-file-name))
+ "hs")))))
+ (puthash intero-temp-file-name
+ (current-buffer)
+ intero-temp-file-buffer-mapping)
+ intero-temp-file-name))
+ (let* ((contents (buffer-string))
+ (fname intero-temp-file-name)
+ (prev-contents (and (file-readable-p fname)
+ (with-temp-buffer
+ (insert-file-contents fname)
+ (buffer-string)))))
+ (unless (and prev-contents (string-equal contents prev-contents))
+ (with-temp-file intero-temp-file-name
+ (insert contents)))))))
+
+(defun intero-localize-path (path)
+ "Turn a possibly-remote PATH to a purely local one.
+This is used to create paths which a remote intero process can load."
+ (if (tramp-tramp-file-p path)
+ (tramp-file-name-localname (tramp-dissect-file-name path))
+ path))
(defun intero-canonicalize-path (path)
"Return a standardized version of PATH.
@@ -1329,7 +1713,7 @@ type as arguments."
(defun intero-format-get-type-at (beg end)
"Compose a request for getting types in region from BEG to END."
(format ":type-at %S %d %d %d %d %S"
- (intero-temp-file-name)
+ (intero-localize-path (intero-temp-file-name))
(save-excursion (goto-char beg)
(line-number-at-pos))
(save-excursion (goto-char beg)
@@ -1359,7 +1743,7 @@ type as arguments."
(unless (member 'save flycheck-check-syntax-automatically)
(intero-async-call
'backend
- (concat ":l " (intero-temp-file-name))))
+ (concat ":l " (intero-localize-path (intero-temp-file-name)))))
(intero-async-call
'backend
":set -fobject-code")
@@ -1377,7 +1761,7 @@ type as arguments."
(intero-blocking-call
'backend
(format ":loc-at %S %d %d %d %d %S"
- (intero-temp-file-name)
+ (intero-localize-path (intero-temp-file-name))
(save-excursion (goto-char beg)
(line-number-at-pos))
(save-excursion (goto-char beg)
@@ -1395,7 +1779,7 @@ type as arguments."
(intero-blocking-call
'backend
(format ":uses %S %d %d %d %d %S"
- (intero-temp-file-name)
+ (intero-localize-path (intero-temp-file-name))
(save-excursion (goto-char beg)
(line-number-at-pos))
(save-excursion (goto-char beg)
@@ -1413,7 +1797,7 @@ passed to CONT in SOURCE-BUFFER."
(intero-async-call
'backend
(format ":complete-at %S %d %d %d %d %S"
- (intero-temp-file-name)
+ (intero-localize-path (intero-temp-file-name))
(save-excursion (goto-char beg)
(line-number-at-pos))
(save-excursion (goto-char beg)
@@ -1429,12 +1813,16 @@ passed to CONT in SOURCE-BUFFER."
(plist-get state :source-buffer)
(funcall
(plist-get state :cont)
- (if (string-match "^*** Exception" reply)
- (list)
- (mapcar
- (lambda (x)
- (replace-regexp-in-string "\\\"" "" x))
- (split-string reply "\n" t))))))))
+ (intero-completion-response-to-list reply))))))
+
+(defun intero-completion-response-to-list (reply)
+ "Convert the REPLY from a backend completion to a list."
+ (if (string-match "^*** Exception" reply)
+ (list)
+ (mapcar
+ (lambda (x)
+ (replace-regexp-in-string "\\\"" "" x))
+ (split-string reply "\n" t))))
(defun intero-get-repl-completions (source-buffer prefix cont)
"Get REPL completions and send to SOURCE-BUFFER.
@@ -1456,6 +1844,26 @@ Completions for PREFIX are passed to CONT in SOURCE-BUFFER."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process communication
+(defun intero-call-process (program &optional infile destination display &rest args)
+ "Synchronously call PROGRAM.
+INFILE, DESTINATION, DISPLAY and ARGS are as for
+'call-process'/'process-file'. Provides TRAMP compatibility for
+'call-process'; when the 'default-directory' is on a remote
+machine, PROGRAM is launched on that machine."
+ (let ((process-args (append (list program infile destination display) args)))
+ (apply 'process-file process-args)))
+
+(defun intero-call-stack (&optional infile destination display stack-yaml &rest args)
+ "Synchronously call stack using the same arguments as `intero-call-process'.
+INFILE, DESTINATION, DISPLAY and ARGS are as for
+`call-process'/`process-file'. STACK-YAML specifies which stack
+yaml config to use, or stack's default when nil."
+ (let ((stack-yaml-args (when stack-yaml
+ (list "--stack-yaml" stack-yaml))))
+ (apply #'intero-call-process intero-stack-executable
+ infile destination display
+ (append stack-yaml-args args))))
+
(defun intero-delete-worker (worker)
"Delete the given WORKER."
(when (intero-buffer-p worker)
@@ -1502,27 +1910,29 @@ as (CALLBACK STATE REPLY)."
(let ((buffer (intero-get-buffer-create worker)))
(if (get-buffer-process buffer)
buffer
- (intero-get-worker-create worker nil (current-buffer)))))
+ (intero-get-worker-create worker nil (current-buffer)
+ (buffer-local-value
+ 'intero-stack-yaml (current-buffer))))))
(defun intero-process (worker)
"Get the WORKER process for the current directory."
(get-buffer-process (intero-buffer worker)))
-(defun intero-get-worker-create (worker &optional targets source-buffer)
+(defun intero-get-worker-create (worker &optional targets source-buffer stack-yaml)
"Start the given WORKER.
-If provided, use the specified TARGETS and SOURCE-BUFFER."
+If provided, use the specified TARGETS, SOURCE-BUFFER and STACK-YAML."
(let* ((buffer (intero-get-buffer-create worker)))
(if (get-buffer-process buffer)
buffer
(let ((install-status (intero-installed-p)))
(if (eq install-status 'installed)
- (intero-start-process-in-buffer buffer targets source-buffer)
- (intero-auto-install buffer install-status targets source-buffer))))))
+ (intero-start-process-in-buffer buffer targets source-buffer stack-yaml)
+ (intero-auto-install buffer install-status targets source-buffer stack-yaml))))))
-(defun intero-auto-install (buffer install-status &optional targets source-buffer)
+(defun intero-auto-install (buffer install-status &optional targets source-buffer stack-yaml)
"Automatically install Intero appropriately for BUFFER.
INSTALL-STATUS indicates the current installation status.
-If supplied, use the given TARGETS and SOURCE-BUFFER."
+If supplied, use the given TARGETS, SOURCE-BUFFER and STACK-YAML."
(if (buffer-local-value 'intero-give-up buffer)
buffer
(let ((source-buffer (or source-buffer (current-buffer))))
@@ -1537,16 +1947,18 @@ Installing intero-%s automatically ...
" intero-package-version))
(redisplay)
- (cl-case (call-process "stack" nil (current-buffer) t "build"
- (with-current-buffer buffer
- (let* ((cabal-file (intero-cabal-find-file))
- (package-name (intero-package-name cabal-file)))
- ;; For local development. Most users'll
- ;; never hit this behaviour.
- (if (string= package-name "intero")
- "intero"
- (concat "intero-" intero-package-version))))
- "ghc-paths" "syb")
+ (cl-case (intero-call-stack
+ nil (current-buffer) t stack-yaml
+ "build"
+ (with-current-buffer buffer
+ (let* ((cabal-file (intero-cabal-find-file))
+ (package-name (intero-package-name cabal-file)))
+ ;; For local development. Most users'll
+ ;; never hit this behaviour.
+ (if (string= package-name "intero")
+ "intero"
+ (concat "intero-" intero-package-version))))
+ "ghc-paths" "syb")
(0
(message "Installed successfully! Starting Intero in a moment ...")
(bury-buffer buffer)
@@ -1571,9 +1983,11 @@ feature, kill this buffer.
'face 'compilation-error))
nil)))))
-(defun intero-start-process-in-buffer (buffer &optional targets source-buffer)
- "Start an Intero worker in BUFFER, for the default or specified TARGETS.
-Automatically performs initial actions in SOURCE-BUFFER, if specified."
+(defun intero-start-process-in-buffer (buffer &optional targets source-buffer stack-yaml)
+ "Start an Intero worker in BUFFER.
+Uses the specified TARGETS if supplied.
+Automatically performs initial actions in SOURCE-BUFFER, if specified.
+Uses the default stack config file, or STACK-YAML file if given."
(if (buffer-local-value 'intero-give-up buffer)
buffer
(let* ((options
@@ -1583,21 +1997,26 @@ Automatically performs initial actions in SOURCE-BUFFER, if specified."
(unless (equal "" package-name)
(list package-name))))
(not (buffer-local-value 'intero-try-with-build buffer))
- t ;; pass --no-load
+ t ;; pass --no-load to stack
+ t ;; pass -ignore-dot-ghci to intero
+ stack-yaml ;; let stack choose a default when nil
))
- (arguments options)
+ (arguments (cons "ghci" options))
(process (with-current-buffer buffer
(when intero-debug
(message "Intero arguments: %s" (combine-and-quote-strings arguments)))
(message "Booting up intero ...")
- (apply #'start-process "stack" buffer "stack" "ghci"
+ (apply #'start-file-process "stack" buffer intero-stack-executable
arguments))))
(set-process-query-on-exit-flag process nil)
(process-send-string process ":set -fobject-code\n")
(process-send-string process ":set prompt \"\\4\"\n")
(with-current-buffer buffer
(erase-buffer)
+ (when stack-yaml
+ (setq intero-stack-yaml stack-yaml))
(setq intero-targets targets)
+ (setq intero-start-time (current-time))
(setq intero-source-buffer source-buffer)
(setq intero-arguments arguments)
(setq intero-starting t)
@@ -1651,11 +2070,16 @@ Restarts flycheck in case there was a problem and flycheck is stuck."
(flycheck-mode)
(flycheck-buffer))
-(defun intero-make-options-list (targets no-build no-load)
+(defun intero-make-options-list (targets no-build no-load ignore-dot-ghci stack-yaml)
"Make the stack ghci options list.
TARGETS are the build targets. When non-nil, NO-BUILD and
-NO-LOAD enable the correspondingly-named stack options."
- (append (list "--with-ghc"
+NO-LOAD enable the correspondingly-named stack options. When
+IGNORE-DOT-GHCI is non-nil, it enables the corresponding GHCI
+option. STACK-YAML is the stack config file to use (or stack's
+default when nil)."
+ (append (when stack-yaml
+ (list "--stack-yaml" stack-yaml))
+ (list "--with-ghc"
"intero"
"--docker-run-args=--interactive=true --tty=false"
)
@@ -1663,7 +2087,9 @@ NO-LOAD enable the correspondingly-named stack options."
(list "--no-build"))
(when no-load
(list "--no-load"))
- (let ((dir (intero-make-temp-file "intero" t)))
+ (when ignore-dot-ghci
+ (list "--ghci-options" "-ignore-dot-ghci"))
+ (let ((dir (intero-localize-path (intero-make-temp-file "intero" t))))
(list "--ghci-options"
(concat "-odir=" dir)
"--ghci-options"
@@ -1698,10 +2124,11 @@ This is a standard process sentinel function."
(defun intero-installed-p ()
"Return non-nil if intero (of the right version) is installed in the stack environment."
(redisplay)
- (with-temp-buffer
- (if (= 0 (call-process "stack" nil t nil "exec"
- "--verbosity" "silent"
- "--" "intero" "--version"))
+ (intero-with-temp-buffer
+ (if (= 0 (intero-call-stack nil t nil intero-stack-yaml
+ "exec"
+ "--verbosity" "silent"
+ "--" "intero" "--version"))
(progn
(goto-char (point-min))
;; This skipping comes due to https://github.com/commercialhaskell/intero/pull/216/files
@@ -1742,7 +2169,8 @@ The process ended. Here is the reason that Emacs gives us:
"For troubleshooting purposes, here are the arguments used to launch intero:
"
- (format " stack ghci %s"
+ (format " %s %s"
+ intero-stack-executable
(combine-and-quote-strings intero-arguments))
"
@@ -1771,9 +2199,9 @@ You can always run M-x intero-restart to make it try again.
(let* ((next-callback (pop intero-callbacks))
(state (nth 0 next-callback))
(func (nth 1 next-callback)))
- (let ((string (strip-carriage-returns (buffer-substring (point-min) (1- (point))))))
+ (let ((string (intero-strip-carriage-returns (buffer-substring (point-min) (1- (point))))))
(if next-callback
- (progn (with-temp-buffer
+ (progn (intero-with-temp-buffer
(funcall func state string))
(setq repeat t))
(when intero-debug
@@ -1781,24 +2209,26 @@ You can always run M-x intero-restart to make it try again.
string)))))
(delete-region (point-min) (point))))))
-(defun strip-carriage-returns (string)
+(defun intero-strip-carriage-returns (string)
"Strip the \\r from Windows \\r\\n line endings in STRING."
(replace-regexp-in-string "\r" "" string))
(defun intero-get-buffer-create (worker)
"Get or create the stack buffer for WORKER.
Uses the directory of the current buffer for context."
- (let* ((root (intero-project-root))
+ (let* ((root (intero-extend-path-by-buffer-host (intero-project-root)))
(cabal-file (intero-cabal-find-file))
(package-name (if cabal-file
(intero-package-name cabal-file)
""))
+ (initial-buffer (current-buffer))
(buffer-name (intero-buffer-name worker))
(default-directory (if cabal-file
(file-name-directory cabal-file)
root)))
(with-current-buffer
(get-buffer-create buffer-name)
+ (intero-inherit-local-variables initial-buffer)
(setq intero-package-name package-name)
(cd default-directory)
(current-buffer))))
@@ -1826,22 +2256,22 @@ Uses the directory of the current buffer for context."
(defun intero-project-root ()
"Get the current stack config directory.
-This is either the directory where the stack.yaml is placed for
-this project, or the global one if no such project-specific
-config exists."
+This is the directory where the file specified in
+`intero-stack-yaml' is located, or if nil then the directory
+where stack.yaml is placed for this project, or the global one if
+no such project-specific config exists."
(if intero-project-root
intero-project-root
- (setq intero-project-root
- (with-temp-buffer
- (cl-case (save-excursion
- (call-process "stack" nil
- (current-buffer)
- nil
- "path"
- "--project-root"
- "--verbosity" "silent"))
- (0 (buffer-substring (line-beginning-position) (line-end-position)))
- (t (intero--warn "Couldn't get the Stack project root.
+ (let ((stack-yaml intero-stack-yaml))
+ (setq intero-project-root
+ (intero-with-temp-buffer
+ (cl-case (save-excursion
+ (intero-call-stack nil (current-buffer) nil stack-yaml
+ "path"
+ "--project-root"
+ "--verbosity" "silent"))
+ (0 (buffer-substring (line-beginning-position) (line-end-position)))
+ (t (intero--warn "Couldn't get the Stack project root.
This can be caused by a syntax error in your stack.yaml file. Check that out.
@@ -1852,31 +2282,36 @@ Otherwise, please report this as a bug!
For debugging purposes, try running the following in your terminal:
-stack path --project-root")
- nil))))))
+%s path --project-root" intero-stack-executable)
+ nil)))))))
(defun intero-ghc-version ()
"Get the GHC version used by the project."
(with-current-buffer (intero-buffer 'backend)
(or intero-ghc-version
(setq intero-ghc-version
- (with-temp-buffer
+ (intero-with-temp-buffer
(cl-case (save-excursion
- (call-process "stack" nil (current-buffer) t "ghc" "--" "--numeric-version"))
+ (intero-call-stack
+ nil (current-buffer) t intero-stack-yaml
+ "ghc" "--" "--numeric-version"))
(0
(buffer-substring (line-beginning-position) (line-end-position)))
(1 nil)))))))
(defun intero-get-targets ()
"Get all available targets."
- (with-temp-buffer
- (cl-case (call-process "stack" nil (current-buffer) t "ide" "targets")
- (0
- (cl-remove-if-not
- (lambda (line)
- (string-match "^[A-Za-z0-9-:]+$" line))
- (split-string (buffer-string) "[\r\n]" t)))
- (1 nil))))
+ (with-current-buffer (intero-buffer 'backend)
+ (intero-with-temp-buffer
+ (cl-case (intero-call-stack nil (current-buffer) t
+ intero-stack-yaml
+ "ide" "targets")
+ (0
+ (cl-remove-if-not
+ (lambda (line)
+ (string-match "^[A-Za-z0-9-:_]+$" line))
+ (split-string (buffer-string) "[\r\n]" t)))
+ (1 nil)))))
(defun intero-package-name (&optional cabal-file)
"Get the current package name from a nearby .cabal file.
@@ -1947,10 +2382,10 @@ Each option is a plist of (:key :default :title) wherein:
:default (boolean) specifies the default checkedness"
(let ((available-width (window-total-width)))
(save-window-excursion
- (with-temp-buffer
+ (intero-with-temp-buffer
(rename-buffer (generate-new-buffer-name "multiswitch"))
(widget-insert (concat title "\n\n"))
- (widget-insert (propertize "Hit " 'face 'font-lock-comment-face))
+ (widget-insert (propertize "Select options with RET, hit " 'face 'font-lock-comment-face))
(widget-create 'push-button :notify
(lambda (&rest ignore)
(exit-recursive-edit))
@@ -1982,6 +2417,7 @@ Each option is a plist of (:key :default :title) wherein:
(use-local-map
(let ((map (copy-keymap widget-keymap)))
(define-key map (kbd "C-c C-c") 'exit-recursive-edit)
+ (define-key map (kbd "C-c C-k") 'abort-recursive-edit)
(define-key map (kbd "C-g") 'abort-recursive-edit)
map))
(widget-setup)
@@ -2033,7 +2469,7 @@ automatically."
(setq intero-hoogle-port port)
(start-process "hoogle"
buffer
- "stack"
+ intero-stack-executable
"hoogle"
"server"
"--no-setup"
@@ -2065,10 +2501,12 @@ automatically."
(let* ((root (intero-project-root))
(buffer-name (intero-hoogle-buffer-name root))
(buf (get-buffer buffer-name))
+ (initial-buffer (current-buffer))
(default-directory root))
(if buf
buf
(with-current-buffer (get-buffer-create buffer-name)
+ (intero-inherit-local-variables initial-buffer)
(cd default-directory)
(current-buffer)))))
@@ -2084,16 +2522,17 @@ automatically."
(defun intero-hoogle-ready-p ()
"Is hoogle ready to be started?"
- (with-temp-buffer
- (cl-case (call-process "stack" nil (current-buffer) t
- "hoogle" "--no-setup" "--verbosity" "silent")
+ (intero-with-temp-buffer
+ (cl-case (intero-call-stack nil (current-buffer) t intero-stack-yaml
+ "hoogle" "--no-setup" "--verbosity" "silent")
(0 t))))
(defun intero-hoogle-supported-p ()
"Is the stack hoogle command supported?"
- (with-temp-buffer
- (cl-case (call-process "stack" nil (current-buffer) t
- "hoogle" "--help")
+ (intero-with-temp-buffer
+ (cl-case (intero-call-stack nil (current-buffer) t
+ intero-stack-yaml
+ "hoogle" "--help")
(0 t))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -2137,6 +2576,23 @@ suggestions are available."
:package (match-string 1 text)))
(setq start (min (length text) (1+ (match-end 0))))))
;; Messages of this format:
+ ;; Expected type: String
+ ;; Actual type: Data.Text.Internal.Builder.Builder
+ (let ((start 0))
+ (while (or (string-match
+ "Expected type: String" text start)
+ (string-match
+ "Actual type: String" text start)
+ (string-match
+ "Actual type: \\[Char\\]" text start)
+ (string-match
+ "Expected type: \\[Char\\]" text start))
+ (setq note t)
+ (add-to-list 'intero-suggestions
+ (list :type 'add-extension
+ :extension "OverloadedStrings"))
+ (setq start (min (length text) (1+ (match-end 0))))))
+ ;; Messages of this format:
;;
;; Defaulting the following constraint(s) to type ‘Integer’
;; (Num a0) arising from the literal ‘1’
@@ -2162,6 +2618,22 @@ suggestions are available."
:option "-fno-warn-name-shadowing"))
(setq start (min (length text) (1+ (match-end 0))))))
;; Messages of this format:
+ ;; Perhaps you want to add ‘foo’ to the import list
+ ;; in the import of ‘Blah’
+ ;; (/path/to/thing:19
+ (when (string-match "Perhaps you want to add [‘`‛]\\([^ ]+\\)['’][\n ]+to[\n ]+the[\n ]+import[\n ]+list[\n ]+in[\n ]+the[\n ]+import[\n ]+of[\n ]+[‘`‛]\\([^ ]+\\)['’][\n ]+(\\([^ ]+\\):(?\\([0-9]+\\)[:,]"
+ text)
+ (let ((ident (match-string 1 text))
+ (module (match-string 2 text))
+ (file (match-string 3 text))
+ (line (string-to-number (match-string 4 text))))
+ (setq note t)
+ (add-to-list 'intero-suggestions
+ (list :type 'add-to-import
+ :module module
+ :ident ident
+ :line line))))
+ ;; Messages of this format:
;;
;; The import of ‘Control.Monad’ is redundant
;; except perhaps to import instances from ‘Control.Monad’
@@ -2213,6 +2685,16 @@ suggestions are available."
:signature (mapconcat #'identity (split-string (substring text start)) " ")
:line (flycheck-error-line msg)))))
;; Messages of this format:
+ (when (string-match "The import of [‘`‛]\\(.+?\\)[’`'][\n ]+from[\n ]+module[\n ]+[‘`‛]\\(.+?\\)[’`'][\n ]+is[\n ]+redundant" text)
+ (let ((module (match-string 2 text))
+ (idents (split-string (match-string 1 text) "," t "[ \n]+")))
+ (setq note t)
+ (add-to-list 'intero-suggestions
+ (list :type 'redundant-import-item
+ :idents idents
+ :line (flycheck-error-line msg)
+ :module module))))
+ ;; Messages of this format:
;;
;; Redundant constraints: (Arith var, Bitwise var)
;; Or
@@ -2225,7 +2707,7 @@ suggestions are available."
;; Monad var)
(when (string-match "Redundant constraints?: " text)
(let* ((redundant-start (match-end 0))
- (parts (with-temp-buffer
+ (parts (intero-with-temp-buffer
(insert (substring text redundant-start))
(goto-char (point-min))
;; A lone unparenthesized constraint might
@@ -2268,7 +2750,11 @@ suggestions are available."
(setq intero-extensions
(split-string
(shell-command-to-string
- "stack exec --verbosity silent -- ghc --supported-extensions"))))))
+ (concat intero-stack-executable
+ (if intero-stack-yaml
+ (concat "--stack-yaml " intero-stack-yaml)
+ "")
+ " exec --verbosity silent -- ghc --supported-extensions")))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Auto actions
@@ -2302,12 +2788,27 @@ suggestions are available."
(mapcar
(lambda (suggestion)
(cl-case (plist-get suggestion :type)
+ (add-to-import
+ (list :key suggestion
+ :title (format "Add ‘%s’ to import of ‘%s’"
+ (plist-get suggestion :ident)
+ (plist-get suggestion :module))
+ :default t))
+ (redundant-import-item
+ (list :key suggestion
+ :title
+ (format "Remove redundant imports %s from import of ‘%s’"
+ (mapconcat (lambda (ident)
+ (concat "‘" ident "’"))
+ (plist-get suggestion :idents) ", ")
+ (plist-get suggestion :module))
+ :default t))
(add-extension
(list :key suggestion
:title (concat "Add {-# LANGUAGE "
(plist-get suggestion :extension)
" #-}")
- :default t))
+ :default (not (string= "OverloadedStrings" (plist-get suggestion :extension)))))
(add-ghc-option
(list :key suggestion
:title (concat "Add {-# OPTIONS_GHC "
@@ -2369,6 +2870,49 @@ suggestions are available."
(cl-loop
for suggestion in sorted
do (cl-case (plist-get suggestion :type)
+ (add-to-import
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- (plist-get suggestion :line)))
+ (when (and (search-forward (plist-get suggestion :module) nil t 1)
+ (search-forward "(" nil t 1))
+ (insert (if (string-match "^[_a-zA-Z]" (plist-get suggestion :ident))
+ (plist-get suggestion :ident)
+ (concat "(" (plist-get suggestion :ident) ")")))
+ (unless (looking-at "[:space:]*)")
+ (insert ", ")))))
+ (redundant-import-item
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- (plist-get suggestion :line)))
+ (let* ((start (point))
+ (end (or (save-excursion
+ (when (search-forward-regexp "\n[^ \t]" nil t 1)
+ (1- (point))))
+ (line-end-position)))
+ (regex
+ (concat
+ "\\("
+ (mapconcat
+ (lambda (ident)
+ (if (string-match "^[_a-zA-Z]" ident)
+ (concat "\\<" (regexp-quote ident) "\\>")
+ (concat "(" (regexp-quote ident) ")")))
+ (plist-get suggestion :idents)
+ "\\|")
+ "\\)"))
+ (string (buffer-substring start end)))
+ (delete-region start end)
+ (insert (replace-regexp-in-string
+ "([\n ]*," "("
+ (replace-regexp-in-string
+ "[\n ,]*,[\n ,]*" ", "
+ (replace-regexp-in-string
+ ",[\n ]*)" ")"
+ (replace-regexp-in-string
+ regex ""
+ string))))
+ (make-string (1- (length (split-string string "\n" t))) 10)))))
(fix-typo
(save-excursion
(goto-char (point-min))
@@ -2449,6 +2993,202 @@ Equivalent to 'warn', but label the warning as coming from intero."
(display-warning 'intero (apply 'format message args) :warning))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Intero help buffer
+
+(defun intero-help-buffer ()
+ "Get the help buffer."
+ (with-current-buffer (get-buffer-create "*Intero-Help*")
+ (unless (eq major-mode 'intero-help-mode) (intero-help-mode))
+ (current-buffer)))
+
+(defvar-local intero-help-entries nil
+ "History for help entries.")
+
+(defun intero-help-pagination ()
+ "Insert pagination for the current help buffer."
+ (let ((buffer-read-only nil))
+ (when (> (length intero-help-entries) 1)
+ (insert-text-button
+ "[back]"
+ 'buffer (current-buffer)
+ 'action (lambda (&rest ignore)
+ (let ((first (pop intero-help-entries)))
+ (setcdr (last intero-help-entries) (cons first nil))
+ (intero-help-refresh)))
+ 'keymap (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'push-button)
+ map))
+ (insert " ")
+ (insert-text-button
+ "[forward]"
+ 'buffer (current-buffer)
+ 'keymap (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'push-button)
+ map)
+ 'action (lambda (&rest ignore)
+ (setq intero-help-entries
+ (intero-bring-to-front intero-help-entries))
+ (intero-help-refresh)))
+ (insert " ")
+ (insert-text-button
+ "[forget]"
+ 'buffer (current-buffer)
+ 'keymap (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'push-button)
+ map)
+ 'action (lambda (&rest ignore)
+ (pop intero-help-entries)
+ (intero-help-refresh)))
+ (insert "\n\n"))))
+
+(defun intero-help-refresh ()
+ "Refresh the help buffer with the current thing in the history."
+ (interactive)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (if (car intero-help-entries)
+ (progn
+ (intero-help-pagination)
+ (insert (cdr (car intero-help-entries)))
+ (goto-char (point-min)))
+ (insert "No help entries."))))
+
+(defun intero-bring-to-front (xs)
+ "Bring the last element of XS to the front."
+ (cons (car (last xs)) (butlast xs)))
+
+(defun intero-help-push-history (buffer item)
+ "Add (BUFFER . ITEM) to the history of help entries."
+ (push (cons buffer item) intero-help-entries))
+
+(defun intero-help-info (ident)
+ "Get the info of the thing with IDENT at point."
+ (interactive (list (intero-ident-at-point)))
+ (with-current-buffer (car (car intero-help-entries))
+ (intero-info ident)))
+
+(define-derived-mode intero-help-mode help-mode "Intero-Help"
+ "Help mode for intero."
+ (setq buffer-read-only t)
+ (setq intero-help-entries nil))
+
+(define-key intero-help-mode-map (kbd "g") 'intero-help-refresh)
+(define-key intero-help-mode-map (kbd "C-c C-i") 'intero-help-info)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Intero highlight uses mode
+
+(defvar intero-highlight-uses-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "n") 'intero-highlight-uses-mode-next)
+ (define-key map (kbd "TAB") 'intero-highlight-uses-mode-next)
+ (define-key map (kbd "p") 'intero-highlight-uses-mode-prev)
+ (define-key map (kbd "S-TAB") 'intero-highlight-uses-mode-prev)
+ (define-key map (kbd "<backtab>") 'intero-highlight-uses-mode-prev)
+ (define-key map (kbd "RET") 'intero-highlight-uses-mode-stop-here)
+ (define-key map (kbd "r") 'intero-highlight-uses-mode-replace)
+ (define-key map (kbd "C-g") 'intero-highlight-uses-mode)
+ (define-key map (kbd "q") 'intero-highlight-uses-mode)
+ map)
+ "Keymap for using `intero-highlight-uses-mode'.")
+
+(defvar-local intero-highlight-uses-mode-point nil)
+(defvar-local intero-highlight-uses-buffer-old-mode nil)
+
+;;;###autoload
+(define-minor-mode intero-highlight-uses-mode
+ "Minor mode for highlighting and jumping between uses."
+ :lighter " Uses"
+ :keymap intero-highlight-uses-mode-map
+ (if intero-highlight-uses-mode
+ (progn (setq intero-highlight-uses-buffer-old-mode buffer-read-only)
+ (setq buffer-read-only t)
+ (setq intero-highlight-uses-mode-point (point)))
+ (progn (setq buffer-read-only intero-highlight-uses-buffer-old-mode)
+ (when intero-highlight-uses-mode-point
+ (goto-char intero-highlight-uses-mode-point))))
+ (remove-overlays (point-min) (point-max) 'intero-highlight-uses-mode-highlight t))
+
+(defun intero-highlight-uses-mode-replace ()
+ "Replace all highlighted instances in the buffer with something else."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((o (intero-highlight-uses-mode-next)))
+ (when o
+ (let ((replacement
+ (read-from-minibuffer
+ (format "Replace uses %s with: "
+ (buffer-substring
+ (overlay-start o)
+ (overlay-end o))))))
+ (let ((inhibit-read-only t))
+ (while o
+ (goto-char (overlay-start o))
+ (delete-region (overlay-start o)
+ (overlay-end o))
+ (insert replacement)
+ (setq o (intero-highlight-uses-mode-next))))))))
+ (intero-highlight-uses-mode -1))
+
+(defun intero-highlight-uses-mode-stop-here ()
+ "Stop at this point."
+ (interactive)
+ (setq intero-highlight-uses-mode-point (point))
+ (intero-highlight-uses-mode -1))
+
+(defun intero-highlight-uses-mode-next ()
+ "Jump to next result."
+ (interactive)
+ (let ((os (sort (cl-remove-if (lambda (o)
+ (or (<= (overlay-start o) (point))
+ (not (overlay-get o 'intero-highlight-uses-mode-highlight))))
+ (overlays-in (point) (point-max)))
+ (lambda (a b)
+ (< (overlay-start a)
+ (overlay-start b))))))
+ (when os
+ (mapc
+ (lambda (o)
+ (when (overlay-get o 'intero-highlight-uses-mode-highlight)
+ (overlay-put o 'face 'lazy-highlight)))
+ (overlays-in (line-beginning-position) (line-end-position)))
+ (goto-char (overlay-start (car os)))
+ (overlay-put (car os) 'face 'isearch)
+ (car os))))
+
+(defun intero-highlight-uses-mode-prev ()
+ "Jump to previous result."
+ (interactive)
+ (let ((os (sort (cl-remove-if (lambda (o)
+ (or (>= (overlay-end o) (point))
+ (not (overlay-get o 'intero-highlight-uses-mode-highlight))))
+ (overlays-in (point-min) (point)))
+ (lambda (a b)
+ (> (overlay-start a)
+ (overlay-start b))))))
+ (when os
+ (mapc
+ (lambda (o)
+ (when (overlay-get o 'intero-highlight-uses-mode-highlight)
+ (overlay-put o 'face 'lazy-highlight)))
+ (overlays-in (line-beginning-position) (line-end-position)))
+ (goto-char (overlay-start (car os)))
+ (overlay-put (car os) 'face 'isearch)
+ (car os))))
+
+(defun intero-highlight-uses-mode-highlight (start end current)
+ "Make a highlight overlay at the span from START to END.
+If CURRENT, highlight the span uniquely."
+ (let ((o (make-overlay start end)))
+ (overlay-put o 'priority 999)
+ (overlay-put o 'face
+ (if current
+ 'isearch
+ 'lazy-highlight))
+ (overlay-put o 'intero-highlight-uses-mode-highlight t)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'intero)
diff --git a/intero.cabal b/intero.cabal
index 67aa1d2..1053699 100644
--- a/intero.cabal
+++ b/intero.cabal
@@ -1,7 +1,7 @@
name:
intero
version:
- 0.1.20
+ 0.1.21
synopsis:
Complete interactive development program for Haskell
license:
@@ -56,6 +56,8 @@ executable intero
cbits/hschooks.c
cpp-options:
-DGHCI
+ cc-options:
+ -fPIC
other-modules:
InteractiveUI
GhciMonad
@@ -63,14 +65,15 @@ executable intero
GhciTypes
GhciInfo
GhciFind
+ Paths_intero
build-depends:
base < 5,
array,
bytestring,
directory,
filepath,
- -- We permit any 8.0.1.*
- ghc >= 7.8 && < 8.0.2,
+ -- We permit any 8.0.1.* or 8.0.2.* or 8.2.1
+ ghc >= 7.8 && < 8.2.2,
ghc-paths,
haskeline,
process,
diff --git a/src/GhciFind.hs b/src/GhciFind.hs
index 4d19727..ff39eb6 100644
--- a/src/GhciFind.hs
+++ b/src/GhciFind.hs
@@ -50,7 +50,11 @@ findQualifiedSource importDecls sample =
Just name
| otherwise = Nothing
where name = unLoc (ideclName m)
+#if __GLASGOW_HASKELL__ >= 802
+ asName = fmap (moduleNameString . unLoc) . ideclAs
+#else
asName = fmap moduleNameString . ideclAs
+#endif
-- | Find completions for the sample, context given by the location.
findCompletions :: (GhcMonad m)
@@ -218,20 +222,34 @@ findLoc infos fp string sl sc el ec =
Nothing ->
return (Left ("No module info for the current file! Try loading it?"))
Just info ->
- do mname' <- findName infos info string sl sc el ec
- d <- getSessionDynFlags
- case mname' of
- Left reason ->
- return (Left reason)
- Right name' ->
- case getSrcSpan name' of
- UnhelpfulSpan{} ->
- return (Left ("Found a name, but no location information. The module is: " ++
- maybe "<unknown>"
- (showppr d . moduleName)
- (nameModule_maybe name')))
- span' ->
- return (Right span')
+ case findImportLoc infos info sl sc el ec of
+ Just result -> return (Right result)
+ Nothing ->
+ do mname' <- findName infos info string sl sc el ec
+ d <- getSessionDynFlags
+ case mname' of
+ Left reason ->
+ return (Left reason)
+ Right name' ->
+ case getSrcSpan name' of
+ UnhelpfulSpan{} ->
+ return (Left ("Found a name, but no location information. The module is: " ++
+ maybe "<unknown>"
+ (showppr d . moduleName)
+ (nameModule_maybe name')))
+ span' ->
+ return (Right span')
+
+findImportLoc :: (Map ModuleName ModInfo) -> ModInfo -> Int -> Int -> Int -> Int -> Maybe SrcSpan
+findImportLoc infos info sl sc el ec =
+ do importedModuleName <- getModuleImportedAt info sl sc el ec
+ importedModInfo <- M.lookup importedModuleName infos
+ return (modinfoLocation importedModInfo)
+
+getModuleImportedAt :: ModInfo -> Int -> Int -> Int -> Int -> Maybe ModuleName
+getModuleImportedAt info sl sc el ec = fmap (unLoc . ideclName . unLoc) importDeclarationMaybe
+ where importDeclarationMaybe = listToMaybe $ filter isWithinRange (modinfoImports info)
+ isWithinRange importDecl = containsSrcSpan sl sc el ec (getLoc $ ideclName $ unLoc importDecl)
-- | Try to resolve the name located at the given position, or
-- otherwise resolve based on the current module's scope.
@@ -364,14 +382,18 @@ findType infos fp string sl sc el ec =
Nothing -> return (FindType minfo ty)
_ ->
fmap (FindType minfo)
- (exprType string)
+#if __GLASGOW_HASKELL__ >= 802
+ (exprType TM_Inst string)
+#else
+ (exprType string)
+#endif
-- | Try to resolve the type display from the given span.
resolveSpanInfo :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe SpanInfo
resolveSpanInfo spanList spanSL spanSC spanEL spanEC =
listToMaybe
(sortBy (flip compareSpanInfoStart)
- (filter (contains spanSL spanSC spanEL spanEC) spanList))
+ (filter (containsSpanInfo spanSL spanSC spanEL spanEC) spanList))
-- | Compare the start of two span infos.
compareSpanInfoStart :: SpanInfo -> SpanInfo -> Ordering
@@ -381,8 +403,17 @@ compareSpanInfoStart this that =
c -> c
-- | Does the 'SpanInfo' contain the location given by the Ints?
-contains :: Int -> Int -> Int -> Int -> SpanInfo -> Bool
-contains spanSL spanSC spanEL spanEC (SpanInfo ancestorSL ancestorSC ancestorEL ancestorEC _ _) =
+containsSpanInfo :: Int -> Int -> Int -> Int -> SpanInfo -> Bool
+containsSpanInfo spanSL spanSC spanEL spanEC (SpanInfo ancestorSL ancestorSC ancestorEL ancestorEC _ _) =
+ contains spanSL spanSC spanEL spanEC ancestorSL ancestorSC ancestorEL ancestorEC
+
+containsSrcSpan :: Int -> Int -> Int -> Int -> SrcSpan -> Bool
+containsSrcSpan spanSL spanSC spanEL spanEC (RealSrcSpan spn) =
+ contains spanSL spanSC spanEL spanEC (srcSpanStartLine spn) (srcSpanStartCol spn - 1) (srcSpanEndLine spn) (srcSpanEndCol spn - 1)
+containsSrcSpan _ _ _ _ _ = False
+
+contains :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool
+contains spanSL spanSC spanEL spanEC ancestorSL ancestorSC ancestorEL ancestorEC =
((ancestorSL == spanSL && spanSC >= ancestorSC) || (ancestorSL < spanSL)) &&
((ancestorEL == spanEL && spanEC <= ancestorEC) || (ancestorEL > spanEL))
diff --git a/src/GhciInfo.hs b/src/GhciInfo.hs
index 92c5c4b..3904f76 100644
--- a/src/GhciInfo.hs
+++ b/src/GhciInfo.hs
@@ -6,9 +6,11 @@
module GhciInfo (collectInfo,getModInfo,showppr) where
+import ConLike
import Control.Exception
import Control.Monad
import qualified CoreUtils
+import DataCon
import Data.Data
import Data.Generics (GenericQ, mkQ, extQ)
import Data.List
@@ -75,12 +77,18 @@ getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
getModInfo name =
do m <- getModSummary name
p <- parseModule m
+ let location = getModuleLocation (parsedSource p)
typechecked <- typecheckModule p
let Just (_, imports, _, _) = renamedSource typechecked
allTypes <- processAllTypeCheckedModule typechecked
let i = tm_checked_module_info typechecked
now <- liftIO getCurrentTime
- return (ModInfo m allTypes i now imports)
+ return (ModInfo m allTypes i now imports location)
+
+getModuleLocation :: ParsedSource -> SrcSpan
+getModuleLocation pSource = case hsmodName (unLoc pSource) of
+ Just located -> getLoc located
+ Nothing -> noSrcSpan
-- | Get ALL source spans in the module.
processAllTypeCheckedModule :: GhcMonad m
@@ -149,8 +157,11 @@ getTypeLHsExpr _ e =
getTypeLPat :: (GhcMonad m)
=> TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLPat _ (L spn pat) =
- return (Just (getMaybeId pat,spn,hsPatType pat))
+ return (Just (getMaybeId pat,spn,getPatType pat))
where
+ getPatType (ConPatOut (L _ (RealDataCon dc)) _ _ _ _ _ _) =
+ dataConRepType dc
+ getPatType pat' = hsPatType pat'
#if __GLASGOW_HASKELL__ >= 800
getMaybeId (VarPat (L _ vid)) = Just vid
#else
diff --git a/src/GhciMonad.hs b/src/GhciMonad.hs
index 82a5819..31afce1 100644
--- a/src/GhciMonad.hs
+++ b/src/GhciMonad.hs
@@ -299,6 +299,19 @@ printForUserPartWay doc = do
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
-- | Run a single Haskell expression
+#if __GLASGOW_HASKELL__ >= 802
+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
+runStmt expr step = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.handleSourceError (\e -> do GHC.printException e;
+ return Nothing) $ do
+ r <- GHC.execStmt expr (GHC.execOptions { GHC.execSingleStep = step })
+ return (Just r)
+#else
runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
runStmt expr step = do
st <- getGHCiState
@@ -310,6 +323,7 @@ runStmt expr step = do
return Nothing) $ do
r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
return (Just r)
+#endif
runDecls :: String -> GHCi [GHC.Name]
runDecls decls = do
@@ -321,6 +335,16 @@ runDecls decls = do
GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
GHC.runDeclsWithLocation (progname st) (line_number st) decls
+#if __GLASGOW_HASKELL__ >= 802
+resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
+resume canLogSpan step = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.resumeExec canLogSpan step
+#else
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
resume canLogSpan step = do
st <- getGHCiState
@@ -329,6 +353,7 @@ resume canLogSpan step = do
withArgs (args st) $
reflectGHCi x $ do
GHC.resume canLogSpan step
+#endif
-- --------------------------------------------------------------------------
-- timing & statistics
diff --git a/src/GhciTypes.hs b/src/GhciTypes.hs
index 95c3a30..87ffc6f 100644
--- a/src/GhciTypes.hs
+++ b/src/GhciTypes.hs
@@ -23,6 +23,8 @@ data ModInfo =
-- ^ Last time the module was updated.
,modinfoImports :: ![LImportDecl Name]
-- ^ Import declarations within this module.
+ ,modinfoLocation :: !SrcSpan
+ -- ^ The location of the module
}
-- | Type of some span of source code. Most of these fields are
diff --git a/src/InteractiveUI.hs b/src/InteractiveUI.hs
index ddb2ecf..ddbcd39 100644
--- a/src/InteractiveUI.hs
+++ b/src/InteractiveUI.hs
@@ -30,6 +30,9 @@ module InteractiveUI (
import GHCi
import GHCi.RemoteTypes
#endif
+#if __GLASGOW_HASKELL__ >= 802
+import GHCi.Signals
+#endif
import qualified Paths_intero
import Data.Version (showVersion)
import qualified Data.Map as M
@@ -60,12 +63,19 @@ import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
setInteractivePrintName )
import Module
import Name
-#if __GLASGOW_HASKELL__ < 709
-import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
-#else
+
+# if __GLASGOW_HASKELL__ >= 802
+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, listVisibleModuleNames )
+#elif __GLASGOW_HASKELL__ >= 710
import Packages ( trusted, getPackageDetails, listVisibleModuleNames )
+#else
+import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
#endif
+
import PprTyThing
+#if __GLASGOW_HASKELL__ >= 802
+import IfaceSyn
+#endif
import RdrName ( getGRE_NameQualifier_maybes )
import SrcLoc
import qualified Lexer
@@ -74,7 +84,12 @@ import StringBuffer
#if __GLASGOW_HASKELL__ < 709
import UniqFM ( eltsUFM )
#endif
+
+#if __GLASGOW_HASKELL__ >= 802
+import Outputable hiding ( printForUser, printForUserPartWay )
+#else
import Outputable hiding ( printForUser, printForUserPartWay, bold )
+#endif
-- Other random utilities
import BasicTypes hiding ( isTopLevel )
@@ -104,6 +119,9 @@ import Data.IORef ( IORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
partition, sort, sortBy )
import Data.Maybe
+#if __GLASGOW_HASKELL__ >= 802
+import qualified Data.Set as Set
+#endif
import Exception hiding (catch)
@@ -136,21 +154,34 @@ import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
import GHC.TopHandler ( topHandler )
-#if __GLASGOW_HASKELL__ >= 800
+pprTyThing', pprTyThingInContext' :: TyThing -> SDoc
+#if __GLASGOW_HASKELL__ >= 802
+pprTyThing' = pprTyThingHdr
+pprTyThingInContext' = pprTyThingInContext showToHeader
+#else
+pprTyThing' = pprTyThing
+pprTyThingInContext' = pprTyThingInContext
+#endif
+
+#if __GLASGOW_HASKELL__ >= 802
+modulePackage :: Module -> UnitId
+modulePackage = moduleUnitId
+#elif __GLASGOW_HASKELL__ >= 800
packageString :: UnitId -> String
packageString = unitIdString
modulePackage :: Module -> UnitId
modulePackage = moduleUnitId
-#elif __GLASGOW_HASKELL__ < 709
-packageString :: PackageId -> String
-packageString = packageIdString
-modulePackage :: Module -> PackageId
-modulePackage = modulePackageId
-#else
+#elif __GLASGOW_HASKELL__ >= 710
packageString :: PackageKey -> String
packageString = packageKeyString
modulePackage :: Module -> PackageKey
modulePackage = modulePackageKey
+#else
+-- 7.8 and below
+packageString :: PackageId -> String
+packageString = packageIdString
+modulePackage :: Module -> PackageId
+modulePackage = modulePackageId
#endif
-----------------------------------------------------------------------------
@@ -201,6 +232,7 @@ ghciCommands = [
("back", keepGoing backCmd, noCompletion),
("browse", keepGoing' (browseCmd False), completeModule),
("browse!", keepGoing' (browseCmd True), completeModule),
+ ("extensions", keepGoing' extensionsCmd, completeModule),
("cd", keepGoing' changeDirectory, completeFilename),
("cd-ghc", keepGoing' changeDirectoryGHC, completeFilename),
("check", keepGoing' checkModule, completeHomeModule),
@@ -317,6 +349,7 @@ defFullHelpText =
" :add [*]<module> ... add module(s) to the current target set\n" ++
" :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
" (!: more details; *: all top-level names)\n" ++
+ " :extensions <mod> display the extensions enabled by module <mod>\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :cmd <expr> run the commands returned by <expr>::IO String\n" ++
" :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
@@ -786,7 +819,11 @@ mkPrompt = do
-- use the 'as' name if there is one
myIdeclName d | Just m <- ideclAs d = m
+#if __GLASGOW_HASKELL__ >= 802
+ | otherwise = ideclName d
+#else
| otherwise = unLoc (ideclName d)
+#endif
deflt_prompt = dots <> context_bit <> modules_bit
@@ -1016,7 +1053,11 @@ runStmt stmt step
| any (flip isPrefixOf stmt) declPrefixes
= do _ <- liftIO $ tryIO $ hFlushAll stdin
result <- GhciMonad.runDecls stmt
+#if __GLASGOW_HASKELL__ >= 802
+ afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)
+#else
afterRunStmt (const True) (GHC.RunOk result)
+#endif
| otherwise
= do -- In the new IO library, read handles buffer data even if the Handle
@@ -1031,8 +1072,40 @@ runStmt stmt step
Just result -> afterRunStmt (const True) result
-- | Clean up the GHCi environment after a statement has run
-afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
-afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e
+#if __GLASGOW_HASKELL__ >= 802
+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi Bool
+afterRunStmt _ (GHC.ExecComplete (Left e) _) = liftIO $ Exception.throwIO e
+afterRunStmt step_here run_result = do
+ resumes <- GHC.getResumeContext
+ case run_result of
+ GHC.ExecComplete (Right names) _ -> do
+ show_types <- isOptionSet ShowType
+ when show_types $ printTypeOfNames names
+ GHC.ExecBreak names mb_info
+ | isNothing mb_info ||
+ step_here (GHC.resumeSpan $ head resumes) -> do
+ mb_id_loc <- toBreakIdAndLocation mb_info
+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+ if (null bCmd)
+ then printStoppedAtBreakInfo (head resumes) names
+ else enqueueCommands [bCmd]
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+ | otherwise -> resume step_here GHC.SingleStep >>=
+ afterRunStmt step_here >> return ()
+ _ -> return ()
+
+ flushInterpBuffers
+ liftIO installSignalHandlers
+ b <- isOptionSet RevertCAFs
+ when b revertCAFs
+
+ return (case run_result of GHC.ExecComplete _ _ -> True; _ -> False)
+#else
+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
+afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e
afterRunStmt step_here run_result = do
resumes <- GHC.getResumeContext
case run_result of
@@ -1061,6 +1134,7 @@ afterRunStmt step_here run_result = do
when b revertCAFs
return (case run_result of GHC.RunOk _ -> True; _ -> False)
+#endif
toBreakIdAndLocation ::
Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
@@ -1687,7 +1761,11 @@ typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
= handleSourceError GHC.printException
$ do
+#if __GLASGOW_HASKELL__ >= 802
+ ty <- GHC.exprType GHC.TM_Inst str
+#else
ty <- GHC.exprType str
+#endif
printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
-----------------------------------------------------------------------------
@@ -1710,7 +1788,7 @@ typeAt str =
(sep [text sample,nest 2 (dcolon <+> ppr ty)])
FindTyThing info' tything ->
printForUserModInfo (modinfoInfo info')
- (pprTyThing tything))
+ (pprTyThing' tything))
-----------------------------------------------------------------------------
-- :uses
@@ -1944,20 +2022,26 @@ isSafeModule m = do
(msafe, pkgs) <- GHC.moduleTrustReqs m
let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
pkg = if packageTrusted dflags m then "trusted" else "untrusted"
+#if __GLASGOW_HASKELL__ >= 802
+ (good, bad) = tallyPkgs dflags (Set.toList pkgs)
+ getPackageStrings = map installedUnitIdString
+#else
(good, bad) = tallyPkgs dflags pkgs
+ getPackageStrings = map packageString
+#endif
-- print info to user...
liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
when (not $ null good)
(liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
- (intercalate ", " $ map packageString good))
+ (intercalate ", " $ getPackageStrings good))
case msafe && null bad of
True -> liftIO $ putStrLn $ mname ++ " is trusted!"
False -> do
when (not $ null bad)
(liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
- ++ (intercalate ", " $ map packageString bad))
+ ++ (intercalate ", " $ getPackageStrings bad))
liftIO $ putStrLn $ mname ++ " is NOT trusted!"
where
@@ -1965,22 +2049,53 @@ isSafeModule m = do
packageTrusted dflags md
| thisPackage dflags == modulePackage md = True
-#if __GLASGOW_HASKELL__ < 709
- | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackage md)
-#else
+#if __GLASGOW_HASKELL__ >= 710
| otherwise = trusted $ getPackageDetails dflags (modulePackage md)
+#else
+ | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackage md)
#endif
tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
| otherwise = partition part deps
where
-#if __GLASGOW_HASKELL__ < 709
+#if __GLASGOW_HASKELL__ >= 802
+ part pkg = trusted $ getInstalledPackageDetails dflags pkg
+#elif __GLASGOW_HASKELL__ >= 710
+ part pkg = trusted $ getPackageDetails dflags pkg
+#else
part pkg = trusted $ getPackageDetails state pkg
state = pkgState dflags
-#else
- part pkg = trusted $ getPackageDetails dflags pkg
#endif
+--------------------------------------------------------------------------------
+-- :extensions
+
+extensionsCmd :: String -> InputT GHCi ()
+extensionsCmd string = do
+ modules <- mapM lookupModule moduleStrings
+ dynflags <-
+ mapM (fmap GHC.ms_hspp_opts . GHC.getModSummary . GHC.moduleName) modules
+ let someExtensions = concatMap dynFlagsEnabledExtensions dynflags
+ liftIO (putStrLn (unwords (nub someExtensions)))
+ where
+ moduleStrings = words string
+
+-- | Get enabled extensions from the dynamic flags.
+dynFlagsEnabledExtensions :: DynFlags -> [String]
+dynFlagsEnabledExtensions df =
+ [ name
+ | name <- supportedLanguagesAndExtensions
+ , extension <- [toEnum 0 ..]
+ , downcase name == downcase (showExtension extension)
+ , xopt extension df
+ ]
+ where
+ downcase = map toLower
+ showExtension e =
+ if isPrefixOf "Opt_" (show e)
+ then drop (length "Opt_") (show e)
+ else show e
+
-----------------------------------------------------------------------------
-- :browse
@@ -2066,8 +2181,8 @@ browseModule bang modl exports_only = do
let things | bang = catMaybes mb_things
| otherwise = filtered_things
- pretty | bang = pprTyThing
- | otherwise = pprTyThingInContext
+ pretty | bang = pprTyThing'
+ | otherwise = pprTyThingInContext'
labels [] = text "-- not currently imported"
labels l = text $ intercalate "\n" $ map qualifier l
@@ -2718,7 +2833,7 @@ showBindings = do
pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
pprTT (thing, fixity, _cls_insts, _fam_insts)
- = pprTyThing thing
+ = pprTyThing' thing
$$ show_fixity
where
show_fixity
@@ -2727,7 +2842,7 @@ showBindings = do
printTyThing :: TyThing -> GHCi ()
-printTyThing tyth = printForUser (pprTyThing tyth)
+printTyThing tyth = printForUser (pprTyThing' tyth)
showBkptTable :: GHCi ()
showBkptTable = do
@@ -3423,8 +3538,12 @@ listAround pan do_highlight = do
prefixed = zipWith ($) highlighted bs_line_nos
output = BS.intercalate (BS.pack "\n") prefixed
+#if __GLASGOW_HASKELL__ >= 802
+ let utf8Decoded = utf8DecodeByteString output
+#else
utf8Decoded <- liftIO $ BS.useAsCStringLen output
$ \(p,n) -> utf8DecodeString (castPtr p) n
+#endif
liftIO $ putStrLn utf8Decoded
where
file = GHC.srcSpanFile pan
diff --git a/src/Main.hs b/src/Main.hs
index 05ff1b9..271f254 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -47,7 +47,9 @@ import Packages ( pprPackages )
#endif
import DriverPhases
import BasicTypes ( failed )
+#if __GLASGOW_HASKELL__ < 802
import StaticFlags
+#endif
import DynFlags
import ErrUtils
import FastString
@@ -60,9 +62,18 @@ import MonadUtils ( liftIO )
-- Imports for --abi-hash
import LoadIface ( loadUserInterface )
import Module ( mkModuleName )
+#if __GLASGOW_HASKELL__ >= 802
+import Finder ( findImportedModule, cannotFindModule )
+#else
import Finder ( findImportedModule, cannotFindInterface )
+#endif
import TcRnMonad ( initIfaceCheck )
+#if __GLASGOW_HASKELL__ >= 802
+import Binary ( openBinMem, put_ )
+import BinFingerprint ( fingerprintBinMem )
+#else
import Binary ( openBinMem, put_, fingerprintBinMem )
+#endif
-- Standard Haskell libraries
import System.IO
@@ -119,12 +130,15 @@ main = do
| otherwise = Just (drop 2 (last minusB_args))
let argv1' = map (mkGeneralLocated "on the commandline") argv1
- (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
-
- -- 2. Parse the "mode" flags (--make, --interactive etc.)
- (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
- let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
+#if __GLASGOW_HASKELL__ >= 802
+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv1'
+ let flagWarnings = modeFlagWarnings
+#else
+ (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
+ let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
+#endif
-- If all we want to do is something like showing the version number
-- then do it now, before we start a GHC session etc. This makes
@@ -240,15 +254,21 @@ main' postLoadMode dflags0 args flagWarnings = do
---------------- Display configuration -----------
when (verbosity dflags6 >= 4) $
-#if __GLASGOW_HASKELL__ >= 709
+#if __GLASGOW_HASKELL__ >= 802
+ let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx
+ where ctx = initSDocContext flags (defaultDumpStyle dflags6)
+ in
+#elif __GLASGOW_HASKELL__ >= 709
let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx
where ctx = initSDocContext flags defaultDumpStyle
in
#endif
liftIO $ dumpPackages dflags6
- when (verbosity dflags6 >= 3) $ do
- liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
+# if __GLASGOW_HASKELL__ < 802
+ when (verbosity dflags6 >= 3) $ do
+ liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
+#endif
---------------- Final sanity checking -----------
liftIO $ checkOptions postLoadMode dflags6 srcs objs
@@ -750,21 +770,27 @@ showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
showOptions :: IO ()
showOptions = putStr (unlines availableOptions)
where
+#if __GLASGOW_HASKELL__ >= 802
availableOptions = map ((:) '-') $
getFlagNames mode_flags ++
- getFlagNames flagsDynamic ++
- (filterUnwantedStatic . getFlagNames $ flagsStatic) ++
- flagsStaticNames
- getFlagNames opts = map getFlagName opts
-#if __GLASGOW_HASKELL__ < 709
- getFlagName (Flag name _) = name
+ getFlagNames flagsDynamic
#else
+ availableOptions = map ((:) '-') $
+ getFlagNames mode_flags ++
+ getFlagNames flagsDynamic ++
+ (filterUnwantedStatic . getFlagNames $ flagsStatic) ++
+ flagsStaticNames
+ -- this is a hack to get rid of two unwanted entries that get listed
+ -- as static flags. Hopefully this hack will disappear one day together
+ -- with static flags
+ filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"]))
+#endif
+ getFlagNames opts = map getFlagName opts
+#if __GLASGOW_HASKELL__ >= 710
getFlagName (Flag name _ _) = name
+#else
+ getFlagName (Flag name _) = name
#endif
- -- this is a hack to get rid of two unwanted entries that get listed
- -- as static flags. Hopefully this hack will disappear one day together
- -- with static flags
- filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"]))
showGhcUsage :: DynFlags -> IO ()
showGhcUsage = showUsage False
@@ -846,12 +872,20 @@ abiHash strs = do
case r of
Found _ m -> return m
_error -> throwGhcException $ CmdLineError $ showSDoc dflags $
+#if __GLASGOW_HASKELL__ >= 802
+ cannotFindModule dflags modname r
+#else
cannotFindInterface dflags modname r
+#endif
mods <- mapM find_it (map fst strs)
let get_iface modl = loadUserInterface False (text "abiHash") modl
+#if __GLASGOW_HASKELL__ >= 802
+ ifaces <- initIfaceCheck (text "") hsc_env $ mapM get_iface mods
+#else
ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
+#endif
bh <- openBinMem (3*1024) -- just less than a block
put_ bh hiVersion
diff --git a/src/test/Main.hs b/src/test/Main.hs
index 8505530..15e2c1a 100644
--- a/src/test/Main.hs
+++ b/src/test/Main.hs
@@ -5,6 +5,7 @@ module Main where
import Control.Exception
import Control.Monad.IO.Class
+import Control.Monad (forM_)
import Data.Char
import System.IO
import System.IO.Temp
@@ -88,6 +89,18 @@ load =
, "Ok, modules loaded: Main."
, "Collecting type info for 1 module(s) ... "]))
it
+ ":l X.hs; :extensions X"
+ (do result <-
+ withIntero
+ []
+ (\dir repl -> do
+ writeFile (dir ++ "/X.hs") "{-# LANGUAGE ScopedTypeVariables #-}\nmodule X where\nx = 'a'"
+ _ <- repl (":l X.hs")
+ repl (":extensions X"))
+ shouldBe
+ (filter (== "ScopedTypeVariables") (words result))
+ ["ScopedTypeVariables"])
+ it
":l NonExistent.hs"
(do result <- withIntero [] (\_ repl -> repl (":l NonExistent.hs"))
shouldBe
@@ -316,6 +329,12 @@ definition =
"f (Just x) = 'a' : x"
(1, 20, 1, 21, "x")
(unlines ["X.hs:(1,9)-(1,10)"]))
+ it
+ "To other module"
+ (locAtMultiple
+ [("X.hs", "import Y"), ("Y.hs", "module Y where")]
+ (1, 8, 1, 9, "Y")
+ (unlines ["./Y.hs:(1,8)-(1,9)"]))
issue
"To unexported thing"
"https://github.com/commercialhaskell/intero/issues/98"
@@ -400,21 +419,25 @@ completion = do
-- Combinators for running and interacting with intero
-- | Find the definition for the thing at point.
-locAt :: String -> (Int, Int, Int, Int, String) -> String -> Expectation
-locAt file (line,col,line',col',name) expected = do
+locAtMultiple :: [(String, String)] -> (Int, Int, Int, Int, String) -> String -> Expectation
+locAtMultiple files (line,col,line',col',name) expected = do
result <-
withIntero
[]
(\dir repl -> do
- writeFile (dir ++ "/X.hs") file
- _ <- repl (":l X.hs")
+ forM_ files $ \(fileName, fileContents) ->
+ writeFile (dir ++ "/" ++ fileName) fileContents
+ _ <- repl (":l " ++ fst (head files))
repl
- (":loc-at X.hs " ++
+ (":loc-at " ++ fst (head files) ++ " " ++
unwords (map show [line, col, line', col']) ++ " " ++ name))
shouldBe result expected
let x = return ()
x
+locAt :: String -> (Int, Int, Int, Int, String) -> String -> Expectation
+locAt file = locAtMultiple [("X.hs", file)]
+
-- | Find use-sites for the given place.
uses
:: (Eq a, Show a)