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, 0 insertions, 3648 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 deleted file mode 100644 index 0553b6307300..000000000000 --- a/configs/shared/emacs/.emacs.d/elpa/intero-20180703.18/intero.el +++ /dev/null @@ -1,3648 +0,0 @@ -;;; 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 |