17ee0e400b
After moving off of Meta, Dotfiles has a greater responsibility to manage configs. Vim, Tmux, and Emacs are now within Stow's purview.
3648 lines
148 KiB
EmacsLisp
3648 lines
148 KiB
EmacsLisp
;;; 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
|
||
;; Copyright (c) 2013 Herbert Valerio Riedel
|
||
;; Copyright (c) 2007 Stefan Monnier
|
||
|
||
;; Author: Chris Done <chrisdone@fpcomplete.com>
|
||
;; Maintainer: Chris Done <chrisdone@fpcomplete.com>
|
||
;; URL: https://github.com/commercialhaskell/intero
|
||
;; Package-Version: 20180703.18
|
||
;; Created: 3rd June 2016
|
||
;; Version: 0.1.13
|
||
;; Keywords: haskell, tools
|
||
;; 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
|
||
;; the Free Software Foundation; either version 3, or (at your option)
|
||
;; any later version.
|
||
|
||
;; This file is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||
;; Boston, MA 02110-1301, USA.
|
||
|
||
;;; Commentary:
|
||
;;
|
||
;; Mode that enables:
|
||
;;
|
||
;; * Flycheck type checking ✓
|
||
;; * Company mode completion ✓
|
||
;; * Go to definition ✓
|
||
;; * Type of selection ✓
|
||
;; * Info ✓
|
||
;; * REPL ✓
|
||
;; * Apply suggestions (extensions, imports, etc.) ✓
|
||
;; * Find uses
|
||
;; * Completion of stack targets ✓
|
||
;; * List all types in all expressions
|
||
;; * Import management
|
||
;; * Dependency management
|
||
|
||
;;; Code:
|
||
|
||
(require 'flycheck)
|
||
(require 'json)
|
||
(require 'warnings)
|
||
(require 'cl-lib)
|
||
(require 'company)
|
||
(require 'comint)
|
||
(require 'widget)
|
||
(require 'eldoc)
|
||
(eval-when-compile
|
||
(require 'wid-edit))
|
||
(require 'tramp)
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Configuration
|
||
|
||
(defgroup intero nil
|
||
"Complete development mode for Haskell"
|
||
:group 'haskell)
|
||
|
||
(defcustom intero-package-version
|
||
(cl-case system-type
|
||
;; Until <https://github.com/haskell/network/issues/313> is fixed:
|
||
(windows-nt "0.1.32")
|
||
(cygwin "0.1.32")
|
||
(t "0.1.32"))
|
||
"Package version to auto-install.
|
||
|
||
This version does not necessarily have to be the latest version
|
||
of intero published on Hackage. Sometimes there are changes to
|
||
Intero which have no use for the Emacs mode. It is only bumped
|
||
when the Emacs mode actually requires newer features from the
|
||
intero executable, otherwise we force our users to upgrade
|
||
pointlessly."
|
||
:group 'intero
|
||
:type 'string)
|
||
|
||
(defcustom intero-repl-no-load
|
||
t
|
||
"Pass --no-load when starting the repl.
|
||
This causes it to skip loading the files from the selected target."
|
||
:group 'intero
|
||
:type 'boolean)
|
||
|
||
(defcustom intero-repl-no-build
|
||
t
|
||
"Pass --no-build when starting the repl.
|
||
This causes it to skip building the target."
|
||
:group 'intero
|
||
:type 'boolean)
|
||
|
||
(defcustom intero-debug nil
|
||
"Show debug output."
|
||
:group 'intero
|
||
:type 'boolean)
|
||
|
||
(defcustom intero-whitelist
|
||
nil
|
||
"Projects to whitelist.
|
||
|
||
It should be a list of directories.
|
||
|
||
To use this, use the following mode hook:
|
||
(add-hook 'haskell-mode-hook 'intero-mode-whitelist)
|
||
or use `intero-global-mode' and add \"/\" to `intero-blacklist'."
|
||
:group 'intero
|
||
:type 'string)
|
||
|
||
(defcustom intero-blacklist
|
||
nil
|
||
"Projects to blacklist.
|
||
|
||
It should be a list of directories.
|
||
|
||
To use this, use the following mode hook:
|
||
(add-hook 'haskell-mode-hook 'intero-mode-blacklist)
|
||
or use `intero-global-mode'."
|
||
:group 'intero
|
||
:type 'string)
|
||
|
||
(defcustom intero-stack-executable
|
||
"stack"
|
||
"Name or path to the Stack executable to use."
|
||
:group 'intero
|
||
:type 'string)
|
||
|
||
(defcustom intero-pop-to-repl
|
||
t
|
||
"When non-nil, pop to REPL when code is sent to it."
|
||
:group 'intero
|
||
:type 'boolean)
|
||
|
||
(defcustom intero-extra-ghc-options nil
|
||
"Extra GHC options to pass to intero executable.
|
||
|
||
For example, this variable can be used to run intero with extra
|
||
warnings and perform more checks via flycheck error reporting."
|
||
:group 'intero
|
||
:type '(repeat string))
|
||
|
||
(defcustom intero-extra-ghci-options nil
|
||
"Extra options to pass to GHCi when running `intero-repl'.
|
||
|
||
For example, this variable can be used to enable some ghci extensions
|
||
by default."
|
||
:group 'intero
|
||
:type '(repeat string))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Modes
|
||
|
||
(defvar intero-mode-map (make-sparse-keymap)
|
||
"Intero minor mode's map.")
|
||
|
||
(defvar-local intero-lighter " Intero"
|
||
"Lighter for the intero minor mode.")
|
||
|
||
;;;###autoload
|
||
(define-minor-mode intero-mode
|
||
"Minor mode for Intero.
|
||
|
||
\\{intero-mode-map}"
|
||
:lighter intero-lighter
|
||
:keymap intero-mode-map
|
||
(when (bound-and-true-p interactive-haskell-mode)
|
||
(when (fboundp 'interactive-haskell-mode)
|
||
(message "Disabling interactive-haskell-mode ...")
|
||
(interactive-haskell-mode -1)))
|
||
(if intero-mode
|
||
(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)
|
||
(setq-local company-minimum-prefix-length 1)
|
||
(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)
|
||
(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)
|
||
(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."
|
||
(and (not (null file))
|
||
(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
|
||
:require 'intero)
|
||
|
||
(define-obsolete-function-alias 'global-intero-mode 'intero-global-mode)
|
||
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Global variables/state
|
||
|
||
(defvar intero-temp-file-buffer-mapping
|
||
(make-hash-table)
|
||
"A mapping from file names to buffers.")
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Buffer-local variables/state
|
||
|
||
(defvar-local intero-callbacks (list)
|
||
"List of callbacks waiting for output.
|
||
LIST is a FIFO.")
|
||
|
||
(defvar-local intero-async-network-cmd nil
|
||
"Command to send to the async network process when we connect.")
|
||
|
||
(defvar-local intero-async-network-connected nil
|
||
"Did we successfully connect to the intero service?")
|
||
|
||
(defvar-local intero-async-network-state nil
|
||
"State to pass to the callback once we get a response.")
|
||
|
||
(defvar-local intero-async-network-worker nil
|
||
"The worker we're associated with.")
|
||
|
||
(defvar-local intero-async-network-callback nil
|
||
"Callback to call when the connection is closed.")
|
||
|
||
(defvar-local intero-arguments (list)
|
||
"Arguments used to call the stack process.")
|
||
|
||
(defvar-local intero-targets (list)
|
||
"Targets used for the stack process.")
|
||
|
||
(defvar-local intero-repl-last-loaded nil
|
||
"Last loaded module in the REPL.")
|
||
|
||
(defvar-local intero-repl-send-after-load nil
|
||
"Send a command after every load.")
|
||
|
||
(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.")
|
||
|
||
(defvar-local intero-project-root nil
|
||
"The project root of the current buffer.")
|
||
|
||
(defvar-local intero-package-name nil
|
||
"The package name associated with the current buffer.")
|
||
|
||
(defvar-local intero-deleting nil
|
||
"The process of the buffer is being deleted.")
|
||
|
||
(defvar-local intero-give-up nil
|
||
"When non-nil, give up trying to start the backend.
|
||
A true value indicates that the backend could not start, or could
|
||
not be installed. The user will have to manually run
|
||
`intero-restart' or `intero-targets' to destroy the buffer and
|
||
create a fresh one without this variable enabled.")
|
||
|
||
(defvar-local intero-try-with-build nil
|
||
"Try starting intero without --no-build.
|
||
This is slower, but will build required dependencies.")
|
||
|
||
(defvar-local intero-starting nil
|
||
"When non-nil, indicates that the intero process starting up.")
|
||
|
||
(defvar-local intero-service-port nil
|
||
"Port that the intero process is listening on for asynchronous commands.")
|
||
|
||
(defvar-local intero-hoogle-port nil
|
||
"Port that hoogle server is listening on.")
|
||
|
||
(defvar-local intero-suggestions nil
|
||
"Auto actions for the buffer.")
|
||
|
||
(defvar-local intero-extensions nil
|
||
"Extensions supported by the compiler.")
|
||
|
||
(defvar-local intero-ghc-version nil
|
||
"GHC version used by the project.")
|
||
|
||
(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 dependency on PACKAGE to the currently-running project backend."
|
||
(interactive "sPackage: ")
|
||
(intero-blocking-call 'backend (concat ":set -package " package))
|
||
(flycheck-buffer))
|
||
|
||
(defun intero-toggle-debug ()
|
||
"Toggle debugging mode on/off."
|
||
(interactive)
|
||
(setq intero-debug (not intero-debug))
|
||
(message "Intero debugging is: %s" (if intero-debug "ON" "OFF")))
|
||
|
||
(defun intero-list-buffers ()
|
||
"List hidden process buffers created by intero.
|
||
|
||
You can use this to kill them or look inside."
|
||
(interactive)
|
||
(let ((buffers (cl-remove-if-not
|
||
(lambda (buffer)
|
||
(string-match-p " intero:" (buffer-name buffer)))
|
||
(buffer-list))))
|
||
(if buffers
|
||
(display-buffer
|
||
(list-buffers-noselect
|
||
nil
|
||
buffers))
|
||
(error "There are no Intero process buffers"))))
|
||
|
||
(defun intero-cd ()
|
||
"Change directory in the backend process."
|
||
(interactive)
|
||
(intero-async-call
|
||
'backend
|
||
(concat ":cd "
|
||
(read-directory-name "Change Intero directory: "))))
|
||
|
||
(defun intero-fontify-expression (expression)
|
||
"Return a haskell-fontified version of EXPRESSION."
|
||
(intero-with-temp-buffer
|
||
(when (fboundp 'haskell-mode)
|
||
(let ((flycheck-checkers nil)
|
||
(haskell-mode-hook nil))
|
||
(haskell-mode)))
|
||
(insert expression)
|
||
(if (fboundp 'font-lock-ensure)
|
||
(font-lock-ensure)
|
||
(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* ((returned-file (match-string 1 use))
|
||
(loaded-file (intero-extend-path-by-buffer-host returned-file))
|
||
(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 (intero-temp-file-p loaded-file)
|
||
(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* ((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)))))
|
||
|
||
(defun intero-info (ident)
|
||
"Get the info of the thing with IDENT at point."
|
||
(interactive (list (intero-ident-at-point)))
|
||
(let ((origin-buffer (current-buffer))
|
||
(package (intero-package-name))
|
||
(info (intero-get-info-of ident))
|
||
(origin (buffer-name)))
|
||
(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.
|
||
Returns nil when unable to find definition."
|
||
(interactive)
|
||
(let ((result (apply #'intero-get-loc-at (intero-thing-at-point))))
|
||
|
||
(if (not (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$"
|
||
result))
|
||
(message "%s" result)
|
||
(if (fboundp 'xref-push-marker-stack) ;; Emacs 25
|
||
(xref-push-marker-stack)
|
||
(with-no-warnings
|
||
(ring-insert find-tag-marker-ring (point-marker))))
|
||
(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
|
||
(expand-file-name
|
||
returned-file
|
||
(intero-extend-path-by-buffer-host (intero-project-root)))))
|
||
(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 ":load " (intero-path-for-ghci (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-p "$(")
|
||
(+ 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 (buffer-local-value 'intero-targets
|
||
(intero-buffer 'backend)))
|
||
(stack-yaml (buffer-local-value 'intero-stack-yaml
|
||
(intero-buffer 'backend))))
|
||
(intero-destroy 'backend)
|
||
(intero-get-worker-create 'backend targets (current-buffer) stack-yaml)
|
||
(intero-repl-restart))))
|
||
|
||
(defun intero-read-targets ()
|
||
"Read a list of stack targets."
|
||
(let ((old-targets
|
||
(buffer-local-value 'intero-targets (intero-buffer 'backend)))
|
||
(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.
|
||
If not provided, WORKER defaults to the current worker process."
|
||
(interactive)
|
||
(if worker
|
||
(intero-delete-worker worker)
|
||
(intero-delete-worker 'backend)))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; DevelMain integration
|
||
|
||
(defun intero-devel-reload ()
|
||
"Reload the module `DevelMain' and then run `DevelMain.update'.
|
||
|
||
This is for doing live update of the code of servers or GUI
|
||
applications. Put your development version of the program in
|
||
`DevelMain', and define `update' to auto-start the program on a
|
||
new thread, and use the `foreign-store' package to access the
|
||
running context across :load/:reloads in Intero."
|
||
(interactive)
|
||
(unwind-protect
|
||
(with-current-buffer
|
||
(or (get-buffer "DevelMain.hs")
|
||
(if (y-or-n-p
|
||
"You need to open a buffer named DevelMain.hs. Find now? ")
|
||
(ido-find-file)
|
||
(error "No DevelMain.hs buffer")))
|
||
(message "Reloading ...")
|
||
(intero-async-call
|
||
'backend
|
||
":load DevelMain"
|
||
(current-buffer)
|
||
(lambda (buffer reply)
|
||
(if (string-match-p "^O[Kk], modules loaded" reply)
|
||
(intero-async-call
|
||
'backend
|
||
"DevelMain.update"
|
||
buffer
|
||
(lambda (_buffer reply)
|
||
(message "DevelMain updated. Output was:\n%s"
|
||
reply)))
|
||
(progn
|
||
(message "DevelMain FAILED. Switch to DevelMain.hs and compile that.")
|
||
(switch-to-buffer buffer)
|
||
(flycheck-buffer)
|
||
(flycheck-list-errors))))))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Flycheck integration
|
||
|
||
(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 (checker cont)
|
||
"Run a check with CHECKER and pass the status onto CONT."
|
||
(if (intero-gave-up 'backend)
|
||
(run-with-timer 0
|
||
nil
|
||
cont
|
||
'interrupted)
|
||
(let* ((file-buffer (current-buffer))
|
||
(staging-file (intero-path-for-ghci (intero-staging-file-name)))
|
||
(temp-file (intero-path-for-ghci (intero-temp-file-name))))
|
||
;; We queue up to :move the staging file to the target temp
|
||
;; file, which also updates its modified time.
|
||
(intero-async-call
|
||
'backend
|
||
(format ":move %s %s" staging-file temp-file))
|
||
;; We load up the target temp file, which has only been updated
|
||
;; by the copy above.
|
||
(intero-async-call
|
||
'backend
|
||
(concat ":load " temp-file)
|
||
(list :cont cont
|
||
:file-buffer file-buffer
|
||
:checker checker)
|
||
(lambda (state string)
|
||
(with-current-buffer (plist-get state :file-buffer)
|
||
(let* ((compile-ok (string-match "O[Kk], 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-results results)
|
||
(funcall (plist-get state :cont) 'finished results))
|
||
(when compile-ok
|
||
(intero-async-call 'backend
|
||
(concat ":module + "
|
||
(replace-regexp-in-string "," "" modules))
|
||
nil
|
||
(lambda (_st _))))))))
|
||
;; We sleep for at least one second to allow a buffer period
|
||
;; between module updates. GHCi will consider a module Foo to be
|
||
;; unchanged even if its filename has changed or timestmap has
|
||
;; changed, if the timestamp is less than 1 second.
|
||
(intero-async-call
|
||
'backend
|
||
":sleep 1"))))
|
||
|
||
(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)
|
||
: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."
|
||
(intero-with-temp-buffer
|
||
(insert string)
|
||
(goto-char (point-min))
|
||
(let ((messages (list))
|
||
(temp-file (intero-temp-file-name buffer))
|
||
(found-error-as-warning nil))
|
||
(while (search-forward-regexp
|
||
(concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):"
|
||
"[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")
|
||
nil t 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 (replace-regexp-in-string
|
||
"[\n\r ]*|$"
|
||
""
|
||
(match-string 3))) ;; Replace gross bullet points.
|
||
(type (cond ((string-match "^Warning:" msg)
|
||
(setq msg (replace-regexp-in-string "^Warning: *" "" msg))
|
||
(if (string-match-p
|
||
(rx bol
|
||
"["
|
||
(or "-Wdeferred-type-errors"
|
||
"-Wdeferred-out-of-scope-variables"
|
||
"-Wtyped-holes")
|
||
"]")
|
||
msg)
|
||
(progn (setq found-error-as-warning t)
|
||
'error)
|
||
'warning))
|
||
((string-match-p "^Splicing " msg) 'splice)
|
||
(t 'error)))
|
||
(location (intero-parse-error
|
||
(concat local-file ":" location-raw ": x")))
|
||
(line (plist-get location :line))
|
||
(column (plist-get location :col)))
|
||
(setq messages
|
||
(cons (flycheck-error-new-at
|
||
line column type
|
||
msg
|
||
:checker checker
|
||
:buffer buffer
|
||
:filename (if (intero-paths-for-same-file temp-file file)
|
||
(intero-buffer-file-name buffer)
|
||
file))
|
||
messages)))
|
||
(forward-line -1))
|
||
(delete-dups
|
||
(if found-error-as-warning
|
||
(cl-remove-if (lambda (msg) (eq 'warning (flycheck-error-level msg))) messages)
|
||
messages)))))
|
||
|
||
(defconst intero-error-regexp-alist
|
||
`((,(concat
|
||
"^ *\\(?1:[^\t\r\n]+?\\):"
|
||
"\\(?:"
|
||
"\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?" ;; "121:1" & "12:3-5"
|
||
"\\|"
|
||
"(\\(?2:[0-9]+\\),\\(?4:[0-9]+\\))-(\\(?3:[0-9]+\\),\\(?5:[0-9]+\\))" ;; "(289,5)-(291,36)"
|
||
"\\)"
|
||
":\\(?6: Warning:\\)?")
|
||
1 (2 . 3) (4 . 5) (6 . nil)) ;; error/warning locus
|
||
|
||
;; multiple declarations
|
||
("^ \\(?:Declared at:\\| \\) \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)$"
|
||
1 2 4 0) ;; info locus
|
||
|
||
;; this is the weakest pattern as it's subject to line wrapping et al.
|
||
(" at \\(?1:[^ \t\r\n]+\\):\\(?2:[0-9]+\\):\\(?4:[0-9]+\\)\\(?:-\\(?5:[0-9]+\\)\\)?[)]?$"
|
||
1 2 (4 . 5) 0)) ;; info locus
|
||
"Regexps used for matching GHC compile messages.")
|
||
|
||
(defun intero-parse-error (string)
|
||
"Parse the line number from the error in STRING."
|
||
(save-match-data
|
||
(when (string-match (mapconcat #'car intero-error-regexp-alist "\\|")
|
||
string)
|
||
(let ((string3 (match-string 3 string))
|
||
(string5 (match-string 5 string)))
|
||
(list :file (match-string 1 string)
|
||
:line (string-to-number (match-string 2 string))
|
||
:col (string-to-number (match-string 4 string))
|
||
:line2 (when string3
|
||
(string-to-number string3))
|
||
:col2 (when string5
|
||
(string-to-number string5)))))))
|
||
|
||
(defun intero-call-in-buffer (buffer func &rest args)
|
||
"In BUFFER, call FUNC with ARGS."
|
||
(with-current-buffer buffer
|
||
(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)))))))
|
||
|
||
(defun intero-repl-completion-at-point ()
|
||
"A (blocking) function suitable for use in `completion-at-point-functions'.
|
||
Should only be used in the repl"
|
||
(let* ((beg (save-excursion (intero-repl-beginning-of-line) (point)))
|
||
(end (point))
|
||
(str (buffer-substring-no-properties beg end))
|
||
(repl-buffer (current-buffer))
|
||
(proc (get-buffer-process (current-buffer))))
|
||
(with-temp-buffer
|
||
(comint-redirect-send-command-to-process
|
||
(format ":complete repl %S" str) ;; command
|
||
(current-buffer) ;; output buffer
|
||
proc ;; target process
|
||
nil ;; echo
|
||
t) ;; no-display
|
||
(while (not (with-current-buffer repl-buffer
|
||
comint-redirect-completed))
|
||
(sleep-for 0.01))
|
||
(let* ((completions (intero-completion-response-to-list (buffer-string)))
|
||
(first-line (car completions)))
|
||
(when (string-match "[^ ]* [^ ]* " first-line) ;; "2 2 :load src/"
|
||
(setq first-line (replace-match "" nil nil first-line))
|
||
(list (+ beg (length first-line)) end (cdr completions)))))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Company integration (auto-completion)
|
||
|
||
(defconst intero-pragmas
|
||
'("CONLIKE" "SCC" "DEPRECATED" "INCLUDE" "INCOHERENT" "INLINABLE" "INLINE"
|
||
"LANGUAGE" "LINE" "MINIMAL" "NOINLINE" "NOUNPACK" "OPTIONS" "OPTIONS_GHC"
|
||
"OVERLAPPABLE" "OVERLAPPING" "OVERLAPS" "RULES" "SOURCE" "SPECIALIZE"
|
||
"UNPACK" "WARNING")
|
||
"Pragmas that GHC supports.")
|
||
|
||
(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 'intero-company))
|
||
(prefix
|
||
(unless (intero-gave-up 'backend)
|
||
(or (let ((hole (intero-grab-hole)))
|
||
(when hole
|
||
(save-excursion
|
||
(goto-char (cdr hole))
|
||
(buffer-substring (car hole) (cdr hole)))))
|
||
(let ((prefix-info (intero-completions-grab-prefix)))
|
||
(when prefix-info
|
||
(cl-destructuring-bind
|
||
(beg end prefix _type) prefix-info
|
||
prefix))))))
|
||
(candidates
|
||
(unless (intero-gave-up 'backend)
|
||
(let ((beg-end (intero-grab-hole)))
|
||
(if beg-end
|
||
(cons :async
|
||
(-partial 'intero-async-fill-at
|
||
(current-buffer)
|
||
(car beg-end)))
|
||
(let ((prefix-info (intero-completions-grab-prefix)))
|
||
(when prefix-info
|
||
(cons :async
|
||
(-partial 'intero-company-callback
|
||
(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
|
||
(beg end prefix type) prefix-info
|
||
(or (and (bound-and-true-p intero-mode)
|
||
(cl-case type
|
||
(haskell-completions-module-name-prefix
|
||
(intero-get-repl-completions source-buffer (concat "import " prefix) cont)
|
||
t)
|
||
(haskell-completions-identifier-prefix
|
||
(intero-get-completions source-buffer beg end cont)
|
||
t)
|
||
(haskell-completions-language-extension-prefix
|
||
(intero-get-repl-completions
|
||
source-buffer
|
||
(concat ":set -X" prefix)
|
||
(-partial (lambda (cont results)
|
||
(funcall cont
|
||
(mapcar (lambda (x)
|
||
(replace-regexp-in-string "^-X" "" x))
|
||
results)))
|
||
cont))
|
||
t)
|
||
(haskell-completions-pragma-name-prefix
|
||
(funcall cont
|
||
(cl-remove-if-not
|
||
(lambda (candidate)
|
||
(string-prefix-p prefix candidate))
|
||
intero-pragmas))
|
||
t)))
|
||
(intero-get-repl-completions source-buffer prefix cont))))
|
||
|
||
(defun intero-completions-grab-prefix (&optional minlen)
|
||
"Grab prefix at point for possible completion.
|
||
If specified, MINLEN is the shortest completion which will be
|
||
considered."
|
||
(when (intero-completions-can-grab-prefix)
|
||
(let ((prefix (cond
|
||
((intero-completions-grab-pragma-prefix))
|
||
((intero-completions-grab-identifier-prefix)))))
|
||
(cond ((and minlen prefix)
|
||
(when (>= (length (nth 2 prefix)) minlen)
|
||
prefix))
|
||
(prefix prefix)))))
|
||
|
||
(defun intero-completions-can-grab-prefix ()
|
||
"Check if the case is appropriate for grabbing completion prefix."
|
||
(when (not (region-active-p))
|
||
(when (looking-at-p (rx (| space line-end punct)))
|
||
(when (not (bobp))
|
||
(save-excursion
|
||
(backward-char)
|
||
(not (looking-at-p (rx (| space line-end)))))))))
|
||
|
||
(defun intero-completions-grab-identifier-prefix ()
|
||
"Grab identifier prefix."
|
||
(let ((pos-at-point (intero-ident-pos-at-point))
|
||
(p (point)))
|
||
(when pos-at-point
|
||
(let* ((start (car pos-at-point))
|
||
(end (cdr pos-at-point))
|
||
(type 'haskell-completions-identifier-prefix)
|
||
(case-fold-search nil)
|
||
value)
|
||
(when (<= p end)
|
||
(setq end p)
|
||
(setq value (buffer-substring-no-properties start end))
|
||
(when (string-match-p (rx bos upper) value)
|
||
(save-excursion
|
||
(goto-char (line-beginning-position))
|
||
(when (re-search-forward
|
||
(rx "import"
|
||
(? (1+ space) "qualified")
|
||
(1+ space)
|
||
upper
|
||
(1+ (| alnum ".")))
|
||
p ;; bound
|
||
t) ;; no-error
|
||
(if (equal p (point))
|
||
(setq type 'haskell-completions-module-name-prefix)
|
||
(when (re-search-forward
|
||
(rx (| " as " "("))
|
||
start
|
||
t)
|
||
(setq type 'haskell-completions-identifier-prefix))))))
|
||
(when (nth 8 (syntax-ppss))
|
||
(setq type 'haskell-completions-general-prefix))
|
||
(when value (list start end value type)))))))
|
||
|
||
(defun intero-completions-grab-pragma-prefix ()
|
||
"Grab completion prefix for pragma completions.
|
||
Returns a list of form '(prefix-start-position
|
||
prefix-end-position prefix-value prefix-type) for pramga names
|
||
such as WARNING, DEPRECATED, LANGUAGE etc. Also returns
|
||
completion prefixes for options in case OPTIONS_GHC pragma, or
|
||
language extensions in case of LANGUAGE pragma. Obsolete OPTIONS
|
||
pragma is supported also."
|
||
(when (nth 4 (syntax-ppss))
|
||
;; We're inside comment
|
||
(let ((p (point))
|
||
(comment-start (nth 8 (syntax-ppss)))
|
||
(case-fold-search nil)
|
||
prefix-start
|
||
prefix-end
|
||
prefix-type
|
||
prefix-value)
|
||
(save-excursion
|
||
(goto-char comment-start)
|
||
(when (looking-at (rx "{-#" (1+ (| space "\n"))))
|
||
(let ((pragma-start (match-end 0)))
|
||
(when (> p pragma-start)
|
||
;; point stands after `{-#`
|
||
(goto-char pragma-start)
|
||
(when (looking-at (rx (1+ (| upper "_"))))
|
||
;; found suitable sequence for pragma name
|
||
(let ((pragma-end (match-end 0))
|
||
(pragma-value (match-string-no-properties 0)))
|
||
(if (eq p pragma-end)
|
||
;; point is at the end of (in)complete pragma name
|
||
;; prepare resulting values
|
||
(progn
|
||
(setq prefix-start pragma-start)
|
||
(setq prefix-end pragma-end)
|
||
(setq prefix-value pragma-value)
|
||
(setq prefix-type
|
||
'haskell-completions-pragma-name-prefix))
|
||
(when (and (> p pragma-end)
|
||
(or (equal "OPTIONS_GHC" pragma-value)
|
||
(equal "OPTIONS" pragma-value)
|
||
(equal "LANGUAGE" pragma-value)))
|
||
;; point is after pragma name, so we need to check
|
||
;; special cases of `OPTIONS_GHC` and `LANGUAGE` pragmas
|
||
;; and provide a completion prefix for possible ghc
|
||
;; option or language extension.
|
||
(goto-char pragma-end)
|
||
(when (re-search-forward
|
||
(rx (* anything)
|
||
(1+ (regexp "\\S-")))
|
||
p
|
||
t)
|
||
(let* ((str (match-string-no-properties 0))
|
||
(split (split-string str (rx (| space "\n")) t))
|
||
(val (car (last split)))
|
||
(end (point)))
|
||
(when (and (equal p end)
|
||
(not (string-match-p "#" val)))
|
||
(setq prefix-value val)
|
||
(backward-char (length val))
|
||
(setq prefix-start (point))
|
||
(setq prefix-end end)
|
||
(setq
|
||
prefix-type
|
||
(if (not (equal "LANGUAGE" pragma-value))
|
||
'haskell-completions-ghc-option-prefix
|
||
'haskell-completions-language-extension-prefix
|
||
)))))))))))))
|
||
(when prefix-value
|
||
(list prefix-start prefix-end prefix-value prefix-type)))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Hole filling
|
||
|
||
(defun intero-async-fill-at (buffer beg cont)
|
||
"Make the blocking call to the process."
|
||
(with-current-buffer buffer
|
||
(intero-async-call
|
||
'backend
|
||
(format
|
||
":fill %s %d %d"
|
||
(intero-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column))))
|
||
(list :buffer (current-buffer) :cont cont)
|
||
(lambda (state reply)
|
||
(if (or (string-match "^Couldn't guess" reply)
|
||
(string-match "^Unable to " reply)
|
||
(intero-parse-error reply))
|
||
(funcall (plist-get state :cont) (list))
|
||
(with-current-buffer (plist-get state :buffer)
|
||
(let ((candidates
|
||
(split-string
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
reply)
|
||
"[\r\n]"
|
||
t)))
|
||
(when candidates
|
||
(funcall (plist-get state :cont) candidates)))))))))
|
||
|
||
(defun intero-grab-hole ()
|
||
"When user is at a hole _ or _foo, return the starting point of
|
||
that hole."
|
||
(let ((beg-end (intero-ident-pos-at-point)))
|
||
(when beg-end
|
||
(let ((string (buffer-substring-no-properties (car beg-end) (cdr beg-end))))
|
||
(when (string-match-p "^_" string)
|
||
beg-end)))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; ELDoc integration
|
||
|
||
(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 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'."
|
||
(with-demoted-errors "eldoc error: %s"
|
||
(and (or (eldoc-display-message-p)
|
||
;; Erase the last message if we won't display a new one.
|
||
(when eldoc-last-message
|
||
(eldoc-message nil)
|
||
nil))
|
||
(eldoc-message msg))))
|
||
|
||
(defun intero-eldoc ()
|
||
"ELDoc backend for intero."
|
||
(let ((buffer (intero-buffer 'backend)))
|
||
(when (and buffer (process-live-p (get-buffer-process buffer)))
|
||
(apply #'intero-get-type-at-async
|
||
(lambda (beg end ty)
|
||
(let ((response-status (intero-haskell-utils-repl-response-error-status ty)))
|
||
(if (eq 'no-error response-status)
|
||
(let ((msg (intero-fontify-expression
|
||
(replace-regexp-in-string "[ \n]+" " " ty))))
|
||
;; Got an updated type-at-point, cache and print now:
|
||
(puthash (list beg end)
|
||
msg
|
||
intero-eldoc-cache)
|
||
(intero-eldoc-maybe-print msg))
|
||
;; But if we're seeing errors, invalidate cache-at-point:
|
||
(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) intero-eldoc-cache))
|
||
|
||
(defun intero-haskell-utils-repl-response-error-status (response)
|
||
"Parse response REPL's RESPONSE for errors.
|
||
Returns one of the following symbols:
|
||
|
||
+ unknown-command
|
||
+ option-missing
|
||
+ interactive-error
|
||
+ no-error
|
||
|
||
*Warning*: this funciton covers only three kind of responses:
|
||
|
||
* \"unknown command …\"
|
||
REPL missing requested command
|
||
* \"<interactive>:3:5: …\"
|
||
interactive REPL error
|
||
* \"Couldn't guess that module name. Does it exist?\"
|
||
(:type-at and maybe some other commands error)
|
||
* *all other reposnses* are treated as success reposneses and
|
||
'no-error is returned."
|
||
(let ((first-line (car (split-string response "\n" t))))
|
||
(cond
|
||
((null first-line) 'no-error)
|
||
((string-match-p "^unknown command" first-line)
|
||
'unknown-command)
|
||
((string-match-p
|
||
"^Couldn't guess that module name. Does it exist?"
|
||
first-line)
|
||
'option-missing)
|
||
((string-match-p "^<interactive>:" first-line)
|
||
'interactive-error)
|
||
((string-match-p "^<no location info>:" first-line)
|
||
'inspection-error)
|
||
(t 'no-error))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; REPL
|
||
|
||
(defconst intero-prompt-regexp "^\4 ")
|
||
|
||
(defvar-local intero-repl-previous-buffer nil
|
||
"Records the buffer to which `intero-repl-switch-back' should jump.
|
||
This is set by `intero-repl-buffer', and should otherwise be nil.")
|
||
|
||
(defun intero-repl-clear-buffer ()
|
||
"Clear the current REPL buffer."
|
||
(interactive)
|
||
(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)
|
||
(when intero-pop-to-repl
|
||
(pop-to-buffer ,repl-buffer)))))
|
||
|
||
(defun intero-repl-after-load ()
|
||
"Set the command to run after load."
|
||
(interactive)
|
||
(if (eq major-mode 'intero-repl-mode)
|
||
(setq intero-repl-send-after-load
|
||
(read-from-minibuffer
|
||
"Command to run: "
|
||
(or intero-repl-send-after-load
|
||
(car (ring-elements comint-input-ring))
|
||
"")))
|
||
(error "Run this in the REPL.")))
|
||
|
||
(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-path-for-ghci (intero-buffer-file-name))))
|
||
(intero-with-repl-buffer prompt-options
|
||
(comint-simple-send
|
||
(get-buffer-process (current-buffer))
|
||
":set prompt \"\\n\"")
|
||
(if (or (not intero-repl-last-loaded)
|
||
(not (equal file intero-repl-last-loaded)))
|
||
(progn
|
||
(comint-simple-send
|
||
(get-buffer-process (current-buffer))
|
||
(concat ":load " file))
|
||
(setq intero-repl-last-loaded file))
|
||
(comint-simple-send
|
||
(get-buffer-process (current-buffer))
|
||
":reload"))
|
||
(when intero-repl-send-after-load
|
||
(comint-simple-send
|
||
(get-buffer-process (current-buffer))
|
||
intero-repl-send-after-load))
|
||
(comint-simple-send (get-buffer-process (current-buffer))
|
||
":set prompt \"\\4 \""))))
|
||
|
||
(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))
|
||
text))))
|
||
|
||
(defun intero-repl (&optional prompt-options)
|
||
"Start up the REPL for this stack project.
|
||
If PROMPT-OPTIONS is non-nil, prompt with an options list."
|
||
(interactive "P")
|
||
(switch-to-buffer-other-window (intero-repl-buffer prompt-options t)))
|
||
|
||
(defun intero-repl-restart ()
|
||
"Restart the REPL."
|
||
(interactive)
|
||
(let* ((root (intero-project-root))
|
||
(package-name (intero-package-name))
|
||
(backend-buffer (intero-buffer 'backend))
|
||
(name (format "*intero:%s:%s:repl*"
|
||
(file-name-nondirectory root)
|
||
package-name)))
|
||
(when (get-buffer name)
|
||
(with-current-buffer (get-buffer name)
|
||
(goto-char (point-max))
|
||
(let ((process (get-buffer-process (current-buffer))))
|
||
(when process (kill-process process)))
|
||
(intero-repl-mode-start backend-buffer
|
||
(buffer-local-value 'intero-targets backend-buffer)
|
||
nil
|
||
(buffer-local-value 'intero-stack-yaml backend-buffer))))))
|
||
|
||
(defun intero-repl-buffer (prompt-options &optional store-previous)
|
||
"Start the REPL buffer.
|
||
If PROMPT-OPTIONS is non-nil, prompt with an options list. When
|
||
STORE-PREVIOUS is non-nil, note the caller's buffer in
|
||
`intero-repl-previous-buffer'."
|
||
(let* ((root (intero-project-root))
|
||
(package-name (intero-package-name))
|
||
(name (format "*intero:%s:%s:repl*"
|
||
(file-name-nondirectory root)
|
||
package-name))
|
||
(initial-buffer (current-buffer))
|
||
(backend-buffer (intero-buffer 'backend)))
|
||
(with-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))
|
||
(current-buffer)))))
|
||
|
||
(defvar intero-hyperlink-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(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.")
|
||
|
||
(define-derived-mode intero-repl-mode comint-mode "Intero-REPL"
|
||
"Interactive prompt for Intero."
|
||
(when (and (not (eq major-mode 'fundamental-mode))
|
||
(eq this-command 'intero-repl-mode))
|
||
(error "You probably meant to run: M-x intero-repl"))
|
||
(setq-local comint-prompt-regexp intero-prompt-regexp)
|
||
(setq-local warning-suppress-types (cons '(undo discard-info) warning-suppress-types))
|
||
(setq-local comint-prompt-read-only t)
|
||
(add-hook 'completion-at-point-functions 'intero-repl-completion-at-point nil t)
|
||
(company-mode))
|
||
|
||
(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.
|
||
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-targets targets)
|
||
(setq intero-repl-last-loaded nil)
|
||
(when stack-yaml
|
||
(setq intero-stack-yaml stack-yaml))
|
||
(when prompt-options
|
||
(intero-repl-options backend-buffer))
|
||
(let ((stack-yaml (if stack-yaml
|
||
stack-yaml
|
||
(buffer-local-value 'intero-stack-yaml backend-buffer)))
|
||
(arguments (intero-make-options-list
|
||
"ghci"
|
||
(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)
|
||
nil
|
||
stack-yaml)))
|
||
(insert (propertize
|
||
(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"))
|
||
(insert ":set prompt \"\"
|
||
:set -fbyte-code
|
||
:set -fdefer-type-errors
|
||
:set -fdiagnostics-color=never
|
||
:set prompt \"\\4 \"
|
||
")
|
||
(basic-save-buffer)
|
||
(current-buffer)))
|
||
(script
|
||
(with-current-buffer script-buffer
|
||
(intero-localize-path (intero-buffer-file-name)))))
|
||
(let ((process
|
||
(get-buffer-process
|
||
(apply #'make-comint-in-buffer "intero" (current-buffer) intero-stack-executable nil "ghci"
|
||
(append arguments
|
||
(list "--verbosity" "silent")
|
||
(list "--ghci-options"
|
||
(concat "-ghci-script=" script))
|
||
(cl-mapcan (lambda (x) (list "--ghci-options" x)) intero-extra-ghci-options))))))
|
||
(when (process-live-p process)
|
||
(set-process-query-on-exit-flag process nil)
|
||
(message "Started Intero process for REPL.")
|
||
(kill-buffer script-buffer))))))
|
||
|
||
(defun intero-repl-options (backend-buffer)
|
||
"Open an option menu to set options used when starting the REPL.
|
||
Default options come from user customization and any temporary
|
||
changes in the BACKEND-BUFFER."
|
||
(interactive)
|
||
(let* ((old-options
|
||
(list
|
||
(list :key "load-all"
|
||
:title "Load all modules"
|
||
:default (not (buffer-local-value 'intero-repl-no-load backend-buffer)))
|
||
(list :key "build-first"
|
||
:title "Build project first"
|
||
: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-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
|
||
'(("\\(\4\\)"
|
||
(0 (prog1 ()
|
||
(compose-region (match-beginning 1)
|
||
(match-end 1)
|
||
?λ))))))
|
||
|
||
(define-key intero-repl-mode-map [remap move-beginning-of-line] 'intero-repl-beginning-of-line)
|
||
(define-key intero-repl-mode-map [remap delete-backward-char] 'intero-repl-delete-backward-char)
|
||
(define-key intero-repl-mode-map (kbd "C-c C-k") 'intero-repl-clear-buffer)
|
||
(define-key intero-repl-mode-map (kbd "C-c C-z") 'intero-repl-switch-back)
|
||
|
||
(defun intero-repl-delete-backward-char ()
|
||
"Delete backwards, excluding the prompt."
|
||
(interactive)
|
||
(unless (looking-back intero-prompt-regexp (line-beginning-position))
|
||
(call-interactively 'delete-backward-char)))
|
||
|
||
(defun intero-repl-beginning-of-line ()
|
||
"Go to the beginning of the line, excluding the prompt."
|
||
(interactive)
|
||
(if (search-backward-regexp intero-prompt-regexp (line-beginning-position) t 1)
|
||
(goto-char (+ 2 (line-beginning-position)))
|
||
(call-interactively 'move-beginning-of-line)))
|
||
|
||
(defun intero-repl-switch-back ()
|
||
"Switch back to the buffer from which this REPL buffer was reached."
|
||
(interactive)
|
||
(if intero-repl-previous-buffer
|
||
(switch-to-buffer-other-window intero-repl-previous-buffer)
|
||
(message "No previous buffer.")))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Buffer operations
|
||
|
||
(defun intero-thing-at-point ()
|
||
"Return (list START END) of something at the point."
|
||
(if (region-active-p)
|
||
(list (region-beginning)
|
||
(region-end))
|
||
(let ((pos (intero-ident-pos-at-point)))
|
||
(if pos
|
||
(list (car pos) (cdr pos))
|
||
(list (point) (point))))))
|
||
|
||
(defun intero-ident-at-point ()
|
||
"Return the identifier under point, or nil if none found.
|
||
May return a qualified name."
|
||
(let ((reg (intero-ident-pos-at-point)))
|
||
(when reg
|
||
(buffer-substring-no-properties (car reg) (cdr reg)))))
|
||
|
||
(defun intero-ident-pos-at-point ()
|
||
"Return the span of the identifier near point going backward.
|
||
Returns nil if no identifier found or point is inside string or
|
||
comment. May return a qualified name."
|
||
(when (not (nth 8 (syntax-ppss)))
|
||
;; Do not handle comments and strings
|
||
(let (start end)
|
||
;; Initial point position is non-deterministic, it may occur anywhere
|
||
;; inside identifier span, so the approach is:
|
||
;; - first try go left and find left boundary
|
||
;; - then try go right and find right boundary
|
||
;;
|
||
;; In both cases assume the longest path, e.g. when going left take into
|
||
;; account than point may occur at the end of identifier, when going right
|
||
;; take into account that point may occur at the beginning of identifier.
|
||
;;
|
||
;; We should handle `.` character very careful because it is heavily
|
||
;; overloaded. Examples of possible cases:
|
||
;; Control.Monad.>>= -- delimiter
|
||
;; Control.Monad.when -- delimiter
|
||
;; Data.Aeson..: -- delimiter and operator symbol
|
||
;; concat.map -- composition function
|
||
;; .? -- operator symbol
|
||
(save-excursion
|
||
;; First, skip whitespace if we're on it, moving point to last
|
||
;; identifier char. That way, if we're at "map ", we'll see the word
|
||
;; "map".
|
||
(when (and (looking-at-p (rx eol))
|
||
(not (bolp)))
|
||
(backward-char))
|
||
(when (and (not (eobp))
|
||
(eq (char-syntax (char-after)) ? ))
|
||
(skip-chars-backward " \t")
|
||
(backward-char))
|
||
;; Now let's try to go left.
|
||
(save-excursion
|
||
(if (not (intero-mode--looking-at-varsym))
|
||
;; Looking at non-operator char, this is quite simple
|
||
(progn
|
||
(skip-syntax-backward "w_")
|
||
;; Remember position
|
||
(setq start (point)))
|
||
;; Looking at operator char.
|
||
(while (and (not (bobp))
|
||
(intero-mode--looking-at-varsym))
|
||
;; skip all operator chars backward
|
||
(setq start (point))
|
||
(backward-char))
|
||
;; Extra check for case when reached beginning of the buffer.
|
||
(when (intero-mode--looking-at-varsym)
|
||
(setq start (point))))
|
||
;; Slurp qualification part if present. If identifier is qualified in
|
||
;; case of non-operator point will stop before `.` dot, but in case of
|
||
;; operator it will stand at `.` delimiting dot. So if we're looking
|
||
;; at `.` let's step one char forward and try to get qualification
|
||
;; part.
|
||
(goto-char start)
|
||
(when (looking-at-p (rx "."))
|
||
(forward-char))
|
||
(let ((pos (intero-mode--skip-qualification-backward)))
|
||
(when pos
|
||
(setq start pos))))
|
||
;; Finally, let's try to go right.
|
||
(save-excursion
|
||
;; Try to slurp qualification part first.
|
||
(skip-syntax-forward "w_")
|
||
(setq end (point))
|
||
(while (and (looking-at-p (rx "." upper))
|
||
(not (zerop (progn (forward-char)
|
||
(skip-syntax-forward "w_")))))
|
||
(setq end (point)))
|
||
;; If point was at non-operator we already done, otherwise we need an
|
||
;; extra check.
|
||
(while (intero-mode--looking-at-varsym)
|
||
(forward-char)
|
||
(setq end (point))))
|
||
(when (not (= start end))
|
||
(cons start end))))))
|
||
|
||
(defun intero-mode--looking-at-varsym ()
|
||
"Return t when point stands at operator symbol."
|
||
(when (not (eobp))
|
||
(let ((lex (intero-lexeme-classify-by-first-char (char-after))))
|
||
(or (eq lex 'varsym)
|
||
(eq lex 'consym)))))
|
||
|
||
(defun intero-mode--skip-qualification-backward ()
|
||
"Skip qualified part of identifier backward.
|
||
Expects point stands *after* delimiting dot.
|
||
Returns beginning position of qualified part or nil if no qualified part found."
|
||
(when (not (and (bobp)
|
||
(looking-at-p (rx bol))))
|
||
(let ((case-fold-search nil)
|
||
pos)
|
||
(while (and (eq (char-before) ?.)
|
||
(progn (backward-char)
|
||
(not (zerop (skip-syntax-backward "w'"))))
|
||
(skip-syntax-forward "'")
|
||
(looking-at-p "[[:upper:]]"))
|
||
(setq pos (point)))
|
||
pos)))
|
||
|
||
(defun intero-lexeme-classify-by-first-char (char)
|
||
"Classify token by CHAR.
|
||
CHAR is a chararacter that is assumed to be the first character
|
||
of a token."
|
||
(let ((category (get-char-code-property char 'general-category)))
|
||
|
||
(cond
|
||
((or (member char '(?! ?# ?$ ?% ?& ?* ?+ ?. ?/ ?< ?= ?> ?? ?@ ?^ ?| ?~ ?\\ ?-))
|
||
(and (> char 127)
|
||
(member category '(Pc Pd Po Sm Sc Sk So))))
|
||
'varsym)
|
||
((equal char ?:)
|
||
'consym)
|
||
((equal char ?\')
|
||
'char)
|
||
((equal char ?\")
|
||
'string)
|
||
((member category '(Lu Lt))
|
||
'conid)
|
||
((or (equal char ?_)
|
||
(member category '(Ll Lo)))
|
||
'varid)
|
||
((and (>= char ?0) (<= char ?9))
|
||
'number)
|
||
((member char '(?\] ?\[ ?\( ?\) ?\{ ?\} ?\` ?\, ?\;))
|
||
'special))))
|
||
|
||
(defun intero-buffer-file-name (&optional buffer)
|
||
"Call function `buffer-file-name' for BUFFER and clean its result.
|
||
The path returned is canonicalized and stripped of any text properties."
|
||
(let ((name (buffer-file-name buffer)))
|
||
(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))
|
||
(expand-file-name 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
|
||
(expand-file-name
|
||
(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'
|
||
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
|
||
(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 pertaining to BUFFER."
|
||
(with-current-buffer (or buffer (current-buffer))
|
||
(or intero-temp-file-name
|
||
(progn (setq intero-temp-file-name
|
||
(intero-canonicalize-path
|
||
(intero-make-temp-file
|
||
"intero" nil
|
||
(concat "-TEMP." (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))))
|
||
|
||
(defun intero-staging-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))
|
||
(let* ((contents (buffer-string))
|
||
(fname (intero-canonicalize-path
|
||
(intero-make-temp-file
|
||
"intero" nil
|
||
(concat "-STAGING." (if (buffer-file-name)
|
||
(file-name-extension (buffer-file-name))
|
||
"hs"))))))
|
||
(with-temp-file fname
|
||
(insert contents))
|
||
fname)))
|
||
|
||
(defun intero-quote-path-for-ghci (path)
|
||
"Quote PATH as necessary so that it can be passed to a GHCi :command."
|
||
(concat "\"" (replace-regexp-in-string "\\([\\\"]\\)" "\\\\\\1" path nil nil) "\""))
|
||
|
||
(defun intero-path-for-ghci (path)
|
||
"Turn a possibly-remote PATH into one that can be passed to a GHCi :command."
|
||
(intero-quote-path-for-ghci (intero-localize-path path)))
|
||
|
||
(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.
|
||
Path names are standardised and drive names are
|
||
capitalized (relevant on Windows)."
|
||
(intero-capitalize-drive-letter (convert-standard-filename path)))
|
||
|
||
(defun intero-capitalize-drive-letter (path)
|
||
"Ensures the drive letter is capitalized in PATH.
|
||
This applies to paths of the form
|
||
x:\\foo\\bar (i.e., Windows)."
|
||
(save-match-data
|
||
(let ((drive-path (split-string path ":\\\\")))
|
||
(if (or (null (car drive-path)) (null (cdr drive-path)))
|
||
path
|
||
(concat (upcase (car drive-path)) ":\\" (cadr drive-path))))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Query/commands
|
||
|
||
(defun intero-get-all-types ()
|
||
"Get all types in all expressions in all modules."
|
||
(intero-blocking-network-call 'backend ":all-types"))
|
||
|
||
(defun intero-get-type-at (beg end)
|
||
"Get the type at the given region denoted by BEG and END."
|
||
(let ((result (intero-get-type-at-helper beg end)))
|
||
(if (string-match (regexp-quote "Couldn't guess that module name. Does it exist?")
|
||
result)
|
||
(progn (flycheck-buffer)
|
||
(message "No type information yet, compiling module ...")
|
||
(intero-get-type-at-helper-process beg end))
|
||
result)))
|
||
|
||
(defun intero-get-type-at-helper (beg end)
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-network-call
|
||
'backend
|
||
(intero-format-get-type-at beg end))))
|
||
|
||
(defun intero-get-type-at-helper-process (beg end)
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-call
|
||
'backend
|
||
(intero-format-get-type-at beg end))))
|
||
|
||
(defun intero-get-type-at-async (cont beg end)
|
||
"Call CONT with type of the region denoted by BEG and END.
|
||
CONT is called within the current buffer, with BEG, END and the
|
||
type as arguments."
|
||
(intero-async-network-call
|
||
'backend
|
||
(intero-format-get-type-at beg end)
|
||
(list :cont cont
|
||
:source-buffer (current-buffer)
|
||
:beg beg
|
||
:end end)
|
||
(lambda (state reply)
|
||
(with-current-buffer (plist-get state :source-buffer)
|
||
(funcall (plist-get state :cont)
|
||
(plist-get state :beg)
|
||
(plist-get state :end)
|
||
(replace-regexp-in-string "\n$" "" reply))))))
|
||
|
||
(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-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column)))
|
||
(save-excursion (goto-char end)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char end)
|
||
(1+ (current-column)))
|
||
(buffer-substring-no-properties beg end)))
|
||
|
||
(defun intero-get-info-of (thing)
|
||
"Get info for THING."
|
||
(let ((optimistic-result
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-call
|
||
'backend
|
||
(format ":info %s" thing)))))
|
||
(if (string-match-p "^<interactive>" optimistic-result)
|
||
;; Load the module Interpreted so that we get information,
|
||
;; then restore bytecode.
|
||
(progn (intero-async-call
|
||
'backend
|
||
":set -fbyte-code")
|
||
(set-buffer-modified-p t)
|
||
(save-buffer)
|
||
(unless (member 'save flycheck-check-syntax-automatically)
|
||
(intero-async-call
|
||
'backend
|
||
(concat ":load " (intero-path-for-ghci (intero-temp-file-name)))))
|
||
(intero-async-call
|
||
'backend
|
||
":set -fobject-code")
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-call
|
||
'backend
|
||
(format ":info %s" thing))))
|
||
optimistic-result)))
|
||
|
||
(defconst intero-unloaded-module-string "Couldn't guess that module name. Does it exist?")
|
||
|
||
(defun intero-get-loc-at (beg end)
|
||
"Get the location of the identifier denoted by BEG and END."
|
||
(let ((result (intero-get-loc-at-helper beg end)))
|
||
(if (string-match (regexp-quote intero-unloaded-module-string)
|
||
result)
|
||
(progn (flycheck-buffer)
|
||
(message "No location information yet, compiling module ...")
|
||
(intero-get-loc-at-helper-process beg end))
|
||
result)))
|
||
|
||
(defun intero-get-loc-at-helper (beg end)
|
||
"Make the blocking call to the process."
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-network-call
|
||
'backend
|
||
(format ":loc-at %s %d %d %d %d %S"
|
||
(intero-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column)))
|
||
(save-excursion (goto-char end)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char end)
|
||
(1+ (current-column)))
|
||
(buffer-substring-no-properties beg end)))))
|
||
|
||
(defun intero-get-loc-at-helper-process (beg end)
|
||
"Make the blocking call to the process."
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-call
|
||
'backend
|
||
(format ":loc-at %s %d %d %d %d %S"
|
||
(intero-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column)))
|
||
(save-excursion (goto-char end)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char end)
|
||
(1+ (current-column)))
|
||
(buffer-substring-no-properties beg end)))))
|
||
|
||
(defun intero-get-uses-at (beg end)
|
||
"Return usage list for identifier denoted by BEG and END."
|
||
(let ((result (intero-get-uses-at-helper beg end)))
|
||
(if (string-match (regexp-quote intero-unloaded-module-string)
|
||
result)
|
||
(progn (flycheck-buffer)
|
||
(message "No use information yet, compiling module ...")
|
||
(intero-get-uses-at-helper-process beg end))
|
||
result)))
|
||
|
||
(defun intero-get-uses-at-helper (beg end)
|
||
"Return usage list for identifier denoted by BEG and END."
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-network-call
|
||
'backend
|
||
(format ":uses %s %d %d %d %d %S"
|
||
(intero-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column)))
|
||
(save-excursion (goto-char end)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char end)
|
||
(1+ (current-column)))
|
||
(buffer-substring-no-properties beg end)))))
|
||
|
||
(defun intero-get-uses-at-helper-process (beg end)
|
||
"Return usage list for identifier denoted by BEG and END."
|
||
(replace-regexp-in-string
|
||
"\n$" ""
|
||
(intero-blocking-call
|
||
'backend
|
||
(format ":uses %s %d %d %d %d %S"
|
||
(intero-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column)))
|
||
(save-excursion (goto-char end)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char end)
|
||
(1+ (current-column)))
|
||
(buffer-substring-no-properties beg end)))))
|
||
|
||
(defun intero-get-completions (source-buffer beg end cont)
|
||
"Get completions and send to SOURCE-BUFFER.
|
||
Prefix is marked by positions BEG and END. Completions are
|
||
passed to CONT in SOURCE-BUFFER."
|
||
(intero-async-network-call
|
||
'backend
|
||
(format ":complete-at %s %d %d %d %d %S"
|
||
(intero-path-for-ghci (intero-temp-file-name))
|
||
(save-excursion (goto-char beg)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char beg)
|
||
(1+ (current-column)))
|
||
(save-excursion (goto-char end)
|
||
(line-number-at-pos))
|
||
(save-excursion (goto-char end)
|
||
(1+ (current-column)))
|
||
(buffer-substring-no-properties beg end))
|
||
(list :cont cont :source-buffer source-buffer)
|
||
(lambda (state reply)
|
||
(with-current-buffer
|
||
(plist-get state :source-buffer)
|
||
(funcall
|
||
(plist-get state :cont)
|
||
(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-p "^*** 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.
|
||
Completions for PREFIX are passed to CONT in SOURCE-BUFFER."
|
||
(intero-async-call
|
||
'backend
|
||
(format ":complete repl %S" prefix)
|
||
(list :cont cont :source-buffer source-buffer)
|
||
(lambda (state reply)
|
||
(with-current-buffer
|
||
(plist-get state :source-buffer)
|
||
(funcall
|
||
(plist-get state :cont)
|
||
(mapcar
|
||
(lambda (x)
|
||
(replace-regexp-in-string "\\\"" "" x))
|
||
(cdr (split-string reply "\n" t))))))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; 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)
|
||
(with-current-buffer (intero-get-buffer-create worker)
|
||
(when (get-buffer-process (current-buffer))
|
||
(setq intero-deleting t)
|
||
(kill-process (get-buffer-process (current-buffer)))
|
||
(delete-process (get-buffer-process (current-buffer))))
|
||
(kill-buffer (current-buffer)))))
|
||
|
||
(defun intero-blocking-call (worker cmd)
|
||
"Send WORKER the command string CMD and block pending its result."
|
||
(let ((result (list nil)))
|
||
(intero-async-call
|
||
worker
|
||
cmd
|
||
result
|
||
(lambda (result reply)
|
||
(setf (car result) reply)))
|
||
(let ((buffer (intero-buffer worker)))
|
||
(while (not (null (buffer-local-value 'intero-callbacks buffer)))
|
||
(sleep-for 0.0001)))
|
||
(car result)))
|
||
|
||
(defun intero-blocking-network-call (worker cmd)
|
||
"Send WORKER the command string CMD via the network and block pending its result."
|
||
(let ((result (list nil)))
|
||
(intero-async-network-call
|
||
worker
|
||
cmd
|
||
result
|
||
(lambda (result reply)
|
||
(setf (car result) reply)))
|
||
(while (eq (car result) nil)
|
||
(sleep-for 0.0001))
|
||
(car result)))
|
||
|
||
(defun intero-async-network-call (worker cmd &optional state callback)
|
||
"Send WORKER the command string CMD, via a network connection.
|
||
The result, along with the given STATE, is passed to CALLBACK
|
||
as (CALLBACK STATE REPLY)."
|
||
(if (file-remote-p default-directory)
|
||
(intero-async-call worker cmd state callback)
|
||
(let ((buffer (intero-buffer worker)))
|
||
(if (and buffer (process-live-p (get-buffer-process buffer)))
|
||
(with-current-buffer buffer
|
||
(if intero-service-port
|
||
(let* ((buffer (generate-new-buffer (format " intero-network:%S" worker)))
|
||
(process
|
||
(make-network-process
|
||
:name (format "%S" worker)
|
||
:buffer buffer
|
||
:host 'local
|
||
:service intero-service-port
|
||
:family 'ipv4
|
||
:nowait t
|
||
:noquery t
|
||
:sentinel 'intero-network-call-sentinel)))
|
||
(with-current-buffer buffer
|
||
(setq intero-async-network-cmd cmd)
|
||
(setq intero-async-network-state state)
|
||
(setq intero-async-network-worker worker)
|
||
(setq intero-async-network-callback callback)))
|
||
(progn (when intero-debug (message "No `intero-service-port', falling back ..."))
|
||
(intero-async-call worker cmd state callback))))
|
||
(error "Intero process is not running: run M-x intero-restart to start it")))))
|
||
|
||
(defun intero-network-call-sentinel (process event)
|
||
(pcase event
|
||
;; This event sometimes gets sent when (delete-process) is called, but
|
||
;; inconsistently. We can't rely on it for killing buffers, but we need to
|
||
;; handle the possibility.
|
||
("deleted\n")
|
||
|
||
("open\n"
|
||
(with-current-buffer (process-buffer process)
|
||
(when intero-debug (message "Connected to service, sending %S" intero-async-network-cmd))
|
||
(setq intero-async-network-connected t)
|
||
(if intero-async-network-cmd
|
||
(process-send-string process (concat intero-async-network-cmd "\n"))
|
||
(delete-process process)
|
||
(kill-buffer (process-buffer process)))))
|
||
(_
|
||
(with-current-buffer (process-buffer process)
|
||
(if intero-async-network-connected
|
||
(when intero-async-network-callback
|
||
(when intero-debug (message "Calling callback with %S" (buffer-string)))
|
||
(funcall intero-async-network-callback
|
||
intero-async-network-state
|
||
(buffer-string)))
|
||
;; We didn't successfully connect, so let's fallback to the
|
||
;; process pipe.
|
||
(when intero-async-network-callback
|
||
(when intero-debug (message "Failed to connect, falling back ... "))
|
||
(setq intero-async-network-callback nil)
|
||
(intero-async-call
|
||
intero-async-network-worker
|
||
intero-async-network-cmd
|
||
intero-async-network-state
|
||
intero-async-network-callback))))
|
||
(delete-process process)
|
||
(kill-buffer (process-buffer process)))))
|
||
|
||
(defun intero-async-call (worker cmd &optional state callback)
|
||
"Send WORKER the command string CMD.
|
||
The result, along with the given STATE, is passed to CALLBACK
|
||
as (CALLBACK STATE REPLY)."
|
||
(let ((buffer (intero-buffer worker)))
|
||
(if (and buffer (process-live-p (get-buffer-process buffer)))
|
||
(progn (with-current-buffer buffer
|
||
(setq intero-callbacks
|
||
(append intero-callbacks
|
||
(list (list state
|
||
(or callback #'ignore)
|
||
cmd)))))
|
||
(when intero-debug
|
||
(message "[Intero] -> %s" cmd))
|
||
(comint-simple-send (intero-process worker) cmd))
|
||
(error "Intero process is not running: run M-x intero-restart to start it"))))
|
||
|
||
(defun intero-buffer (worker)
|
||
"Get the WORKER buffer for the current directory."
|
||
(let ((buffer (intero-get-buffer-create worker))
|
||
(targets (buffer-local-value 'intero-targets (current-buffer))))
|
||
(if (get-buffer-process buffer)
|
||
buffer
|
||
(intero-get-worker-create worker targets (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 stack-yaml)
|
||
"Start the given WORKER.
|
||
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 stack-yaml)
|
||
(intero-auto-install buffer install-status targets source-buffer stack-yaml))))))
|
||
|
||
(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, SOURCE-BUFFER and STACK-YAML."
|
||
(if (buffer-local-value 'intero-give-up buffer)
|
||
buffer
|
||
(let ((source-buffer (or source-buffer (current-buffer))))
|
||
(switch-to-buffer buffer)
|
||
(erase-buffer)
|
||
(insert (cl-case install-status
|
||
(not-installed "Intero is not installed in the Stack environment.")
|
||
(wrong-version "The wrong version of Intero is installed for this Emacs package.")))
|
||
(if (intero-version>= (intero-stack-version) '(1 6 1))
|
||
(intero-copy-compiler-tool-auto-install source-buffer targets buffer)
|
||
(intero-old-auto-install source-buffer targets buffer stack-yaml)))))
|
||
|
||
(defun intero-copy-compiler-tool-auto-install (source-buffer targets buffer)
|
||
"Automatically install Intero appropriately for BUFFER.
|
||
Use the given TARGETS, SOURCE-BUFFER and STACK-YAML."
|
||
(let ((ghc-version (intero-ghc-version-raw)))
|
||
(insert
|
||
(format "
|
||
|
||
Installing intero-%s for GHC %s ...
|
||
|
||
" intero-package-version ghc-version))
|
||
(redisplay)
|
||
(cl-case
|
||
(let ((default-directory (make-temp-file "intero" t)))
|
||
(intero-call-stack
|
||
nil (current-buffer) t nil "build"
|
||
"--copy-compiler-tool"
|
||
(concat "intero-" intero-package-version)
|
||
"--flag" "haskeline:-terminfo"
|
||
"--resolver" (concat "ghc-" ghc-version)
|
||
"ghc-paths-0.1.0.9" "mtl-2.2.2" "network-2.7.0.0" "random-1.1" "syb-0.7"))
|
||
(0
|
||
(message "Installed successfully! Starting Intero in a moment ...")
|
||
(bury-buffer buffer)
|
||
(switch-to-buffer source-buffer)
|
||
(intero-start-process-in-buffer buffer targets source-buffer))
|
||
(1
|
||
(with-current-buffer buffer (setq-local intero-give-up t))
|
||
(insert (propertize "Could not install Intero!
|
||
|
||
We don't know why it failed. Please read the above output and try
|
||
installing manually. If that doesn't work, report this as a
|
||
problem.
|
||
|
||
WHAT TO DO NEXT
|
||
|
||
If you don't want to Intero to try installing itself again for
|
||
this project, just keep this buffer around in your Emacs.
|
||
|
||
If you'd like to try again next time you try use an Intero
|
||
feature, kill this buffer.
|
||
"
|
||
'face 'compilation-error))
|
||
nil))))
|
||
|
||
(defun intero-old-auto-install (source-buffer targets buffer stack-yaml)
|
||
"Automatically install Intero appropriately for BUFFER.
|
||
Use the given TARGETS, SOURCE-BUFFER and STACK-YAML."
|
||
(insert
|
||
"
|
||
|
||
Installing intero-%s automatically ...
|
||
|
||
" intero-package-version)
|
||
(redisplay)
|
||
(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"
|
||
"--flag" "haskeline:-terminfo")
|
||
(0
|
||
(message "Installed successfully! Starting Intero in a moment ...")
|
||
(bury-buffer buffer)
|
||
(switch-to-buffer source-buffer)
|
||
(intero-start-process-in-buffer buffer targets source-buffer))
|
||
(1
|
||
(with-current-buffer buffer (setq-local intero-give-up t))
|
||
(insert (propertize "Could not install Intero!
|
||
|
||
We don't know why it failed. Please read the above output and try
|
||
installing manually. If that doesn't work, report this as a
|
||
problem.
|
||
|
||
WHAT TO DO NEXT
|
||
|
||
If you don't want to Intero to try installing itself again for
|
||
this project, just keep this buffer around in your Emacs.
|
||
|
||
If you'd like to try again next time you try use an Intero
|
||
feature, kill this buffer.
|
||
"
|
||
'face 'compilation-error))
|
||
nil)))
|
||
|
||
(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
|
||
(intero-make-options-list
|
||
(intero-executable-path stack-yaml)
|
||
(or targets
|
||
(let ((package-name (buffer-local-value 'intero-package-name buffer)))
|
||
(unless (equal "" package-name)
|
||
(list package-name))))
|
||
(not (buffer-local-value 'intero-try-with-build buffer))
|
||
t ;; pass --no-load to stack
|
||
t ;; pass -ignore-dot-ghci to intero
|
||
stack-yaml ;; let stack choose a default when nil
|
||
))
|
||
(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-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 -fdefer-type-errors\n")
|
||
(process-send-string process ":set -fdiagnostics-color=never\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)
|
||
(setq intero-callbacks
|
||
(list (list (cons source-buffer
|
||
buffer)
|
||
(lambda (buffers msg)
|
||
(let ((source-buffer (car buffers))
|
||
(process-buffer (cdr buffers)))
|
||
(with-current-buffer process-buffer
|
||
(when (string-match "^Intero-Service-Port: \\([0-9]+\\)\n" msg)
|
||
(setq intero-service-port (string-to-number (match-string 1 msg))))
|
||
(setq-local intero-starting nil))
|
||
(when source-buffer
|
||
(with-current-buffer source-buffer
|
||
(when flycheck-mode
|
||
(run-with-timer 0 nil
|
||
'intero-call-in-buffer
|
||
(current-buffer)
|
||
'intero-flycheck-buffer)))))
|
||
(message "Booted up intero!"))))))
|
||
(set-process-filter
|
||
process
|
||
(lambda (process string)
|
||
(when intero-debug
|
||
(message "[Intero] <- %s" string))
|
||
(when (buffer-live-p (process-buffer process))
|
||
(with-current-buffer (process-buffer process)
|
||
(goto-char (point-max))
|
||
(insert string)
|
||
(when (and intero-try-with-build
|
||
intero-starting)
|
||
(let ((last-line (buffer-substring-no-properties
|
||
(line-beginning-position)
|
||
(line-end-position))))
|
||
(if (string-match-p "^Progress" last-line)
|
||
(message "Booting up intero (building dependencies: %s)"
|
||
(downcase
|
||
(or (car (split-string (replace-regexp-in-string
|
||
"\u0008+" "\n"
|
||
last-line)
|
||
"\n" t))
|
||
"...")))
|
||
(message "Booting up intero ..."))))
|
||
(intero-read-buffer)))))
|
||
(set-process-sentinel process 'intero-sentinel)
|
||
buffer)))
|
||
|
||
(defun intero-flycheck-buffer ()
|
||
"Run flycheck in the buffer.
|
||
Restarts flycheck in case there was a problem and flycheck is stuck."
|
||
(flycheck-mode -1)
|
||
(flycheck-mode)
|
||
(flycheck-buffer))
|
||
|
||
(defun intero-make-options-list (with-ghc 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. 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"
|
||
with-ghc
|
||
"--docker-run-args=--interactive=true --tty=false"
|
||
)
|
||
(when no-build
|
||
(list "--no-build"))
|
||
(when no-load
|
||
(list "--no-load"))
|
||
(when ignore-dot-ghci
|
||
(list "--ghci-options" "-ignore-dot-ghci"))
|
||
(cl-mapcan (lambda (x) (list "--ghci-options" x)) intero-extra-ghc-options)
|
||
targets))
|
||
|
||
(defun intero-sentinel (process change)
|
||
"Handle when PROCESS reports a CHANGE.
|
||
This is a standard process sentinel function."
|
||
(when (buffer-live-p (process-buffer process))
|
||
(when (and (not (process-live-p process)))
|
||
(let ((buffer (process-buffer process)))
|
||
(if (with-current-buffer buffer intero-deleting)
|
||
(message "Intero process deleted.")
|
||
(if (and (intero-unsatisfied-package-p buffer)
|
||
(not (buffer-local-value 'intero-try-with-build buffer)))
|
||
(progn (with-current-buffer buffer (setq-local intero-try-with-build t))
|
||
(intero-start-process-in-buffer
|
||
buffer
|
||
(buffer-local-value 'intero-targets buffer)
|
||
(buffer-local-value 'intero-source-buffer buffer)))
|
||
(progn (with-current-buffer buffer (setq-local intero-give-up t))
|
||
(intero-show-process-problem process change))))))))
|
||
|
||
(defun intero-unsatisfied-package-p (buffer)
|
||
"Return non-nil if BUFFER contain GHCi's unsatisfied package complaint."
|
||
(with-current-buffer buffer
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(search-forward-regexp "cannot satisfy -package" nil t 1))))
|
||
|
||
(defun intero-executable-path (stack-yaml)
|
||
"The path for the intero executable."
|
||
(intero-with-temp-buffer
|
||
(cl-case (save-excursion
|
||
(intero-call-stack
|
||
nil (current-buffer) t intero-stack-yaml "path" "--compiler-tools-bin"))
|
||
(0 (replace-regexp-in-string "[\r\n]+$" "/intero" (buffer-string)))
|
||
(1 "intero"))))
|
||
|
||
(defun intero-installed-p ()
|
||
"Return non-nil if intero (of the right version) is installed in the stack environment."
|
||
(redisplay)
|
||
(intero-with-temp-buffer
|
||
(if (= 0 (intero-call-stack
|
||
nil t nil intero-stack-yaml
|
||
"exec"
|
||
"--verbosity" "silent"
|
||
"--"
|
||
(intero-executable-path intero-stack-yaml)
|
||
"--version"))
|
||
(progn
|
||
(goto-char (point-min))
|
||
;; This skipping comes due to https://github.com/commercialhaskell/intero/pull/216/files
|
||
(when (looking-at "Intero ")
|
||
(goto-char (match-end 0)))
|
||
;;
|
||
(if (string= (buffer-substring (point) (line-end-position))
|
||
intero-package-version)
|
||
'installed
|
||
'wrong-version))
|
||
'not-installed)))
|
||
|
||
(defun intero-show-process-problem (process change)
|
||
"Report to the user that PROCESS reported CHANGE, causing it to end."
|
||
(message "Problem with Intero!")
|
||
(switch-to-buffer (process-buffer process))
|
||
(goto-char (point-max))
|
||
(insert "\n---\n\n")
|
||
(insert
|
||
(propertize
|
||
(concat
|
||
"This is the buffer where Emacs talks to intero. It's normally hidden,
|
||
but a problem occcured.
|
||
|
||
TROUBLESHOOTING
|
||
|
||
It may be obvious if there is some text above this message
|
||
indicating a problem.
|
||
|
||
If you do not wish to use Intero for some projects, see
|
||
https://github.com/commercialhaskell/intero#whitelistingblacklisting-projects
|
||
|
||
The process ended. Here is the reason that Emacs gives us:
|
||
|
||
"
|
||
" " change
|
||
"\n"
|
||
"For troubleshooting purposes, here are the arguments used to launch intero:
|
||
|
||
"
|
||
(format " %s %s"
|
||
intero-stack-executable
|
||
(combine-and-quote-strings intero-arguments))
|
||
|
||
"
|
||
|
||
It's worth checking that the correct stack executable is being
|
||
found on your path, or has been set via
|
||
`intero-stack-executable'. The executable being used now is:
|
||
|
||
"
|
||
(executable-find intero-stack-executable)
|
||
"
|
||
|
||
WHAT TO DO NEXT
|
||
|
||
If you fixed the problem, just kill this buffer, Intero will make
|
||
a fresh one and attempt to start the process automatically as
|
||
soon as you start editing code again.
|
||
|
||
If you are unable to fix the problem, just leave this buffer
|
||
around in Emacs and Intero will not attempt to start the process
|
||
anymore.
|
||
|
||
You can always run M-x intero-restart to make it try again.
|
||
|
||
")
|
||
'face 'compilation-error)))
|
||
|
||
(defun intero-read-buffer ()
|
||
"In the process buffer, we read what's in it."
|
||
(let ((repeat t))
|
||
(while repeat
|
||
(setq repeat nil)
|
||
(goto-char (point-min))
|
||
(when (search-forward "\4" (point-max) t 1)
|
||
(let* ((next-callback (pop intero-callbacks))
|
||
(state (nth 0 next-callback))
|
||
(func (nth 1 next-callback)))
|
||
(let ((string (intero-strip-carriage-returns (buffer-substring (point-min) (1- (point))))))
|
||
(if next-callback
|
||
(progn (intero-with-temp-buffer
|
||
(funcall func state string))
|
||
(setq repeat t))
|
||
(when intero-debug
|
||
(intero--warn "Received output but no callback in `intero-callbacks': %S"
|
||
string)))))
|
||
(delete-region (point-min) (point))))))
|
||
|
||
(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-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))))
|
||
|
||
(defun intero-gave-up (worker)
|
||
"Return non-nil if starting WORKER or installing intero failed."
|
||
(and (intero-buffer-p worker)
|
||
(let ((buffer (get-buffer (intero-buffer-name worker))))
|
||
(buffer-local-value 'intero-give-up buffer))))
|
||
|
||
(defun intero-buffer-p (worker)
|
||
"Return non-nil if a buffer exists for WORKER."
|
||
(get-buffer (intero-buffer-name worker)))
|
||
|
||
(defun intero-buffer-name (worker)
|
||
"For a given WORKER, create a buffer name."
|
||
(let* ((root (intero-project-root))
|
||
(package-name (intero-package-name)))
|
||
(concat " intero:"
|
||
(format "%s" worker)
|
||
":"
|
||
package-name
|
||
" "
|
||
root)))
|
||
|
||
(defun intero-project-root ()
|
||
"Get the current stack config directory.
|
||
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
|
||
(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.
|
||
|
||
If you do not wish to use Intero for some projects, see
|
||
https://github.com/commercialhaskell/intero#whitelistingblacklisting-projects
|
||
|
||
Otherwise, please report this as a bug!
|
||
|
||
For debugging purposes, try running the following in your terminal:
|
||
|
||
%s path --project-root" intero-stack-executable)
|
||
nil)))))))
|
||
|
||
(defun intero-ghc-version ()
|
||
"Get the GHC version used by the project, calls only once per backend."
|
||
(with-current-buffer (intero-buffer 'backend)
|
||
(or intero-ghc-version
|
||
(setq intero-ghc-version
|
||
(intero-ghc-version-raw)))))
|
||
|
||
(defun intero-ghc-version-raw ()
|
||
"Get the GHC version used by the project."
|
||
(intero-with-temp-buffer
|
||
(cl-case (save-excursion
|
||
(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-version>= (new0 old0)
|
||
"Is the version NEW >= OLD?"
|
||
(or (and (null new0) (null old0))
|
||
(let ((new (or new0 (list 0)))
|
||
(old (or old0 (list 0))))
|
||
(or (> (car new)
|
||
(car old))
|
||
(and (= (car new)
|
||
(car old))
|
||
(intero-version>= (cdr new)
|
||
(cdr old)))))))
|
||
|
||
(defun intero-stack-version ()
|
||
"Get the version components of stack."
|
||
(let* ((str (intero-stack-version-raw))
|
||
(parts (mapcar #'string-to-number (split-string str "\\."))))
|
||
parts))
|
||
|
||
(defun intero-stack-version-raw ()
|
||
"Get the Stack version in PATH."
|
||
(intero-with-temp-buffer
|
||
(cl-case (save-excursion
|
||
(intero-call-stack
|
||
nil (current-buffer) t intero-stack-yaml "--numeric-version"))
|
||
(0
|
||
(buffer-substring (line-beginning-position) (line-end-position)))
|
||
(1 nil))))
|
||
|
||
(defun intero-get-targets ()
|
||
"Get all available targets."
|
||
(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-p "^[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.
|
||
If there is none, return an empty string. If specified, use
|
||
CABAL-FILE rather than trying to locate one."
|
||
(or intero-package-name
|
||
(setq intero-package-name
|
||
(let ((cabal-file (or cabal-file
|
||
(intero-cabal-find-file))))
|
||
(if cabal-file
|
||
(replace-regexp-in-string
|
||
".cabal$" ""
|
||
(file-name-nondirectory cabal-file))
|
||
"")))))
|
||
|
||
(defun intero-cabal-find-file (&optional dir)
|
||
"Search for package description file upwards starting from DIR.
|
||
If DIR is nil, `default-directory' is used as starting point for
|
||
directory traversal. Upward traversal is aborted if file owner
|
||
changes. Uses `intero-cabal-find-pkg-desc' internally."
|
||
(let ((use-dir (or dir default-directory)))
|
||
(while (and use-dir (not (file-directory-p use-dir)))
|
||
(setq use-dir (file-name-directory (directory-file-name use-dir))))
|
||
(when use-dir
|
||
(catch 'found
|
||
(let ((user (nth 2 (file-attributes use-dir)))
|
||
;; Abbreviate, so as to stop when we cross ~/.
|
||
(root (abbreviate-file-name use-dir)))
|
||
;; traverse current dir up to root as long as file owner doesn't change
|
||
(while (and root (equal user (nth 2 (file-attributes root))))
|
||
(let ((cabal-file (intero-cabal-find-pkg-desc root)))
|
||
(when cabal-file
|
||
(throw 'found cabal-file)))
|
||
|
||
(let ((proot (file-name-directory (directory-file-name root))))
|
||
(if (equal proot root) ;; fix-point reached?
|
||
(throw 'found nil)
|
||
(setq root proot))))
|
||
nil)))))
|
||
|
||
(defun intero-cabal-find-pkg-desc (dir &optional allow-multiple)
|
||
"Find a package description file in the directory DIR.
|
||
Returns nil if none or multiple \".cabal\" files were found. If
|
||
ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files,
|
||
a list is returned instead of failing with a nil result."
|
||
;; This is basically a port of Cabal's
|
||
;; Distribution.Simple.Utils.findPackageDesc function
|
||
;; http://hackage.haskell.org/packages/archive/Cabal/1.16.0.3/doc/html/Distribution-Simple-Utils.html
|
||
;; but without the exception throwing.
|
||
(let* ((cabal-files
|
||
(cl-remove-if (lambda (path)
|
||
(or (file-directory-p path)
|
||
(not (file-exists-p path))))
|
||
(directory-files dir t ".\\.cabal\\'" t))))
|
||
(cond
|
||
((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found
|
||
(allow-multiple cabal-files) ;; pass-thru multiple candidates
|
||
(t nil))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Multiselection
|
||
|
||
(defvar intero-multiswitch-keymap
|
||
(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))
|
||
|
||
(defun intero-multiswitch (title options)
|
||
"Displaying TITLE, read multiple flags from a list of OPTIONS.
|
||
Each option is a plist of (:key :default :title) wherein:
|
||
|
||
:key should be something comparable with EQUAL
|
||
:title should be a string
|
||
:default (boolean) specifies the default checkedness"
|
||
(let ((available-width (window-total-width)))
|
||
(save-window-excursion
|
||
(intero-with-temp-buffer
|
||
(rename-buffer (generate-new-buffer-name "multiswitch"))
|
||
(widget-insert (concat title "\n\n"))
|
||
(widget-insert (propertize "Select options with RET, hit " 'face 'font-lock-comment-face))
|
||
(widget-create 'push-button :notify
|
||
(lambda (&rest ignore)
|
||
(exit-recursive-edit))
|
||
"C-c C-c")
|
||
(widget-insert (propertize " to apply these choices, or hit " 'face 'font-lock-comment-face))
|
||
(widget-create 'push-button :notify
|
||
(lambda (&rest ignore)
|
||
(abort-recursive-edit))
|
||
"C-c C-k")
|
||
(widget-insert (propertize " to cancel.\n\n" 'face 'font-lock-comment-face))
|
||
(let* ((me (current-buffer))
|
||
(choices (mapcar (lambda (option)
|
||
(append option (list :value (plist-get option :default))))
|
||
options)))
|
||
(cl-loop for option in choices
|
||
do (widget-create
|
||
'toggle
|
||
:notify (lambda (widget &rest ignore)
|
||
(setq choices
|
||
(mapcar (lambda (choice)
|
||
(if (equal (plist-get choice :key)
|
||
(plist-get (cdr widget) :key))
|
||
(plist-put choice :value (plist-get (cdr widget) :value))
|
||
choice))
|
||
choices)))
|
||
:on (concat "[x] " (plist-get option :title))
|
||
:off (concat "[ ] " (plist-get option :title))
|
||
:value (plist-get option :default)
|
||
:key (plist-get option :key)))
|
||
(let ((lines (line-number-at-pos)))
|
||
(select-window (split-window-below))
|
||
(switch-to-buffer me)
|
||
(goto-char (point-min)))
|
||
(use-local-map intero-multiswitch-keymap)
|
||
(widget-setup)
|
||
(recursive-edit)
|
||
(kill-buffer me)
|
||
(mapcar (lambda (choice)
|
||
(plist-get choice :key))
|
||
(cl-remove-if-not (lambda (choice)
|
||
(plist-get choice :value))
|
||
choices)))))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Hoogle
|
||
|
||
(defun intero-hoogle-blocking-query (query)
|
||
"Make a request of QUERY using the local hoogle server.
|
||
If running, otherwise returns nil.
|
||
|
||
It is the responsibility of the caller to make sure the server is
|
||
running; the user might not want to start the server
|
||
automatically."
|
||
(let ((buffer (intero-hoogle-get-buffer)))
|
||
(when buffer
|
||
(let ((url (intero-hoogle-url buffer query)))
|
||
(with-current-buffer (url-retrieve-synchronously url t)
|
||
(search-forward "\n\n" nil t 1)
|
||
(json-read-from-string
|
||
(buffer-substring (line-beginning-position)
|
||
(line-end-position))))))))
|
||
|
||
(defun intero-hoogle-url (buffer query)
|
||
"Via hoogle server BUFFER make the HTTP URL for QUERY."
|
||
(format "http://127.0.0.1:%d/?hoogle=%s&mode=json"
|
||
(buffer-local-value 'intero-hoogle-port buffer)
|
||
(url-encode-url query)))
|
||
|
||
(defun intero-hoogle-get-worker-create ()
|
||
"Get or create the hoogle worker."
|
||
(let* ((buffer (intero-hoogle-get-buffer-create)))
|
||
(if (get-buffer-process buffer)
|
||
buffer
|
||
(intero-start-hoogle-process-in-buffer buffer))))
|
||
|
||
(defun intero-start-hoogle-process-in-buffer (buffer)
|
||
"Start the process in BUFFER, returning BUFFER."
|
||
(let* ((port (intero-free-port))
|
||
(process (with-current-buffer buffer
|
||
(message "Booting up hoogle ...")
|
||
(setq intero-hoogle-port port)
|
||
(start-process "hoogle"
|
||
buffer
|
||
intero-stack-executable
|
||
"hoogle"
|
||
"server"
|
||
"--no-setup"
|
||
"--"
|
||
"--local"
|
||
"--port"
|
||
(number-to-string port)))))
|
||
(set-process-query-on-exit-flag process nil)
|
||
(set-process-sentinel process 'intero-hoogle-sentinel)
|
||
buffer))
|
||
|
||
(defun intero-free-port ()
|
||
"Get the next free port to use."
|
||
(let ((proc (make-network-process
|
||
:name "port-check"
|
||
:family 'ipv4
|
||
:host "127.0.0.1"
|
||
:service t
|
||
:server t)))
|
||
(delete-process proc)
|
||
(process-contact proc :service)))
|
||
|
||
(defun intero-hoogle-sentinel (process change)
|
||
"For the hoogle PROCESS there is a CHANGE to handle."
|
||
(message "Hoogle sentinel: %S %S" process change))
|
||
|
||
(defun intero-hoogle-get-buffer-create ()
|
||
"Get or create the Hoogle buffer for the current stack project."
|
||
(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)))))
|
||
|
||
(defun intero-hoogle-get-buffer ()
|
||
"Get the Hoogle buffer for the current stack project."
|
||
(let* ((root (intero-project-root))
|
||
(buffer-name (intero-hoogle-buffer-name root)))
|
||
(get-buffer buffer-name)))
|
||
|
||
(defun intero-hoogle-buffer-name (root)
|
||
"For a given worker, create a buffer name using ROOT."
|
||
(concat "*Hoogle:" root "*"))
|
||
|
||
(defun intero-hoogle-ready-p ()
|
||
"Is hoogle ready to be started?"
|
||
(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?"
|
||
(intero-with-temp-buffer
|
||
(cl-case (intero-call-stack nil (current-buffer) t
|
||
intero-stack-yaml
|
||
"hoogle" "--help")
|
||
(0 t))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Collecting information from compiler messages
|
||
|
||
(defun intero-collect-compiler-messages (msgs)
|
||
"Collect information from compiler MSGS.
|
||
|
||
This may update in-place the MSGS objects to hint that
|
||
suggestions are available."
|
||
(setq intero-suggestions nil)
|
||
(let ((extension-regex (concat " " (regexp-opt (intero-extensions) t) "\\>"))
|
||
(quoted-symbol-regex "[‘`‛]\\([^ ]+\\)['’]"))
|
||
(cl-loop
|
||
for msg in msgs
|
||
do (let ((text (flycheck-error-message msg))
|
||
(note nil))
|
||
;; Messages of this format:
|
||
;;
|
||
;; • Constructor ‘Assert’ does not have the required strict field(s): assertName,
|
||
;; assertDoc, assertExpression,
|
||
;; assertSection
|
||
(let ((start 0))
|
||
(while (or
|
||
(string-match "does not have the required strict field.*?:[\n\t\r ]" text start)
|
||
(string-match "Fields of .*? not initialised:[\n\t\r ]" text start))
|
||
(let* ((match-end (match-end 0))
|
||
(fields
|
||
(let ((reached-end nil))
|
||
(mapcar
|
||
(lambda (field)
|
||
(with-temp-buffer
|
||
(insert field)
|
||
(goto-char (point-min))
|
||
(intero-ident-at-point)))
|
||
(cl-remove-if
|
||
(lambda (field)
|
||
(or reached-end
|
||
(when (string-match "[\r\n]" field)
|
||
(setq reached-end t)
|
||
nil)))
|
||
(split-string
|
||
(substring text match-end)
|
||
"[\n\t\r ]*,[\n\t\r ]*" t))))))
|
||
(setq note t)
|
||
(add-to-list
|
||
'intero-suggestions
|
||
(list :type 'add-missing-fields
|
||
:fields fields
|
||
:line (flycheck-error-line msg)
|
||
:column (flycheck-error-column msg)))
|
||
(setq start (min (length text) (1+ match-end))))))
|
||
|
||
;; Messages of this format:
|
||
;;
|
||
;; Can't make a derived instance of ‘Functor X’:
|
||
;; You need DeriveFunctor to derive an instance for this class
|
||
;; Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension
|
||
;; In the newtype declaration for ‘X’
|
||
(let ((start 0))
|
||
(while (let ((case-fold-search nil))
|
||
(string-match extension-regex text start))
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'add-extension
|
||
:extension (match-string 1 text)))
|
||
(setq start (min (length text) (1+ (match-end 0))))))
|
||
;; Messages of this format:
|
||
;;
|
||
;; Could not find module ‘Language.Haskell.TH’
|
||
;; It is a member of the hidden package ‘template-haskell’.
|
||
;; Use -v to see a list of the files searched for....
|
||
(let ((start 0))
|
||
(while (string-match "It is a member of the hidden package [‘`‛]\\([^ ]+\\)['’]" text start)
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'add-package
|
||
: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’
|
||
;; In the expression: 2
|
||
;; In an equation for ‘x'’: x' = 2
|
||
(let ((start 0))
|
||
(while (string-match
|
||
" Defaulting the following constraint" text start)
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'add-ghc-option
|
||
:option "-fno-warn-type-defaults"))
|
||
(setq start (min (length text) (1+ (match-end 0))))))
|
||
;; Messages of this format:
|
||
;;
|
||
;; This binding for ‘x’ shadows the existing binding
|
||
(let ((start 0))
|
||
(while (string-match
|
||
" This binding for ‘\\(.*\\)’ shadows the existing binding" text start)
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'add-ghc-option
|
||
: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’
|
||
;; To import instances alone, use: import Control.Monad()... (intero)
|
||
(when (string-match
|
||
" The \\(qualified \\)?import of[ ][‘`‛]\\([^ ]+\\)['’] is redundant"
|
||
text)
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'remove-import
|
||
:module (match-string 2 text)
|
||
:line (flycheck-error-line msg))))
|
||
;; Messages of this format:
|
||
;;
|
||
;; Not in scope: ‘putStrn’
|
||
;; Perhaps you meant one of these:
|
||
;; ‘putStr’ (imported from Prelude),
|
||
;; ‘putStrLn’ (imported from Prelude)
|
||
;;
|
||
;; Or this format:
|
||
;;
|
||
;; error:
|
||
;; • Variable not in scope: lopSetup :: [Statement Exp']
|
||
;; • Perhaps you meant ‘loopSetup’ (line 437)
|
||
(when (string-match
|
||
"[Nn]ot in scope: \\(data constructor \\|type constructor or class \\)?[‘`‛]?\\([^'’ ]+\\).*\n.*Perhaps you meant"
|
||
text)
|
||
(let ((typo (match-string 2 text))
|
||
(start (min (length text) (1+ (match-end 0)))))
|
||
(while (string-match quoted-symbol-regex text start)
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'fix-typo
|
||
:typo typo
|
||
:replacement (match-string 1 text)
|
||
:column (flycheck-error-column msg)
|
||
:line (flycheck-error-line msg)))
|
||
(setq start (min (length text) (1+ (match-end 0)))))))
|
||
;; Messages of this format:
|
||
;;
|
||
;; Top-level binding with no type signature: main :: IO ()
|
||
(when (string-match
|
||
"Top-level binding with no type signature:"
|
||
text)
|
||
(let ((start (min (length text) (match-end 0))))
|
||
(setq note t)
|
||
(add-to-list 'intero-suggestions
|
||
(list :type 'add-signature
|
||
: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
|
||
;; Redundant constraint: Arith var
|
||
;; Or
|
||
;; Redundant constraints: (Arith var,
|
||
;; Bitwise var,
|
||
;; Functor var,
|
||
;; Applicative var,
|
||
;; Monad var)
|
||
(when (string-match "Redundant constraints?: " text)
|
||
(let* ((redundant-start (match-end 0))
|
||
(parts (intero-with-temp-buffer
|
||
(insert (substring text redundant-start))
|
||
(goto-char (point-min))
|
||
;; A lone unparenthesized constraint might
|
||
;; be multiple sexps.
|
||
(while (not (eq (point) (point-at-eol)))
|
||
(forward-sexp))
|
||
(let ((redundant-end (point)))
|
||
(search-forward-regexp ".*\n.*In the ")
|
||
(cons (buffer-substring (point-min) redundant-end)
|
||
(buffer-substring (match-end 0) (point-max)))))))
|
||
(setq note t)
|
||
(add-to-list
|
||
'intero-suggestions
|
||
(let ((rest (cdr parts))
|
||
(redundant (let ((raw (car parts)))
|
||
(if (eq (string-to-char raw) ?\()
|
||
(substring raw 1 (1- (length raw)))
|
||
raw))))
|
||
(list :type 'redundant-constraint
|
||
:redundancies (mapcar #'string-trim
|
||
(intero-parse-comma-list redundant))
|
||
:signature (mapconcat #'identity (split-string rest) " ")
|
||
:line (flycheck-error-line msg))))))
|
||
;; Add a note if we found a suggestion to make
|
||
(when note
|
||
(setf (flycheck-error-message msg)
|
||
(concat text
|
||
"\n\n"
|
||
(propertize "(Hit `C-c C-r' in the Haskell buffer to apply suggestions)"
|
||
'face 'font-lock-warning-face)))))))
|
||
(setq intero-lighter
|
||
(if (null intero-suggestions)
|
||
" Intero"
|
||
(format " Intero:%d" (length intero-suggestions)))))
|
||
|
||
(defun intero-extensions ()
|
||
"Get extensions for the current project's GHC."
|
||
(with-current-buffer (intero-buffer 'backend)
|
||
(or intero-extensions
|
||
(setq intero-extensions
|
||
(cl-remove-if-not
|
||
(lambda (str) (let ((case-fold-search nil))
|
||
(string-match "^[A-Z][A-Za-z0-9]+$" str)))
|
||
(split-string
|
||
(shell-command-to-string
|
||
(concat intero-stack-executable
|
||
(if intero-stack-yaml
|
||
(concat "--stack-yaml " intero-stack-yaml)
|
||
"")
|
||
" exec --verbosity silent -- ghc --supported-extensions"))))))))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; Auto actions
|
||
|
||
(defun intero-parse-comma-list (text)
|
||
"Parse a list of comma-separated expressions in TEXT."
|
||
(cl-loop for tok in (split-string text "[[:space:]\n]*,[[:space:]\n]*")
|
||
with acc = nil
|
||
append (let* ((clist (string-to-list tok))
|
||
(num-open (-count (lambda (c) (or (eq c ?\() (eq c ?\[)))
|
||
clist))
|
||
(num-close (-count (lambda (c) (or (eq c ?\)) (eq c ?\])))
|
||
clist)))
|
||
(cond
|
||
((> num-open num-close) (progn (add-to-list 'acc tok) nil))
|
||
((> num-close num-open) (let ((tmp (reverse (cons tok acc))))
|
||
(setq acc nil)
|
||
(list (string-join tmp ", "))))
|
||
(t (list tok))))))
|
||
|
||
(defun intero-apply-suggestions ()
|
||
"Prompt and apply the suggestions."
|
||
(interactive)
|
||
(if (null intero-suggestions)
|
||
(message "No suggestions to apply")
|
||
(let ((to-apply
|
||
(intero-multiswitch
|
||
(format "There are %d suggestions to apply:" (length intero-suggestions))
|
||
(cl-remove-if-not
|
||
#'identity
|
||
(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))
|
||
(add-missing-fields
|
||
(list :key suggestion
|
||
:default t
|
||
:title
|
||
(format "Add missing fields to record: %s"
|
||
(mapconcat (lambda (ident)
|
||
(concat "‘" ident "’"))
|
||
(plist-get suggestion :fields)
|
||
", "))))
|
||
(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 (not (string= "OverloadedStrings" (plist-get suggestion :extension)))))
|
||
(add-ghc-option
|
||
(list :key suggestion
|
||
:title (concat "Add {-# OPTIONS_GHC "
|
||
(plist-get suggestion :option)
|
||
" #-}")
|
||
:default (not
|
||
(string=
|
||
(plist-get suggestion :option)
|
||
"-fno-warn-name-shadowing"))))
|
||
(add-package
|
||
(list :key suggestion
|
||
:title (concat "Enable package: " (plist-get suggestion :package))
|
||
:default t))
|
||
(remove-import
|
||
(list :key suggestion
|
||
:title (concat "Remove: import "
|
||
(plist-get suggestion :module))
|
||
:default t))
|
||
(fix-typo
|
||
(list :key suggestion
|
||
:title (concat "Replace ‘"
|
||
(plist-get suggestion :typo)
|
||
"’ with ‘"
|
||
(plist-get suggestion :replacement)
|
||
"’")
|
||
:default (null (cdr intero-suggestions))))
|
||
(add-signature
|
||
(list :key suggestion
|
||
:title (concat "Add signature: "
|
||
(plist-get suggestion :signature))
|
||
:default t))
|
||
(redundant-constraint
|
||
(list :key suggestion
|
||
:title (concat
|
||
"Remove redundant constraints: "
|
||
(string-join (plist-get suggestion :redundancies)
|
||
", ")
|
||
"\n from the "
|
||
(plist-get suggestion :signature))
|
||
:default nil))))
|
||
intero-suggestions)))))
|
||
(if (null to-apply)
|
||
(message "No changes selected to apply.")
|
||
(let ((sorted (sort to-apply
|
||
(lambda (lt gt)
|
||
(let ((lt-line (or (plist-get lt :line) 0))
|
||
(lt-column (or (plist-get lt :column) 0))
|
||
(gt-line (or (plist-get gt :line) 0))
|
||
(gt-column (or (plist-get gt :column) 0)))
|
||
(or (> lt-line gt-line)
|
||
(and (= lt-line gt-line)
|
||
(> lt-column gt-column))))))))
|
||
;; # Changes unrelated to the buffer
|
||
(cl-loop
|
||
for suggestion in sorted
|
||
do (cl-case (plist-get suggestion :type)
|
||
(add-package
|
||
(intero-add-package (plist-get suggestion :package)))))
|
||
;; # Changes that do not increase/decrease line numbers
|
||
;;
|
||
;; Update in-place suggestions
|
||
(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-p "^[_a-zA-Z]" (plist-get suggestion :ident))
|
||
(plist-get suggestion :ident)
|
||
(concat "(" (plist-get suggestion :ident) ")")))
|
||
(unless (looking-at-p "[:space:]*)")
|
||
(insert ", ")))))
|
||
(redundant-import-item
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(forward-line (1- (plist-get suggestion :line)))
|
||
(let* ((case-fold-search nil)
|
||
(start (search-forward "(" nil t 1))
|
||
(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-p "^[_a-zA-Z]" ident)
|
||
(concat "\\<" (regexp-quote ident) "\\> ?" "\\("(regexp-quote "(..)") "\\)?")
|
||
(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 ,]*" ""
|
||
(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))
|
||
(forward-line (1- (plist-get suggestion :line)))
|
||
(move-to-column (- (plist-get suggestion :column) 1))
|
||
(delete-char (length (plist-get suggestion :typo)))
|
||
(insert (plist-get suggestion :replacement))))
|
||
(add-missing-fields
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(forward-line (1- (plist-get suggestion :line)))
|
||
(move-to-column (- (plist-get suggestion :column) 1))
|
||
(search-forward "{")
|
||
(unless (looking-at "}")
|
||
(save-excursion (insert ", ")))
|
||
(insert (mapconcat (lambda (field) (concat field " = _"))
|
||
(plist-get suggestion :fields)
|
||
", "))))))
|
||
;; # Changes that do increase/decrease line numbers
|
||
;;
|
||
;; Remove redundant constraints
|
||
(cl-loop
|
||
for suggestion in sorted
|
||
do (cl-case (plist-get suggestion :type)
|
||
(redundant-constraint
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(forward-line (1- (plist-get suggestion :line)))
|
||
(search-forward-regexp "[[:alnum:][:space:]\n]*=>")
|
||
(backward-sexp 2)
|
||
(let ((start (1+ (point))))
|
||
(forward-sexp)
|
||
(let* ((end (1- (point)))
|
||
(constraints (intero-parse-comma-list
|
||
(buffer-substring start end)))
|
||
(nonredundant
|
||
(cl-loop for r in (plist-get suggestion :redundancies)
|
||
with nonredundant = constraints
|
||
do (setq nonredundant (delete r nonredundant))
|
||
finally return nonredundant)))
|
||
(goto-char start)
|
||
(delete-char (- end start))
|
||
(insert (string-join nonredundant ", "))))))))
|
||
|
||
;; Add a type signature to a top-level binding.
|
||
(cl-loop
|
||
for suggestion in sorted
|
||
do (cl-case (plist-get suggestion :type)
|
||
(add-signature
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(forward-line (1- (plist-get suggestion :line)))
|
||
(insert (plist-get suggestion :signature))
|
||
(insert "\n")))))
|
||
|
||
;; Remove import lines from the file. May remove more than one
|
||
;; line per import.
|
||
(cl-loop
|
||
for suggestion in sorted
|
||
do (cl-case (plist-get suggestion :type)
|
||
(remove-import
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(forward-line (1- (plist-get suggestion :line)))
|
||
(delete-region (line-beginning-position)
|
||
(or (when (search-forward-regexp "\n[^ \t]" nil t 1)
|
||
(1- (point)))
|
||
(line-end-position)))))))
|
||
;; Add extensions to the top of the file
|
||
(cl-loop
|
||
for suggestion in sorted
|
||
do (cl-case (plist-get suggestion :type)
|
||
(add-extension
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(intero-skip-shebangs)
|
||
(insert "{-# LANGUAGE "
|
||
(plist-get suggestion :extension)
|
||
" #-}\n")))
|
||
(add-ghc-option
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(intero-skip-shebangs)
|
||
(insert "{-# OPTIONS_GHC "
|
||
(plist-get suggestion :option)
|
||
" #-}\n"))))))))))
|
||
|
||
(defun intero-skip-shebangs ()
|
||
"Skip #! and -- shebangs used in Haskell scripts."
|
||
(when (looking-at-p "#!") (forward-line 1))
|
||
(when (looking-at-p "-- stack ") (forward-line 1)))
|
||
|
||
(defun intero--warn (message &rest args)
|
||
"Display a warning message made from (format MESSAGE ARGS...).
|
||
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 "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)
|
||
|
||
;;; intero.el ends here
|