diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/intero-20180703.18/intero.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/intero-20180703.18/intero.el | 3648 |
1 files changed, 3648 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/intero-20180703.18/intero.el b/configs/shared/emacs/.emacs.d/elpa/intero-20180703.18/intero.el new file mode 100644 index 000000000000..0553b6307300 --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/intero-20180703.18/intero.el @@ -0,0 +1,3648 @@ +;;; 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 |