intero 0.1.20 → 0.1.21
raw patch · 11 files changed
+3528/−2538 lines, 11 filesdep ~ghcnew-uploader
Dependency ranges changed: ghc
Files
- README.md +22/−20
- cbits/hschooks.c +1/−1
- elisp/intero.el +3186/−2446
- intero.cabal +6/−3
- src/GhciFind.hs +49/−18
- src/GhciInfo.hs +13/−2
- src/GhciMonad.hs +25/−0
- src/GhciTypes.hs +2/−0
- src/InteractiveUI.hs +144/−25
- src/Main.hs +52/−18
- src/test/Main.hs +28/−5
README.md view
@@ -1,4 +1,4 @@-# <img src="https://github.com/commercialhaskell/intero/raw/master/images/intero.svg" height=25> intero [](https://travis-ci.org/commercialhaskell/intero) <a href="https://melpa.org/#/intero"><img alt="MELPA" src="https://melpa.org/packages/intero-badge.svg"/></a>+# <img src="https://github.com/commercialhaskell/intero/raw/master/images/intero.svg" height=25> intero [](https://travis-ci.org/commercialhaskell/intero) [](https://melpa.org/#/intero) [](https://stable.melpa.org/#/intero) [](https://ci.appveyor.com/project/commercialhaskell/intero) Complete interactive development program for Haskell @@ -16,35 +16,37 @@ `C-c C-t` | Show the type of thing at point, or the selection `C-u C-c C-t` | Insert a type signature for the thing at point `C-c C-l` | Load this module in the REPL+`C-c C-c` | Evaluate the selected region in the REPL `C-c C-r` | Apply suggestions from GHC `C-c C-k` | Clear REPL `C-c C-z` | Switch to and from the REPL -## Whitelisting/blacklisting projects--Typically Intero will enable for all projects, and for files-without a stack.yaml, it will assume the "global" project. Some users-prefer to enable Intero selectively. See below how to do that.+## Enabling intero -Find this line in your Emacs configuration and remove it:+To enable `intero` in all `haskell-mode` buffers by default, enable+`intero-global-mode`, by using `M-x customize` or by adding+`(intero-global-mode 1)` to your Emacs start-up files. -``` lisp-(add-hook 'haskell-mode-hook 'intero-mode)-```+Intero will then activate for all projects, and for files without a+stack.yaml, it will assume the "global" project. If you want to use an+alternate stack yaml configuration file (for example, when developing+for multiple GHC versions), use `M-x intero-stack-yaml` to switch+file. When switching configuration, you will asked whether you want to+preserve this choice across emacs sessions for the given project. -To whitelist specific directories (and ignore everything else), use:+## Whitelisting/blacklisting projects -``` lisp-(setq intero-whitelist '("/work/directories/" "/my/directories/"))-(add-hook 'haskell-mode-hook 'intero-mode-whitelist)-```+Some users prefer to enable Intero selectively. The custom variables+`intero-blacklist` and `intero-whitelist` are provided for this+purpose, and are honoured by `intero-global-mode`: -To blacklist specific directories (and allow everything else), use:+If the parent directory of a Haskell file is listed in+`intero-blacklist`, then `intero` will not be enabled for that file,+unless a parent directory of that file is also listed in+`intero-whitelist`. In other words, whitelist entries take+precedence. You can therefore blacklist `/` to disable `intero` in all+projects unless they are whitelisted. -``` lisp-(setq intero-blacklist '("/path/to/bad/project" "/path/to/ignore/me"))-(add-hook 'haskell-mode-hook 'intero-mode-blacklist)-``` ## Intero for IDE writers
cbits/hschooks.c view
@@ -30,7 +30,7 @@ void defaultsHook (void) {-#if __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 802 // This helps particularly with large compiles, but didn't work // very well with earlier GHCs because it caused large amounts of // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().
elisp/intero.el view
@@ -1,2452 +1,3192 @@ ;;; intero.el --- Complete development mode for Haskell ;; Copyright (c) 2016 Chris Done-;; 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-;; Created: 3rd June 2016-;; Version: 0.1.13-;; Keywords: haskell, tools-;; Package-Requires: ((flycheck "0.25") (company "0.8") (emacs "24.3") (haskell-mode "13.0"))--;; 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))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Configuration--(defgroup intero nil- "Complete development mode for Haskell"- :group 'haskell)--(defcustom intero-package-version- "0.1.20"- "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)-(make-variable-buffer-local 'intero-repl-no-load)--(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)-(make-variable-buffer-local 'intero-repl-no-build)--(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)"- :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)"- :group 'intero- :type '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 (flycheck-select-checker 'intero)- (flycheck-mode)- (add-to-list (make-local-variable 'company-backends) 'company-intero)- (company-mode)- (setq-local eldoc-documentation-function 'eldoc-intero))- (message "Intero mode disabled.")))--(defun intero-mode-whitelist ()- "Run intero-mode when the current project is in `intero-whitelist'."- (interactive)- (let ((file (buffer-file-name)))- (when (cl-remove-if-not (lambda (directory)- (file-in-directory-p file directory))- intero-whitelist)- (intero-mode))))--(defun intero-mode-blacklist ()- "Run intero-mode unless the current project is in `intero-blacklist'."- (interactive)- (let ((file (buffer-file-name)))- (unless (cl-remove-if-not (lambda (directory)- (file-in-directory-p file directory))- intero-blacklist)- (intero-mode))))--(define-key intero-mode-map (kbd "C-c C-t") 'intero-type-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-z") 'intero-repl)-(define-key intero-mode-map (kbd "C-c C-r") 'intero-apply-suggestions)--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Global variables/state--(defvar intero-global-mode nil- "Global mode is enabled?")--(defun global-intero-mode ()- "Enable Intero on all Haskell mode buffers."- (interactive)- (setq intero-global-mode (not intero-global-mode))- (if intero-global-mode- (add-hook 'haskell-mode-hook 'intero-mode)- (remove-hook 'haskell-mode-hook 'intero-mode))- (when (eq this-command 'global-intero-mode)- (message "Intero mode is now %s on all future Haskell buffers."- (if intero-global-mode- "enabled" "disabled"))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Buffer-local variables/state--(defvar-local intero-callbacks (list)- "List of callbacks waiting for output.-LIST is a FIFO.")--(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-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-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 intero-ghc-version nil- "GHC version used by the project.")--(defvar-local intero-repl-last-loaded- nil- "The last loaded thing with `intero-repl-load`.")--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Interactive commands--(defun intero-add-package (package)- "Add a package dependency 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 " 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."- (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-type-at (insert)- "Get the type of the thing or selection at point.--With prefix argument INSERT, inserts the type above the current-line as a type signature."- (interactive "P")- (let ((ty (apply #'intero-get-type-at (intero-thing-at-point))))- (if insert- (save-excursion- (goto-char (line-beginning-position))- (insert (intero-fontify-expression ty) "\n"))- (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))- (help-xref-following nil)- (origin (buffer-name)))- (help-setup-xref (list #'intero-call-in-buffer origin-buffer 'intero-info ident)- (called-interactively-p 'interactive))- (save-excursion- (let ((help-xref-following nil))- (with-help-window (help-buffer)- (with-current-buffer (help-buffer)- (insert- (intero-fontify-expression ident)- " in `"- origin- "'"- " (" package ")"- "\n\n"- (intero-fontify-expression info))- (goto-char (point-min))))))))--(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))))- (when (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$"- 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 ((file (match-string 1 result))- (line (string-to-number (match-string 2 result)))- (col (string-to-number (match-string 3 result))))- (unless (string= file (intero-temp-file-name))- (find-file file))- (pop-mark)- (goto-char (point-min))- (forward-line (1- line))- (forward-char (1- col))- t))))--(defun intero-restart ()- "Simply restart the process with the same configuration as before."- (interactive)- (when (intero-buffer-p 'backend)- (let ((targets (with-current-buffer (intero-buffer 'backend)- intero-targets)))- (intero-destroy 'backend)- (intero-get-worker-create 'backend targets (current-buffer))- (intero-repl-restart))))--(defun intero-targets ()- "Set the targets to use for stack ghci."- (interactive)- (let* ((old-targets- (with-current-buffer (intero-buffer 'backend)- intero-targets))- (available-targets (intero-get-targets))- (targets (if available-targets- (intero-multiswitch- "Targets:"- (mapcar (lambda (target)- (list :key target- :title target- :default (member target old-targets)))- available-targets))- (split-string (read-from-minibuffer "Targets: " nil nil nil nil old-targets)- " "- t))))- (intero-destroy)- (intero-get-worker-create 'backend targets (current-buffer))- (intero-repl-restart)))--(defun intero-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- ":l DevelMain"- (current-buffer)- (lambda (buffer reply)- (if (string-match "^OK, 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-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)))- (intero-async-call- 'backend- (concat ":l " (intero-temp-file-name))- (list :cont cont- :file-buffer file-buffer- :checker checker)- (lambda (state string)- (let ((compile-ok (string-match "OK, modules loaded: \\(.*\\)\\.$" string)))- (with-current-buffer (plist-get state :file-buffer)- (let ((modules (match-string 1 string))- (msgs (intero-parse-errors-warnings-splices- (plist-get state :checker)- (current-buffer)- string)))- (intero-collect-compiler-messages msgs)- (funcall (plist-get state :cont)- 'finished- (cl-remove-if (lambda (msg)- (eq 'splice (flycheck-error-level msg)))- msgs))- (when compile-ok- (intero-async-call 'backend- (concat ":m + "- (replace-regexp-in-string modules "," ""))- nil- (lambda (_st _))))))))))))---(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))--(add-to-list 'flycheck-checkers 'intero)--(defun intero-parse-errors-warnings-splices (checker buffer string)- "Parse flycheck errors and warnings.-CHECKER and BUFFER are added to each item parsed from STRING."- (with-temp-buffer- (insert string)- (goto-char (point-min))- (let ((messages (list))- (temp-file (intero-temp-file-name buffer)))- (while (search-forward-regexp- (concat "[\r\n]\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\):\\([0-9()-:]+\\):"- "[ \n\r]+\\([[:unibyte:][:nonascii:]]+?\\)\n[^ ]")- nil t 1)- (let* ((file (intero-canonicalize-path (match-string 1)))- (location-raw (match-string 2))- (msg (match-string 3)) ;; Replace gross bullet points.- (type (cond ((string-match "^Warning:" msg)- (setq msg (replace-regexp-in-string "^Warning: *" "" msg))- (if (string-match "^\\[-Wdeferred-type-errors\\]" msg)- 'error- 'warning))- ((string-match "^Splicing " msg) 'splice)- (t 'error)))- (location (intero-parse-error- (concat 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 (when (string= temp-file file)- buffer)- :filename (intero-buffer-file-name buffer))- messages)))- (forward-line -1))- (delete-dups 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."- (let ((span nil))- (cl-loop for regex- in intero-error-regexp-alist- do (when (string-match (car regex) string)- (setq span- (list :file (match-string 1 string)- :line (string-to-number (match-string 2 string))- :col (string-to-number (match-string 4 string))- :line2 (when (match-string 3 string)- (string-to-number (match-string 3 string)))- :col2 (when (match-string 5 string)- (string-to-number (match-string 5 string)))))))- span))--(defun intero-call-in-buffer (buffer func &rest args)- "In BUFFER, call FUNC with ARGS."- (with-current-buffer buffer- (apply func args)))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; 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 company-intero (command &optional arg &rest ignored)- "Company source for intero, with the standard COMMAND and ARG args.-Other arguments are IGNORED."- (interactive (list 'interactive))- (cl-case command- (interactive (company-begin-backend 'company-intero))- (prefix- (unless (intero-gave-up 'backend)- (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 ((prefix-info (intero-completions-grab-prefix)))- (when prefix-info- (cons :async- (-partial 'intero-company-callback- (current-buffer)- prefix-info))))))))--(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-match (concat "^" 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)))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; ELDoc integration--(defvar-local eldoc-intero-cache (make-hash-table :test 'equal)- "Cache for types of regions, used by `eldoc-intero'.-This is not for saving on requests (we make a request even if-something is in cache, overwriting the old entry), but rather for-making types show immediately when we do have them cached.")--(defun eldoc-intero-maybe-print (msg)- "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 eldoc-intero ()- "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- eldoc-intero-cache)- (eldoc-intero-maybe-print msg))- ;; But if we're seeing errors, invalidate cache-at-point:- (remhash (list beg end) eldoc-intero-cache))))- (intero-thing-at-point))))- ;; If we have something cached at point, print that first:- (gethash (intero-thing-at-point) eldoc-intero-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)))--(defun intero-repl-load (&optional prompt-options)- "Load the current file in the REPL.-If PROMPT-OPTIONS is non-nil, prompt with an options list."- (interactive "P")- (save-buffer)- (let ((file (intero-temp-file-name))- (repl-buffer (intero-repl-buffer prompt-options t)))- (with-current-buffer repl-buffer- (comint-simple-send- (get-buffer-process (current-buffer))- (if (string= intero-repl-last-loaded file)- ":r"- (concat ":l " file)))- (setq intero-repl-last-loaded file))- (pop-to-buffer repl-buffer)))--(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)))))--(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- (if (get-buffer name)- (get-buffer name)- (with-current-buffer- (get-buffer-create name)- (cd root)- (intero-repl-mode)- (intero-repl-mode-start backend-buffer- (buffer-local-value 'intero-targets backend-buffer)- prompt-options)- (current-buffer)))- (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:char)- (define-key map [C-return] 'intero-find-file-with-line:char)- map)- "Keymap for clicking on links in REPL.")--(defun intero-find-file-with-line:char ()- "Jump to the file and location indicated by text properties at point."- (interactive)- (let ((file (get-text-property (point) 'file))- (line (get-text-property (point) 'line))- (char (get-text-property (point) 'char)))- (with-no-warnings (find-file-other-window file))- (goto-char (point-min))- (forward-line (1- line))- (forward-char (1- char))))--(defun intero-linkify-file-line-char (begin end)- "Linkify all occurences of <file>:<line>:<char>: betwen BEGIN and END."- (when (> end begin)- (let ((end-marker (copy-marker end))- ;; match - /path/to/file.ext:<line>:<char>:- ;; - /path/to/file.ext:<line>:<char>-- ;; - /path/to/file.ext:(<line>:<char>)- (file:line:char-regexp "\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\)[:](?\\([0-9]+\\)[:,]\\([0-9]+\\)[:)-]"))- (save-excursion- (goto-char begin)- ;; Delete unrecognized escape sequences.- (while (re-search-forward file:line:char-regexp end-marker t)- (let ((file (match-string-no-properties 1))- (line (match-string-no-properties 2))- (char (match-string-no-properties 3))- (link-start (1+ (match-beginning 1)))- (link-end (1+ (match-end 2))))- (add-text-properties- link-start link-end- (list 'keymap intero-hyperlink-map- 'file file- 'line (string-to-number line)- 'char (string-to-number char)- 'help-echo "mouse-2: visit this file"))))))))--(defvar intero-last-output-newline-marker nil)--(defun intero-linkify-process-output (_)- "Comint filter function to make <file>:<line>:<char>: into clickable links.--Note that this function uses the `intero-last-output-newline-marker',-to keep track of line breaks. The `intero-linkify-file-line-char'-function is subsequently applied to each line, once."- (unless intero-last-output-newline-marker- (setq-local intero-last-output-newline-marker (make-marker))- (set-marker intero-last-output-newline-marker (marker-position comint-last-output-start)))- (let ((start-marker (if (and (markerp intero-last-output-newline-marker)- (eq (marker-buffer intero-last-output-newline-marker)- (current-buffer))- (marker-position intero-last-output-newline-marker))- comint-last-output-start- (point-min-marker)))- (end-marker (process-mark (get-buffer-process (current-buffer)))))- (save-excursion- (goto-char start-marker)- (while (re-search-forward "[\n\r]" end-marker t)- (intero-linkify-file-line-char intero-last-output-newline-marker (match-beginning 0))- (set-marker intero-last-output-newline-marker (match-end 0))))))--(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))- (add-hook 'comint-output-filter-functions- 'intero-linkify-process-output- t)- (setq-local comint-prompt-read-only t)- (add-to-list (make-local-variable 'company-backends) 'company-intero)- (company-mode))--(defun intero-repl-mode-start (backend-buffer targets prompt-options)- "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."- (setq intero-targets targets)- (when prompt-options- (intero-repl-options backend-buffer))- (let ((arguments (intero-make-options-list- (or targets- (let ((package-name (buffer-local-value 'intero-package-name- backend-buffer)))- (unless (equal "" package-name)- (list package-name))))- (buffer-local-value 'intero-repl-no-build backend-buffer)- (buffer-local-value 'intero-repl-no-load backend-buffer))))- (insert (propertize- (format "Starting:\n stack ghci %s\n" (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 prompt \"\\4 \"-")- (basic-save-buffer)- (current-buffer)))- (script- (with-current-buffer script-buffer- (intero-buffer-file-name))))- (let ((process- (get-buffer-process- (apply #'make-comint-in-buffer "intero" (current-buffer) "stack" nil "ghci"- (append arguments- (list "--verbosity" "silent")- (list "--ghci-options"- (concat "-ghci-script=" script)))))))- (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 intero-repl-no-load (not (member "load-all" new-options)))- (setq 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 (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 (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 (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 "[[: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)))))--(defvar-local intero-temp-file-name nil- "The name of a temporary file to which the current buffer's content is copied.")--(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- (expand-file-name ".stack-work/intero/"- (intero-project-root))))- (make-directory temporary-file-directory t)- (make-temp-file prefix dir-flag suffix)))--(defun intero-temp-file-name (&optional buffer)- "Return the name of a temp file containing an up-to-date copy of BUFFER's contents."- (with-current-buffer (or buffer (current-buffer))- (prog1- (or intero-temp-file-name- (setq intero-temp-file-name- (intero-canonicalize-path- (intero-make-temp-file- "intero" nil- (concat "." (if (buffer-file-name)- (file-name-extension (buffer-file-name))- "hs"))))))- (let ((contents (buffer-string)))- (with-temp-file intero-temp-file-name- (insert contents))))))--(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-call 'backend ":all-types"))--(defun intero-get-type-at (beg end)- "Get the type at the given region denoted by BEG and 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-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-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 ":i %s" thing)))))- (if (string-match "^<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 ":l " (intero-temp-file-name))))- (intero-async-call- 'backend- ":set -fobject-code")- (replace-regexp-in-string- "\n$" ""- (intero-blocking-call- 'backend- (format ":i %s" thing))))- optimistic-result)))--(defun intero-get-loc-at (beg end)- "Get the location of the identifier denoted by BEG and END."- (replace-regexp-in-string- "\n$" ""- (intero-blocking-call- 'backend- (format ":loc-at %S %d %d %d %d %S"- (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."- (replace-regexp-in-string- "\n$" ""- (intero-blocking-call- 'backend- (format ":uses %S %d %d %d %d %S"- (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-call- 'backend- (format ":complete-at %S %d %d %d %d %S"- (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)- (if (string-match "^*** Exception" reply)- (list)- (mapcar- (lambda (x)- (replace-regexp-in-string "\\\"" "" x))- (split-string reply "\n" t))))))))--(defun intero-get-repl-completions (source-buffer prefix cont)- "Get REPL completions and send to SOURCE-BUFFER.-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-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)))- (with-current-buffer (intero-buffer worker)- (while (not (null intero-callbacks))- (sleep-for 0.0001)))- (car result)))--(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)))- (if (get-buffer-process buffer)- buffer- (intero-get-worker-create worker nil (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)- "Start the given WORKER.-If provided, use the specified TARGETS and SOURCE-BUFFER."- (let* ((buffer (intero-get-buffer-create worker)))- (if (get-buffer-process buffer)- buffer- (let ((install-status (intero-installed-p)))- (if (eq install-status 'installed)- (intero-start-process-in-buffer buffer targets source-buffer)- (intero-auto-install buffer install-status targets source-buffer))))))--(defun intero-auto-install (buffer install-status &optional targets source-buffer)- "Automatically install Intero appropriately for BUFFER.-INSTALL-STATUS indicates the current installation status.-If supplied, use the given TARGETS and SOURCE-BUFFER."- (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."))- (format "--Installing intero-%s automatically ...--" intero-package-version))- (redisplay)- (cl-case (call-process "stack" nil (current-buffer) t "build"- (with-current-buffer buffer- (let* ((cabal-file (intero-cabal-find-file))- (package-name (intero-package-name cabal-file)))- ;; For local development. Most users'll- ;; never hit this behaviour.- (if (string= package-name "intero")- "intero"- (concat "intero-" intero-package-version))))- "ghc-paths" "syb")- (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)- "Start an Intero worker in BUFFER, for the default or specified TARGETS.-Automatically performs initial actions in SOURCE-BUFFER, if specified."- (if (buffer-local-value 'intero-give-up buffer)- buffer- (let* ((options- (intero-make-options-list- (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- ))- (arguments options)- (process (with-current-buffer buffer- (when intero-debug- (message "Intero arguments: %s" (combine-and-quote-strings arguments)))- (message "Booting up intero ...")- (apply #'start-process "stack" buffer "stack" "ghci"- arguments))))- (set-process-query-on-exit-flag process nil)- (process-send-string process ":set -fobject-code\n")- (process-send-string process ":set prompt \"\\4\"\n")- (with-current-buffer buffer- (erase-buffer)- (setq intero-targets targets)- (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- (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 "^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 (targets no-build no-load)- "Make the stack ghci options list.-TARGETS are the build targets. When non-nil, NO-BUILD and-NO-LOAD enable the correspondingly-named stack options."- (append (list "--with-ghc"- "intero"- "--docker-run-args=--interactive=true --tty=false"- )- (when no-build- (list "--no-build"))- (when no-load- (list "--no-load"))- (let ((dir (intero-make-temp-file "intero" t)))- (list "--ghci-options"- (concat "-odir=" dir)- "--ghci-options"- (concat "-hidir=" dir)))- 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-installed-p ()- "Return non-nil if intero (of the right version) is installed in the stack environment."- (redisplay)- (with-temp-buffer- (if (= 0 (call-process "stack" nil t nil "exec"- "--verbosity" "silent"- "--" "intero" "--version"))- (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 " stack ghci %s"- (combine-and-quote-strings intero-arguments))- "--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 (strip-carriage-returns (buffer-substring (point-min) (1- (point))))))- (if next-callback- (progn (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 strip-carriage-returns (string)- "Strip the \\r from Windows \\r\\n line endings in STRING."- (replace-regexp-in-string "\r" "" string))--(defun intero-get-buffer-create (worker)- "Get or create the stack buffer for WORKER.-Uses the directory of the current buffer for context."- (let* ((root (intero-project-root))- (cabal-file (intero-cabal-find-file))- (package-name (if cabal-file- (intero-package-name cabal-file)- ""))- (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)- (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 either the directory where the stack.yaml is placed for-this project, or the global one if no such project-specific-config exists."- (if intero-project-root- intero-project-root- (setq intero-project-root- (with-temp-buffer- (cl-case (save-excursion- (call-process "stack" nil- (current-buffer)- nil- "path"- "--project-root"- "--verbosity" "silent"))- (0 (buffer-substring (line-beginning-position) (line-end-position)))- (t (intero--warn "Couldn't get the Stack project root.--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:--stack path --project-root")- nil))))))--(defun intero-ghc-version ()- "Get the GHC version used by the project."- (with-current-buffer (intero-buffer 'backend)- (or intero-ghc-version- (setq intero-ghc-version- (with-temp-buffer- (cl-case (save-excursion- (call-process "stack" nil (current-buffer) t "ghc" "--" "--numeric-version"))- (0- (buffer-substring (line-beginning-position) (line-end-position)))- (1 nil)))))))--(defun intero-get-targets ()- "Get all available targets."- (with-temp-buffer- (cl-case (call-process "stack" nil (current-buffer) t "ide" "targets")- (0- (cl-remove-if-not- (lambda (line)- (string-match "^[A-Za-z0-9-:]+$" line))- (split-string (buffer-string) "[\r\n]" t)))- (1 nil))))--(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 'file-directory-p- (cl-remove-if-not 'file-exists-p- (directory-files dir t ".\\.cabal\\'")))))- (cond- ((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found- (allow-multiple cabal-files) ;; pass-thru multiple candidates- (t nil))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Multiselection--(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- (with-temp-buffer- (rename-buffer (generate-new-buffer-name "multiswitch"))- (widget-insert (concat title "\n\n"))- (widget-insert (propertize "Hit " 'face 'font-lock-comment-face))- (widget-create 'push-button :notify- (lambda (&rest ignore)- (exit-recursive-edit))- "C-c C-c")- (widget-insert (propertize " to apply these choices.\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- (let ((map (copy-keymap widget-keymap)))- (define-key map (kbd "C-c C-c") 'exit-recursive-edit)- (define-key map (kbd "C-g") 'abort-recursive-edit)- map))- (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- "stack"- "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))- (default-directory root))- (if buf- buf- (with-current-buffer (get-buffer-create buffer-name)- (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?"- (with-temp-buffer- (cl-case (call-process "stack" nil (current-buffer) t- "hoogle" "--no-setup" "--verbosity" "silent")- (0 t))))--(defun intero-hoogle-supported-p ()- "Is the stack hoogle command supported?"- (with-temp-buffer- (cl-case (call-process "stack" nil (current-buffer) t- "hoogle" "--help")- (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 (regexp-opt (intero-extensions)))- (quoted-symbol-regex "[‘`‛]\\([^ ]+\\)['’]"))- (cl-loop- for msg in msgs- do (let ((text (flycheck-error-message msg))- (note nil))- ;; 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 (string-match extension-regex text start)- (setq note t)- (add-to-list 'intero-suggestions- (list :type 'add-extension- :extension (match-string 0 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:- ;;- ;; 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:- ;;- ;; 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:- ;;- ;; 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 (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- (split-string- (shell-command-to-string- "stack 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-extension- (list :key suggestion- :title (concat "Add {-# LANGUAGE "- (plist-get suggestion :extension)- " #-}")- :default t))- (add-ghc-option- (list :key suggestion- :title (concat "Add {-# OPTIONS_GHC "- (plist-get suggestion :option)- " #-}")- :default t))- (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)- (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))))))- ;; # 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))- (insert "{-# LANGUAGE "- (plist-get suggestion :extension)- " #-}\n")))- (add-ghc-option- (save-excursion- (goto-char (point-min))- (insert "{-# OPTIONS_GHC "- (plist-get suggestion :option)- " #-}\n"))))))))))--(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))+;; 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+;; 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+ "0.1.21"+ "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)"+ :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)"+ :group 'intero+ :type 'string)++(defcustom intero-stack-executable+ "stack"+ "Name or path to the Stack executable to use."+ :group 'intero+ :type '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)+ (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."+ (cl-some (lambda (directory)+ (file-in-directory-p file directory))+ dirs))++(defun intero-mode-maybe ()+ "Enable `intero-mode' in all Haskell mode buffers.+The buffer's filename (or working directory) is checked against+`intero-whitelist' and `intero-blacklist'. If both the whitelist+and blacklist match, then the whitelist entry wins, and+`intero-mode' is enabled."+ (when (and (derived-mode-p 'haskell-mode)+ (let* ((file (or (buffer-file-name) default-directory))+ (blacklisted (intero-directories-contain-file+ file intero-blacklist))+ (whitelisted (intero-directories-contain-file+ file intero-whitelist)))+ (or whitelisted (not blacklisted))))+ (intero-mode 1)))++;;;###autoload+(define-globalized-minor-mode intero-global-mode+ intero-mode intero-mode-maybe)++(define-obsolete-function-alias 'global-intero-mode 'intero-global-mode)+++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Global variables/state++(defvar intero-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-arguments (list)+ "Arguments used to call the stack process.")++(defvar-local intero-targets (list)+ "Targets used for the stack process.")++(defvar-local intero-start-time nil+ "Start time of the stack process.")++(defvar-local intero-source-buffer (list)+ "Buffer from which Intero was first requested to start.")++(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-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-repl-last-loaded+ nil+ "The last loaded thing with `intero-repl-load`.")++(defvar-local intero-buffer-host nil+ "The hostname of the box hosting the intero process for the current buffer.")++(defvar-local intero-stack-yaml nil+ "The yaml file that intero should tell stack to use. When nil,+ intero relies on stack's default, usually the 'stack.yaml' in+ the project root.")++(defun intero-inherit-local-variables (buffer)+ "Make the current buffer inherit values of certain local variables from BUFFER."+ (let ((variables '(intero-stack-executable+ intero-repl-no-build+ intero-repl-no-load+ intero-stack-yaml+ ;; TODO: shouldn’t more of the above be here?+ )))+ (cl-loop for v in variables do+ (set (make-local-variable v) (buffer-local-value v buffer)))))++(defmacro intero-with-temp-buffer (&rest body)+ "Run BODY in `with-temp-buffer', but inherit certain local variables from the current buffer first."+ (declare (indent 0) (debug t))+ `(let ((initial-buffer (current-buffer)))+ (with-temp-buffer+ (intero-inherit-local-variables initial-buffer)+ ,@body)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Interactive commands++(defun intero-add-package (package)+ "Add a 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 " 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* ((fp (match-string 1 use))+ (sline (string-to-number (match-string 2 use)))+ (scol (string-to-number (match-string 3 use)))+ (eline (string-to-number (match-string 4 use)))+ (ecol (string-to-number (match-string 5 use)))+ (start (save-excursion (goto-char (point-min))+ (forward-line (1- sline))+ (forward-char (1- scol))+ (point))))+ (when (string= fp (intero-temp-file-name))+ (unless highlighted+ (intero-highlight-uses-mode))+ (setq highlighted t)+ (intero-highlight-uses-mode-highlight+ start+ (save-excursion (goto-char (point-min))+ (forward-line (1- eline))+ (forward-char (1- ecol))+ (point))+ (= start (car thing))))))))))++(defun intero-type-at (insert)+ "Get the type of the thing or selection at point.++With prefix argument INSERT, inserts the type above the current+line as a type signature."+ (interactive "P")+ (let* ((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))))+ (when (string-match "\\(.*?\\):(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))$"+ 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 loaded-file))+ (pop-mark)+ (goto-char (point-min))+ (forward-line (1- line))+ (forward-char (1- col))+ t))))++(defmacro intero-with-dump-splices (exp)+ "Run EXP but with dump-splices enabled in the intero backend process."+ `(when (intero-blocking-call 'backend ":set -ddump-splices")+ (let ((result ,exp))+ (progn+ nil ; Disable dump-splices here in future+ result))))++(defun intero-expand-splice-at-point ()+ "Show the expansion of the template haskell splice at point."+ (interactive)+ (unless (intero-gave-up 'backend)+ (intero-with-dump-splices+ (let* ((output (intero-blocking-call+ 'backend+ (concat ":l " (intero-localize-path (intero-temp-file-name)))))+ (msgs (intero-parse-errors-warnings-splices nil (current-buffer) output))+ (line (line-number-at-pos))+ (column (if (save-excursion+ (forward-char 1)+ (looking-back "$(" 1))+ (+ 2 (current-column))+ (if (looking-at "$(")+ (+ 3 (current-column))+ (1+ (current-column)))))+ (expansion-msg+ (cl-loop for msg in msgs+ when (and (eq (flycheck-error-level msg) 'splice)+ (= (flycheck-error-line msg) line)+ (<= (flycheck-error-column msg) column))+ return (flycheck-error-message msg)))+ (expansion+ (when expansion-msg+ (string-trim+ (replace-regexp-in-string "^Splicing expression" "" expansion-msg)))))+ (when expansion+ (message "%s" (intero-fontify-expression expansion)))))))++(defun intero-restart ()+ "Simply restart the process with the same configuration as before."+ (interactive)+ (when (intero-buffer-p 'backend)+ (let ((targets (with-current-buffer (intero-buffer 'backend)+ intero-targets))+ (stack-yaml (with-current-buffer (intero-buffer 'backend)+ intero-stack-yaml)))+ (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+ (with-current-buffer (intero-buffer 'backend)+ intero-targets))+ (available-targets (intero-get-targets)))+ (if available-targets+ (intero-multiswitch+ "Set the targets to use for stack ghci:"+ (mapcar (lambda (target)+ (list :key target+ :title target+ :default (member target old-targets)))+ available-targets))+ (split-string (read-from-minibuffer "Targets: " nil nil nil nil old-targets)+ " "+ t))))++(defun intero-targets (targets save-dir-local)+ "Set the TARGETS to use for stack ghci.+When SAVE-DIR-LOCAL is non-nil, save TARGETS as the+directory-local value for `intero-targets'."+ (interactive (list (intero-read-targets)+ (y-or-n-p "Save selected target(s) in directory local variables for future sessions? ")))+ (intero-destroy)+ (intero-get-worker-create 'backend targets (current-buffer))+ (intero-repl-restart)+ (when save-dir-local+ (save-window-excursion+ (let ((default-directory (intero-project-root)))+ (add-dir-local-variable 'haskell-mode 'intero-targets targets)+ (save-buffer)))))++(defun intero-stack-yaml (file save-dir-local)+ "Change the yaml FILE that intero should tell stack to use.+Intero will be restarted with the new configuration. When+SAVE-DIR-LOCAL is non-nil, save FILE as the directory-local value+for `intero-stack-yaml'."+ (interactive (list (read-file-name+ "Select YAML config: "+ (file-name-as-directory (intero-project-root)))+ (y-or-n-p "Save selected stack yaml config in directory local variable for future sessions? ")))+ (let ((stack-yaml (expand-file-name file)))+ (setq intero-stack-yaml stack-yaml)+ (with-current-buffer (intero-buffer 'backend)+ (setq intero-stack-yaml stack-yaml))+ (intero-restart)+ (intero-repl-restart)+ (when save-dir-local+ (save-window-excursion+ (let ((default-directory (intero-project-root)))+ (add-dir-local-variable 'haskell-mode 'intero-stack-yaml stack-yaml)+ (save-buffer))))))++(defun intero-destroy (&optional worker)+ "Stop WORKER and kill its associated process buffer.+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+ ":l DevelMain"+ (current-buffer)+ (lambda (buffer reply)+ (if (string-match "^OK, 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++(defvar-local intero-check-last-hash nil+ "Most recent hash for the current buffer when flycheck was last triggered.")++(defvar-local intero-check-last-results nil+ "Most recent flycheck results for the current buffer.")++(defun intero-check-reuse-last-results (hash cont)+ "If HASH is not new, return non-nil and call CONT with `intero-check-last-results'."+ (let ((reuse (and intero-check-last-hash+ (equal hash intero-check-last-hash))))+ (progn+ (when reuse+ (funcall cont 'finished intero-check-last-results))+ reuse)))++(defun intero-flycheck-enable ()+ "Enable intero's flycheck support in this buffer."+ (flycheck-select-checker 'intero)+ (setq intero-check-last-mod-time nil+ intero-check-last-results nil)+ (flycheck-mode))++(defun intero-check-calculate-hash ()+ "Calculate a hash for the current buffer that will change when it needs re-checking."+ (secure-hash+ 'md5+ (concat (prin1-to-string intero-start-time) ; Force re-check after intero-restart+ (buffer-substring-no-properties (point-min) (point-max)))))++(defun intero-check (checker cont)+ "Run a check with CHECKER and pass the status onto CONT."+ (if (intero-gave-up 'backend)+ (run-with-timer 0+ nil+ cont+ 'interrupted)+ (let* ((file-buffer (current-buffer))+ (temp-file (intero-localize-path (intero-temp-file-name)))+ (hash (intero-check-calculate-hash)))+ (unless (intero-check-reuse-last-results hash cont)+ (intero-async-call+ 'backend+ (concat ":l " temp-file)+ (list :cont cont+ :file-buffer file-buffer+ :hash hash+ :checker checker)+ (lambda (state string)+ (with-current-buffer (plist-get state :file-buffer)+ (unless (intero-check-reuse-last-results (plist-get state :hash)+ (plist-get state :cont))+ (let* ((compile-ok (string-match "OK, modules loaded: \\(.*\\)\\.$" string))+ (modules (match-string 1 string))+ (msgs (intero-parse-errors-warnings-splices+ (plist-get state :checker)+ (current-buffer)+ string)))+ (intero-collect-compiler-messages msgs)+ (let ((results (cl-remove-if (lambda (msg)+ (eq 'splice (flycheck-error-level msg)))+ msgs)))+ (setq intero-check-last-hash (plist-get state :hash)+ intero-check-last-results results)+ (funcall (plist-get state :cont) 'finished results))+ (when compile-ok+ (intero-async-call 'backend+ (concat ":m + "+ (replace-regexp-in-string modules "," ""))+ nil+ (lambda (_st _)))))))))))))+++(flycheck-define-generic-checker 'intero+ "A syntax and type checker for Haskell using an Intero worker+process."+ :start 'intero-check+ :modes '(haskell-mode literate-haskell-mode)+ :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)))+ (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 (match-string 3)) ;; Replace gross bullet points.+ (type (cond ((string-match "^Warning:" msg)+ (setq msg (replace-regexp-in-string "^Warning: *" "" msg))+ (if (string-match "^\\[-Wdeferred-type-errors\\]" msg)+ 'error+ 'warning))+ ((string-match "^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 (when (intero-paths-for-same-file temp-file file)+ buffer)+ :filename (intero-buffer-file-name buffer))+ messages)))+ (forward-line -1))+ (delete-dups 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."+ (let ((span nil))+ (cl-loop for regex+ in intero-error-regexp-alist+ do (when (string-match (car regex) string)+ (setq span+ (list :file (match-string 1 string)+ :line (string-to-number (match-string 2 string))+ :col (string-to-number (match-string 4 string))+ :line2 (when (match-string 3 string)+ (string-to-number (match-string 3 string)))+ :col2 (when (match-string 5 string)+ (string-to-number (match-string 5 string)))))))+ span))++(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)))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; 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)+ (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 ((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-match (concat "^" 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)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; 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)+ (pop-to-buffer ,repl-buffer))))++(defun intero-repl-load (&optional prompt-options)+ "Load the current file in the REPL.+If PROMPT-OPTIONS is non-nil, prompt with an options list."+ (interactive "P")+ (save-buffer)+ (let ((file (intero-localize-path (intero-temp-file-name))))+ (intero-with-repl-buffer prompt-options+ (comint-simple-send+ (get-buffer-process (current-buffer))+ (concat ":l " file))+ (setq intero-repl-last-loaded file))))++(defun intero-repl-eval-region (begin end &optional prompt-options)+ "Evaluate the code in region from BEGIN to END in the REPL.+If the region is unset, the current line will be used.+PROMPT-OPTIONS are passed to `intero-repl-buffer' if supplied."+ (interactive "r")+ (unless (use-region-p)+ (setq begin (line-beginning-position)+ end (line-end-position)))+ (let ((text (buffer-substring-no-properties begin end)))+ (intero-with-repl-buffer prompt-options+ (comint-simple-send+ (get-buffer-process (current-buffer))+ 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.")++(defun intero-find-file-with-line-and-char ()+ "Jump to the file and location indicated by text properties at point."+ (interactive)+ (let ((file (get-text-property (point) 'file))+ (line (get-text-property (point) 'line))+ (char (get-text-property (point) 'char)))+ (with-no-warnings (find-file-other-window file))+ (goto-char (point-min))+ (forward-line (1- line))+ (forward-char (1- char))))++(defun intero-linkify-file-line-char (begin end)+ "Linkify all occurences of <file>:<line>:<char>: betwen BEGIN and END."+ (when (> end begin)+ (let ((end-marker (copy-marker end))+ ;; match - /path/to/file.ext:<line>:<char>:+ ;; - /path/to/file.ext:<line>:<char>-+ ;; - /path/to/file.ext:(<line>:<char>)+ (file:line:char-regexp "\\([A-Z]?:?[^ \r\n:][^:\n\r]+\\)[:](?\\([0-9]+\\)[:,]\\([0-9]+\\)[:)-]"))+ (save-excursion+ (goto-char begin)+ ;; Delete unrecognized escape sequences.+ (while (re-search-forward file:line:char-regexp end-marker t)+ (let ((file (match-string-no-properties 1))+ (line (match-string-no-properties 2))+ (char (match-string-no-properties 3))+ (link-start (1+ (match-beginning 1)))+ (link-end (1+ (match-end 2))))+ (let ((unmangled-file (intero-unmangle-file-path file)))+ (when unmangled-file+ (setq file unmangled-file)+ (replace-match unmangled-file nil nil nil 1)))+ (add-text-properties+ link-start link-end+ (list 'keymap intero-hyperlink-map+ 'file file+ 'line (string-to-number line)+ 'char (string-to-number char)+ 'help-echo "mouse-2: visit this file"))))))))++(defvar intero-last-output-newline-marker nil)++(defun intero-linkify-process-output (_)+ "Comint filter function to make <file>:<line>:<char>: into clickable links.++Note that this function uses the `intero-last-output-newline-marker',+to keep track of line breaks. The `intero-linkify-file-line-char'+function is subsequently applied to each line, once."+ (unless intero-last-output-newline-marker+ (setq-local intero-last-output-newline-marker (make-marker))+ (set-marker intero-last-output-newline-marker (marker-position comint-last-output-start)))+ (let ((start-marker (if (and (markerp intero-last-output-newline-marker)+ (eq (marker-buffer intero-last-output-newline-marker)+ (current-buffer))+ (marker-position intero-last-output-newline-marker))+ comint-last-output-start+ (point-min-marker)))+ (end-marker (process-mark (get-buffer-process (current-buffer)))))+ (save-excursion+ (goto-char start-marker)+ (while (re-search-forward "[\n\r]" end-marker t)+ (intero-linkify-file-line-char intero-last-output-newline-marker (match-beginning 0))+ (set-marker intero-last-output-newline-marker (match-end 0))))))++(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))+ (add-hook 'comint-output-filter-functions+ 'intero-linkify-process-output+ t t)+ (setq-local comint-prompt-read-only t)+ (add-hook 'completion-at-point-functions 'intero-completion-at-point nil t)+ (add-to-list (make-local-variable 'company-backends) 'intero-company)+ (company-mode))++(defun intero-repl-mode-start (backend-buffer targets prompt-options 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-repl-last-loaded nil)+ (setq intero-targets targets)+ (when stack-yaml+ (setq intero-stack-yaml stack-yaml))+ (when prompt-options+ (intero-repl-options backend-buffer))+ (let ((stack-yaml (if stack-yaml+ stack-yaml+ (buffer-local-value 'intero-stack-yaml backend-buffer)))+ (arguments (intero-make-options-list+ (or targets+ (let ((package-name (buffer-local-value 'intero-package-name+ backend-buffer)))+ (unless (equal "" package-name)+ (list package-name))))+ (buffer-local-value 'intero-repl-no-build backend-buffer)+ (buffer-local-value 'intero-repl-no-load backend-buffer)+ 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 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)))))))+ (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 (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 (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 (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 "[[: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))+ path))))+ (string= (funcall simplify-path path-1) (funcall simplify-path path-2))))++(defun intero-buffer-host (&optional buffer)+ "Get the hostname of the box hosting the file behind the BUFFER."+ (with-current-buffer (or buffer (current-buffer))+ (let ((file (intero-buffer-file-name)))+ (if intero-buffer-host+ intero-buffer-host+ (setq intero-buffer-host+ (when file+ (if (tramp-tramp-file-p file)+ (tramp-file-name-host (tramp-dissect-file-name file))+ "")))))))++(defun intero-extend-path-by-buffer-host (path &optional buffer)+ "Take a PATH, and extend it by the host of the provided BUFFER (default to current buffer). Return PATH unchanged if the file is local, or the BUFFER has no host."+ (with-current-buffer (or buffer (current-buffer))+ (if (or (eq nil (intero-buffer-host)) (eq "" (intero-buffer-host)))+ path+ (concat "/"+ (intero-buffer-host)+ ":"+ path))))++(defvar-local intero-temp-file-name nil+ "The name of a temporary file to which the current buffer's content is copied.")++(defun intero-temp-file-p (path)+ "Is PATH a temp file?"+ (string= (file-name-directory path)+ (file-name-directory (intero-temp-file-dir))))++(defun intero-temp-file-origin-buffer (temp-file)+ "Get the original buffer that TEMP-FILE was created for."+ (or+ (gethash (intero-canonicalize-path temp-file)+ intero-temp-file-buffer-mapping)+ (cl-loop+ for buffer in (buffer-list)+ when (string= (intero-canonicalize-path temp-file)+ (buffer-local-value 'intero-temp-file-name buffer))+ return buffer)))++(defun intero-unmangle-file-path (file)+ "If FILE is an intero temp file, return the original source path, otherwise FILE."+ (or (when (intero-temp-file-p file)+ (let ((origin-buffer (intero-temp-file-origin-buffer file)))+ (when origin-buffer+ (buffer-file-name origin-buffer))))+ file))++(defun intero-make-temp-file (prefix &optional dir-flag suffix)+ "Like `make-temp-file', but using a different temp directory.+PREFIX, DIR-FLAG and SUFFIX are all passed to `make-temp-file'+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 containing an up-to-date copy of BUFFER's contents."+ (with-current-buffer (or buffer (current-buffer))+ (prog1+ (or intero-temp-file-name+ (progn (setq intero-temp-file-name+ (intero-canonicalize-path+ (intero-make-temp-file+ "intero" nil+ (concat "." (if (buffer-file-name)+ (file-name-extension (buffer-file-name))+ "hs")))))+ (puthash intero-temp-file-name+ (current-buffer)+ intero-temp-file-buffer-mapping)+ intero-temp-file-name))+ (let* ((contents (buffer-string))+ (fname intero-temp-file-name)+ (prev-contents (and (file-readable-p fname)+ (with-temp-buffer+ (insert-file-contents fname)+ (buffer-string)))))+ (unless (and prev-contents (string-equal contents prev-contents))+ (with-temp-file intero-temp-file-name+ (insert contents)))))))++(defun intero-localize-path (path)+ "Turn a possibly-remote PATH to a purely local one.+This is used to create paths which a remote intero process can load."+ (if (tramp-tramp-file-p path)+ (tramp-file-name-localname (tramp-dissect-file-name path))+ path))++(defun intero-canonicalize-path (path)+ "Return a standardized version of PATH.+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-call 'backend ":all-types"))++(defun intero-get-type-at (beg end)+ "Get the type at the given region denoted by BEG and 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-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-localize-path (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 ":i %s" thing)))))+ (if (string-match "^<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 ":l " (intero-localize-path (intero-temp-file-name)))))+ (intero-async-call+ 'backend+ ":set -fobject-code")+ (replace-regexp-in-string+ "\n$" ""+ (intero-blocking-call+ 'backend+ (format ":i %s" thing))))+ optimistic-result)))++(defun intero-get-loc-at (beg end)+ "Get the location of the identifier denoted by BEG and END."+ (replace-regexp-in-string+ "\n$" ""+ (intero-blocking-call+ 'backend+ (format ":loc-at %S %d %d %d %d %S"+ (intero-localize-path (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."+ (replace-regexp-in-string+ "\n$" ""+ (intero-blocking-call+ 'backend+ (format ":uses %S %d %d %d %d %S"+ (intero-localize-path (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-call+ 'backend+ (format ":complete-at %S %d %d %d %d %S"+ (intero-localize-path (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 "^*** 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)))+ (with-current-buffer (intero-buffer worker)+ (while (not (null intero-callbacks))+ (sleep-for 0.0001)))+ (car result)))++(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)))+ (if (get-buffer-process buffer)+ buffer+ (intero-get-worker-create worker nil (current-buffer)+ (buffer-local-value+ 'intero-stack-yaml (current-buffer))))))++(defun intero-process (worker)+ "Get the WORKER process for the current directory."+ (get-buffer-process (intero-buffer worker)))++(defun intero-get-worker-create (worker &optional targets source-buffer 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."))+ (format "++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")+ (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+ (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 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+ (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 "^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 (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"+ "intero"+ "--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"))+ (let ((dir (intero-localize-path (intero-make-temp-file "intero" t))))+ (list "--ghci-options"+ (concat "-odir=" dir)+ "--ghci-options"+ (concat "-hidir=" dir)))+ 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-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" "--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))+ "++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."+ (with-current-buffer (intero-buffer 'backend)+ (or intero-ghc-version+ (setq intero-ghc-version+ (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-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 "^[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 'file-directory-p+ (cl-remove-if-not 'file-exists-p+ (directory-files dir t ".\\.cabal\\'")))))+ (cond+ ((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found+ (allow-multiple cabal-files) ;; pass-thru multiple candidates+ (t nil))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Multiselection++(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.\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+ (let ((map (copy-keymap widget-keymap)))+ (define-key map (kbd "C-c C-c") 'exit-recursive-edit)+ (define-key map (kbd "C-c C-k") 'abort-recursive-edit)+ (define-key map (kbd "C-g") 'abort-recursive-edit)+ map))+ (widget-setup)+ (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 (regexp-opt (intero-extensions)))+ (quoted-symbol-regex "[‘`‛]\\([^ ]+\\)['’]"))+ (cl-loop+ for msg in msgs+ do (let ((text (flycheck-error-message msg))+ (note nil))+ ;; 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 (string-match extension-regex text start)+ (setq note t)+ (add-to-list 'intero-suggestions+ (list :type 'add-extension+ :extension (match-string 0 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+ (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))+ (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 t))+ (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 "^[_a-zA-Z]" (plist-get suggestion :ident))+ (plist-get suggestion :ident)+ (concat "(" (plist-get suggestion :ident) ")")))+ (unless (looking-at "[:space:]*)")+ (insert ", ")))))+ (redundant-import-item+ (save-excursion+ (goto-char (point-min))+ (forward-line (1- (plist-get suggestion :line)))+ (let* ((start (point))+ (end (or (save-excursion+ (when (search-forward-regexp "\n[^ \t]" nil t 1)+ (1- (point))))+ (line-end-position)))+ (regex+ (concat+ "\\("+ (mapconcat+ (lambda (ident)+ (if (string-match "^[_a-zA-Z]" ident)+ (concat "\\<" (regexp-quote ident) "\\>")+ (concat "(" (regexp-quote ident) ")")))+ (plist-get suggestion :idents)+ "\\|")+ "\\)"))+ (string (buffer-substring start end)))+ (delete-region start end)+ (insert (replace-regexp-in-string+ "([\n ]*," "("+ (replace-regexp-in-string+ "[\n ,]*,[\n ,]*" ", "+ (replace-regexp-in-string+ ",[\n ]*)" ")"+ (replace-regexp-in-string+ regex ""+ string))))+ (make-string (1- (length (split-string string "\n" t))) 10)))))+ (fix-typo+ (save-excursion+ (goto-char (point-min))+ (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))))))+ ;; # 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))+ (insert "{-# LANGUAGE "+ (plist-get suggestion :extension)+ " #-}\n")))+ (add-ghc-option+ (save-excursion+ (goto-char (point-min))+ (insert "{-# OPTIONS_GHC "+ (plist-get suggestion :option)+ " #-}\n"))))))))))++(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 "C-g") 'intero-highlight-uses-mode)+ (define-key map (kbd "q") 'intero-highlight-uses-mode)+ map)+ "Keymap for using `intero-highlight-uses-mode'.")++(defvar-local intero-highlight-uses-mode-point nil)+(defvar-local intero-highlight-uses-buffer-old-mode nil)++;;;###autoload+(define-minor-mode intero-highlight-uses-mode+ "Minor mode for highlighting and jumping between uses."+ :lighter " Uses"+ :keymap intero-highlight-uses-mode-map+ (if intero-highlight-uses-mode+ (progn (setq intero-highlight-uses-buffer-old-mode buffer-read-only)+ (setq buffer-read-only t)+ (setq intero-highlight-uses-mode-point (point)))+ (progn (setq buffer-read-only intero-highlight-uses-buffer-old-mode)+ (when intero-highlight-uses-mode-point+ (goto-char intero-highlight-uses-mode-point))))+ (remove-overlays (point-min) (point-max) 'intero-highlight-uses-mode-highlight t))++(defun intero-highlight-uses-mode-replace ()+ "Replace all highlighted instances in the buffer with something else."+ (interactive)+ (save-excursion+ (goto-char (point-min))+ (let ((o (intero-highlight-uses-mode-next)))+ (when o+ (let ((replacement+ (read-from-minibuffer+ (format "Replace uses %s with: "+ (buffer-substring+ (overlay-start o)+ (overlay-end o))))))+ (let ((inhibit-read-only t))+ (while o+ (goto-char (overlay-start o))+ (delete-region (overlay-start o)+ (overlay-end o))+ (insert replacement)+ (setq o (intero-highlight-uses-mode-next))))))))+ (intero-highlight-uses-mode -1))++(defun intero-highlight-uses-mode-stop-here ()+ "Stop at this point."+ (interactive)+ (setq intero-highlight-uses-mode-point (point))+ (intero-highlight-uses-mode -1))++(defun intero-highlight-uses-mode-next ()+ "Jump to next result."+ (interactive)+ (let ((os (sort (cl-remove-if (lambda (o)+ (or (<= (overlay-start o) (point))+ (not (overlay-get o 'intero-highlight-uses-mode-highlight))))+ (overlays-in (point) (point-max)))+ (lambda (a b)+ (< (overlay-start a)+ (overlay-start b))))))+ (when os+ (mapc+ (lambda (o)+ (when (overlay-get o 'intero-highlight-uses-mode-highlight)+ (overlay-put o 'face 'lazy-highlight)))+ (overlays-in (line-beginning-position) (line-end-position)))+ (goto-char (overlay-start (car os)))+ (overlay-put (car os) 'face 'isearch)+ (car os))))++(defun intero-highlight-uses-mode-prev ()+ "Jump to previous result."+ (interactive)+ (let ((os (sort (cl-remove-if (lambda (o)+ (or (>= (overlay-end o) (point))+ (not (overlay-get o 'intero-highlight-uses-mode-highlight))))+ (overlays-in (point-min) (point)))+ (lambda (a b)+ (> (overlay-start a)+ (overlay-start b))))))+ (when os+ (mapc+ (lambda (o)+ (when (overlay-get o 'intero-highlight-uses-mode-highlight)+ (overlay-put o 'face 'lazy-highlight)))+ (overlays-in (line-beginning-position) (line-end-position)))+ (goto-char (overlay-start (car os)))+ (overlay-put (car os) 'face 'isearch)+ (car os))))++(defun intero-highlight-uses-mode-highlight (start end current)+ "Make a highlight overlay at the span from START to END.+If CURRENT, highlight the span uniquely."+ (let ((o (make-overlay start end)))+ (overlay-put o 'priority 999)+ (overlay-put o 'face+ (if current+ 'isearch+ 'lazy-highlight))+ (overlay-put o 'intero-highlight-uses-mode-highlight t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
intero.cabal view
@@ -1,7 +1,7 @@ name: intero version:- 0.1.20+ 0.1.21 synopsis: Complete interactive development program for Haskell license:@@ -56,6 +56,8 @@ cbits/hschooks.c cpp-options: -DGHCI+ cc-options:+ -fPIC other-modules: InteractiveUI GhciMonad@@ -63,14 +65,15 @@ GhciTypes GhciInfo GhciFind+ Paths_intero build-depends: base < 5, array, bytestring, directory, filepath,- -- We permit any 8.0.1.*- ghc >= 7.8 && < 8.0.2,+ -- We permit any 8.0.1.* or 8.0.2.* or 8.2.1+ ghc >= 7.8 && < 8.2.2, ghc-paths, haskeline, process,
src/GhciFind.hs view
@@ -50,7 +50,11 @@ Just name | otherwise = Nothing where name = unLoc (ideclName m)+#if __GLASGOW_HASKELL__ >= 802+ asName = fmap (moduleNameString . unLoc) . ideclAs+#else asName = fmap moduleNameString . ideclAs+#endif -- | Find completions for the sample, context given by the location. findCompletions :: (GhcMonad m)@@ -218,21 +222,35 @@ Nothing -> return (Left ("No module info for the current file! Try loading it?")) Just info ->- do mname' <- findName infos info string sl sc el ec- d <- getSessionDynFlags- case mname' of- Left reason ->- return (Left reason)- Right name' ->- case getSrcSpan name' of- UnhelpfulSpan{} ->- return (Left ("Found a name, but no location information. The module is: " ++- maybe "<unknown>"- (showppr d . moduleName)- (nameModule_maybe name')))- span' ->- return (Right span')+ case findImportLoc infos info sl sc el ec of+ Just result -> return (Right result)+ Nothing ->+ do mname' <- findName infos info string sl sc el ec+ d <- getSessionDynFlags+ case mname' of+ Left reason ->+ return (Left reason)+ Right name' ->+ case getSrcSpan name' of+ UnhelpfulSpan{} ->+ return (Left ("Found a name, but no location information. The module is: " +++ maybe "<unknown>"+ (showppr d . moduleName)+ (nameModule_maybe name')))+ span' ->+ return (Right span') +findImportLoc :: (Map ModuleName ModInfo) -> ModInfo -> Int -> Int -> Int -> Int -> Maybe SrcSpan+findImportLoc infos info sl sc el ec =+ do importedModuleName <- getModuleImportedAt info sl sc el ec+ importedModInfo <- M.lookup importedModuleName infos+ return (modinfoLocation importedModInfo)++getModuleImportedAt :: ModInfo -> Int -> Int -> Int -> Int -> Maybe ModuleName+getModuleImportedAt info sl sc el ec = fmap (unLoc . ideclName . unLoc) importDeclarationMaybe+ where importDeclarationMaybe = listToMaybe $ filter isWithinRange (modinfoImports info)+ isWithinRange importDecl = containsSrcSpan sl sc el ec (getLoc $ ideclName $ unLoc importDecl)+ -- | Try to resolve the name located at the given position, or -- otherwise resolve based on the current module's scope. findName :: GhcMonad m@@ -364,14 +382,18 @@ Nothing -> return (FindType minfo ty) _ -> fmap (FindType minfo)- (exprType string)+#if __GLASGOW_HASKELL__ >= 802+ (exprType TM_Inst string)+#else+ (exprType string) +#endif -- | Try to resolve the type display from the given span. resolveSpanInfo :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe SpanInfo resolveSpanInfo spanList spanSL spanSC spanEL spanEC = listToMaybe (sortBy (flip compareSpanInfoStart)- (filter (contains spanSL spanSC spanEL spanEC) spanList))+ (filter (containsSpanInfo spanSL spanSC spanEL spanEC) spanList)) -- | Compare the start of two span infos. compareSpanInfoStart :: SpanInfo -> SpanInfo -> Ordering@@ -381,8 +403,17 @@ c -> c -- | Does the 'SpanInfo' contain the location given by the Ints?-contains :: Int -> Int -> Int -> Int -> SpanInfo -> Bool-contains spanSL spanSC spanEL spanEC (SpanInfo ancestorSL ancestorSC ancestorEL ancestorEC _ _) =+containsSpanInfo :: Int -> Int -> Int -> Int -> SpanInfo -> Bool+containsSpanInfo spanSL spanSC spanEL spanEC (SpanInfo ancestorSL ancestorSC ancestorEL ancestorEC _ _) =+ contains spanSL spanSC spanEL spanEC ancestorSL ancestorSC ancestorEL ancestorEC++containsSrcSpan :: Int -> Int -> Int -> Int -> SrcSpan -> Bool+containsSrcSpan spanSL spanSC spanEL spanEC (RealSrcSpan spn) =+ contains spanSL spanSC spanEL spanEC (srcSpanStartLine spn) (srcSpanStartCol spn - 1) (srcSpanEndLine spn) (srcSpanEndCol spn - 1)+containsSrcSpan _ _ _ _ _ = False++contains :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool+contains spanSL spanSC spanEL spanEC ancestorSL ancestorSC ancestorEL ancestorEC = ((ancestorSL == spanSL && spanSC >= ancestorSC) || (ancestorSL < spanSL)) && ((ancestorEL == spanEL && spanEC <= ancestorEC) || (ancestorEL > spanEL))
src/GhciInfo.hs view
@@ -6,9 +6,11 @@ module GhciInfo (collectInfo,getModInfo,showppr) where +import ConLike import Control.Exception import Control.Monad import qualified CoreUtils+import DataCon import Data.Data import Data.Generics (GenericQ, mkQ, extQ) import Data.List@@ -75,13 +77,19 @@ getModInfo name = do m <- getModSummary name p <- parseModule m+ let location = getModuleLocation (parsedSource p) typechecked <- typecheckModule p let Just (_, imports, _, _) = renamedSource typechecked allTypes <- processAllTypeCheckedModule typechecked let i = tm_checked_module_info typechecked now <- liftIO getCurrentTime- return (ModInfo m allTypes i now imports)+ return (ModInfo m allTypes i now imports location) +getModuleLocation :: ParsedSource -> SrcSpan+getModuleLocation pSource = case hsmodName (unLoc pSource) of+ Just located -> getLoc located+ Nothing -> noSrcSpan+ -- | Get ALL source spans in the module. processAllTypeCheckedModule :: GhcMonad m => TypecheckedModule -> m [SpanInfo]@@ -149,8 +157,11 @@ getTypeLPat :: (GhcMonad m) => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat _ (L spn pat) =- return (Just (getMaybeId pat,spn,hsPatType pat))+ return (Just (getMaybeId pat,spn,getPatType pat)) where+ getPatType (ConPatOut (L _ (RealDataCon dc)) _ _ _ _ _ _) =+ dataConRepType dc+ getPatType pat' = hsPatType pat' #if __GLASGOW_HASKELL__ >= 800 getMaybeId (VarPat (L _ vid)) = Just vid #else
src/GhciMonad.hs view
@@ -299,6 +299,19 @@ liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc -- | Run a single Haskell expression+#if __GLASGOW_HASKELL__ >= 802+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt expr step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printException e;+ return Nothing) $ do+ r <- GHC.execStmt expr (GHC.execOptions { GHC.execSingleStep = step })+ return (Just r)+#else runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) runStmt expr step = do st <- getGHCiState@@ -310,6 +323,7 @@ return Nothing) $ do r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step return (Just r)+#endif runDecls :: String -> GHCi [GHC.Name] runDecls decls = do@@ -321,6 +335,16 @@ GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do GHC.runDeclsWithLocation (progname st) (line_number st) decls +#if __GLASGOW_HASKELL__ >= 802+resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan step+#else resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult resume canLogSpan step = do st <- getGHCiState@@ -329,6 +353,7 @@ withArgs (args st) $ reflectGHCi x $ do GHC.resume canLogSpan step+#endif -- -------------------------------------------------------------------------- -- timing & statistics
src/GhciTypes.hs view
@@ -23,6 +23,8 @@ -- ^ Last time the module was updated. ,modinfoImports :: ![LImportDecl Name] -- ^ Import declarations within this module.+ ,modinfoLocation :: !SrcSpan+ -- ^ The location of the module } -- | Type of some span of source code. Most of these fields are
src/InteractiveUI.hs view
@@ -30,6 +30,9 @@ import GHCi import GHCi.RemoteTypes #endif+#if __GLASGOW_HASKELL__ >= 802+import GHCi.Signals+#endif import qualified Paths_intero import Data.Version (showVersion) import qualified Data.Map as M@@ -60,12 +63,19 @@ setInteractivePrintName ) import Module import Name-#if __GLASGOW_HASKELL__ < 709-import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )-#else++# if __GLASGOW_HASKELL__ >= 802+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, listVisibleModuleNames )+#elif __GLASGOW_HASKELL__ >= 710 import Packages ( trusted, getPackageDetails, listVisibleModuleNames )+#else+import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) #endif+ import PprTyThing+#if __GLASGOW_HASKELL__ >= 802+import IfaceSyn+#endif import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc import qualified Lexer@@ -74,7 +84,12 @@ #if __GLASGOW_HASKELL__ < 709 import UniqFM ( eltsUFM ) #endif++#if __GLASGOW_HASKELL__ >= 802+import Outputable hiding ( printForUser, printForUserPartWay )+#else import Outputable hiding ( printForUser, printForUserPartWay, bold )+#endif -- Other random utilities import BasicTypes hiding ( isTopLevel )@@ -104,6 +119,9 @@ import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy ) import Data.Maybe+#if __GLASGOW_HASKELL__ >= 802+import qualified Data.Set as Set+#endif import Exception hiding (catch) @@ -136,21 +154,34 @@ import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) -#if __GLASGOW_HASKELL__ >= 800+pprTyThing', pprTyThingInContext' :: TyThing -> SDoc+#if __GLASGOW_HASKELL__ >= 802+pprTyThing' = pprTyThingHdr+pprTyThingInContext' = pprTyThingInContext showToHeader +#else+pprTyThing' = pprTyThing+pprTyThingInContext' = pprTyThingInContext+#endif++#if __GLASGOW_HASKELL__ >= 802+modulePackage :: Module -> UnitId+modulePackage = moduleUnitId+#elif __GLASGOW_HASKELL__ >= 800 packageString :: UnitId -> String packageString = unitIdString modulePackage :: Module -> UnitId modulePackage = moduleUnitId-#elif __GLASGOW_HASKELL__ < 709-packageString :: PackageId -> String-packageString = packageIdString-modulePackage :: Module -> PackageId-modulePackage = modulePackageId-#else+#elif __GLASGOW_HASKELL__ >= 710 packageString :: PackageKey -> String packageString = packageKeyString modulePackage :: Module -> PackageKey modulePackage = modulePackageKey+#else+-- 7.8 and below+packageString :: PackageId -> String+packageString = packageIdString+modulePackage :: Module -> PackageId+modulePackage = modulePackageId #endif -----------------------------------------------------------------------------@@ -201,6 +232,7 @@ ("back", keepGoing backCmd, noCompletion), ("browse", keepGoing' (browseCmd False), completeModule), ("browse!", keepGoing' (browseCmd True), completeModule),+ ("extensions", keepGoing' extensionsCmd, completeModule), ("cd", keepGoing' changeDirectory, completeFilename), ("cd-ghc", keepGoing' changeDirectoryGHC, completeFilename), ("check", keepGoing' checkModule, completeHomeModule),@@ -317,6 +349,7 @@ " :add [*]<module> ... add module(s) to the current target set\n" ++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++ " (!: more details; *: all top-level names)\n" +++ " :extensions <mod> display the extensions enabled by module <mod>\n" ++ " :cd <dir> change directory to <dir>\n" ++ " :cmd <expr> run the commands returned by <expr>::IO String\n" ++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++@@ -786,7 +819,11 @@ -- use the 'as' name if there is one myIdeclName d | Just m <- ideclAs d = m+#if __GLASGOW_HASKELL__ >= 802+ | otherwise = ideclName d+#else | otherwise = unLoc (ideclName d)+#endif deflt_prompt = dots <> context_bit <> modules_bit @@ -1016,7 +1053,11 @@ | any (flip isPrefixOf stmt) declPrefixes = do _ <- liftIO $ tryIO $ hFlushAll stdin result <- GhciMonad.runDecls stmt+#if __GLASGOW_HASKELL__ >= 802+ afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)+#else afterRunStmt (const True) (GHC.RunOk result)+#endif | otherwise = do -- In the new IO library, read handles buffer data even if the Handle@@ -1031,11 +1072,43 @@ Just result -> afterRunStmt (const True) result -- | Clean up the GHCi environment after a statement has run-afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool-afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e+#if __GLASGOW_HASKELL__ >= 802+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi Bool+afterRunStmt _ (GHC.ExecComplete (Left e) _) = liftIO $ Exception.throwIO e afterRunStmt step_here run_result = do resumes <- GHC.getResumeContext case run_result of+ GHC.ExecComplete (Right names) _ -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()+ _ -> return ()++ flushInterpBuffers+ liftIO installSignalHandlers+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return (case run_result of GHC.ExecComplete _ _ -> True; _ -> False)+#else+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool +afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e +afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of GHC.RunOk names -> do show_types <- isOptionSet ShowType when show_types $ printTypeOfNames names@@ -1061,6 +1134,7 @@ when b revertCAFs return (case run_result of GHC.RunOk _ -> True; _ -> False)+#endif toBreakIdAndLocation :: Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))@@ -1687,7 +1761,11 @@ typeOfExpr str = handleSourceError GHC.printException $ do+#if __GLASGOW_HASKELL__ >= 802+ ty <- GHC.exprType GHC.TM_Inst str+#else ty <- GHC.exprType str+#endif printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)] -----------------------------------------------------------------------------@@ -1710,7 +1788,7 @@ (sep [text sample,nest 2 (dcolon <+> ppr ty)]) FindTyThing info' tything -> printForUserModInfo (modinfoInfo info')- (pprTyThing tything))+ (pprTyThing' tything)) ----------------------------------------------------------------------------- -- :uses@@ -1944,20 +2022,26 @@ (msafe, pkgs) <- GHC.moduleTrustReqs m let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface pkg = if packageTrusted dflags m then "trusted" else "untrusted"+#if __GLASGOW_HASKELL__ >= 802+ (good, bad) = tallyPkgs dflags (Set.toList pkgs)+ getPackageStrings = map installedUnitIdString+#else (good, bad) = tallyPkgs dflags pkgs+ getPackageStrings = map packageString+#endif -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") when (not $ null good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++- (intercalate ", " $ map packageString good))+ (intercalate ", " $ getPackageStrings good)) case msafe && null bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do when (not $ null bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "- ++ (intercalate ", " $ map packageString bad))+ ++ (intercalate ", " $ getPackageStrings bad)) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where@@ -1965,22 +2049,53 @@ packageTrusted dflags md | thisPackage dflags == modulePackage md = True-#if __GLASGOW_HASKELL__ < 709- | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackage md)-#else+#if __GLASGOW_HASKELL__ >= 710 | otherwise = trusted $ getPackageDetails dflags (modulePackage md)+#else+ | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackage md) #endif tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], []) | otherwise = partition part deps where-#if __GLASGOW_HASKELL__ < 709+#if __GLASGOW_HASKELL__ >= 802+ part pkg = trusted $ getInstalledPackageDetails dflags pkg+#elif __GLASGOW_HASKELL__ >= 710+ part pkg = trusted $ getPackageDetails dflags pkg+#else part pkg = trusted $ getPackageDetails state pkg state = pkgState dflags-#else- part pkg = trusted $ getPackageDetails dflags pkg #endif +--------------------------------------------------------------------------------+-- :extensions++extensionsCmd :: String -> InputT GHCi ()+extensionsCmd string = do+ modules <- mapM lookupModule moduleStrings+ dynflags <-+ mapM (fmap GHC.ms_hspp_opts . GHC.getModSummary . GHC.moduleName) modules+ let someExtensions = concatMap dynFlagsEnabledExtensions dynflags+ liftIO (putStrLn (unwords (nub someExtensions)))+ where+ moduleStrings = words string++-- | Get enabled extensions from the dynamic flags.+dynFlagsEnabledExtensions :: DynFlags -> [String]+dynFlagsEnabledExtensions df =+ [ name+ | name <- supportedLanguagesAndExtensions+ , extension <- [toEnum 0 ..]+ , downcase name == downcase (showExtension extension)+ , xopt extension df+ ]+ where+ downcase = map toLower+ showExtension e =+ if isPrefixOf "Opt_" (show e)+ then drop (length "Opt_") (show e)+ else show e+ ----------------------------------------------------------------------------- -- :browse @@ -2066,8 +2181,8 @@ let things | bang = catMaybes mb_things | otherwise = filtered_things- pretty | bang = pprTyThing- | otherwise = pprTyThingInContext+ pretty | bang = pprTyThing'+ | otherwise = pprTyThingInContext' labels [] = text "-- not currently imported" labels l = text $ intercalate "\n" $ map qualifier l@@ -2718,7 +2833,7 @@ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprTT (thing, fixity, _cls_insts, _fam_insts)- = pprTyThing thing+ = pprTyThing' thing $$ show_fixity where show_fixity@@ -2727,7 +2842,7 @@ printTyThing :: TyThing -> GHCi ()-printTyThing tyth = printForUser (pprTyThing tyth)+printTyThing tyth = printForUser (pprTyThing' tyth) showBkptTable :: GHCi () showBkptTable = do@@ -3423,8 +3538,12 @@ prefixed = zipWith ($) highlighted bs_line_nos output = BS.intercalate (BS.pack "\n") prefixed +#if __GLASGOW_HASKELL__ >= 802+ let utf8Decoded = utf8DecodeByteString output+#else utf8Decoded <- liftIO $ BS.useAsCStringLen output $ \(p,n) -> utf8DecodeString (castPtr p) n+#endif liftIO $ putStrLn utf8Decoded where file = GHC.srcSpanFile pan
src/Main.hs view
@@ -47,7 +47,9 @@ #endif import DriverPhases import BasicTypes ( failed )+#if __GLASGOW_HASKELL__ < 802 import StaticFlags+#endif import DynFlags import ErrUtils import FastString@@ -60,9 +62,18 @@ -- Imports for --abi-hash import LoadIface ( loadUserInterface ) import Module ( mkModuleName )+#if __GLASGOW_HASKELL__ >= 802+import Finder ( findImportedModule, cannotFindModule )+#else import Finder ( findImportedModule, cannotFindInterface )+#endif import TcRnMonad ( initIfaceCheck )+#if __GLASGOW_HASKELL__ >= 802+import Binary ( openBinMem, put_ )+import BinFingerprint ( fingerprintBinMem )+#else import Binary ( openBinMem, put_, fingerprintBinMem )+#endif -- Standard Haskell libraries import System.IO@@ -119,12 +130,15 @@ | otherwise = Just (drop 2 (last minusB_args)) let argv1' = map (mkGeneralLocated "on the commandline") argv1- (argv2, staticFlagWarnings) <- parseStaticFlags argv1' - -- 2. Parse the "mode" flags (--make, --interactive etc.)- (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2-- let flagWarnings = staticFlagWarnings ++ modeFlagWarnings+#if __GLASGOW_HASKELL__ >= 802+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv1'+ let flagWarnings = modeFlagWarnings+#else+ (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + let flagWarnings = staticFlagWarnings ++ modeFlagWarnings +#endif -- If all we want to do is something like showing the version number -- then do it now, before we start a GHC session etc. This makes@@ -240,15 +254,21 @@ ---------------- Display configuration ----------- when (verbosity dflags6 >= 4) $-#if __GLASGOW_HASKELL__ >= 709+#if __GLASGOW_HASKELL__ >= 802 let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx+ where ctx = initSDocContext flags (defaultDumpStyle dflags6)+ in+#elif __GLASGOW_HASKELL__ >= 709+ let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx where ctx = initSDocContext flags defaultDumpStyle in #endif liftIO $ dumpPackages dflags6 - when (verbosity dflags6 >= 3) $ do- liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)+# if __GLASGOW_HASKELL__ < 802+ when (verbosity dflags6 >= 3) $ do + liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) +#endif ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs@@ -750,21 +770,27 @@ showOptions :: IO () showOptions = putStr (unlines availableOptions) where+#if __GLASGOW_HASKELL__ >= 802 availableOptions = map ((:) '-') $ getFlagNames mode_flags ++- getFlagNames flagsDynamic ++- (filterUnwantedStatic . getFlagNames $ flagsStatic) ++- flagsStaticNames- getFlagNames opts = map getFlagName opts-#if __GLASGOW_HASKELL__ < 709- getFlagName (Flag name _) = name+ getFlagNames flagsDynamic #else+ availableOptions = map ((:) '-') $+ getFlagNames mode_flags +++ getFlagNames flagsDynamic ++ + (filterUnwantedStatic . getFlagNames $ flagsStatic) ++ + flagsStaticNames + -- this is a hack to get rid of two unwanted entries that get listed + -- as static flags. Hopefully this hack will disappear one day together + -- with static flags + filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) +#endif+ getFlagNames opts = map getFlagName opts+#if __GLASGOW_HASKELL__ >= 710 getFlagName (Flag name _ _) = name+#else+ getFlagName (Flag name _) = name #endif- -- this is a hack to get rid of two unwanted entries that get listed- -- as static flags. Hopefully this hack will disappear one day together- -- with static flags- filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) showGhcUsage :: DynFlags -> IO () showGhcUsage = showUsage False@@ -846,12 +872,20 @@ case r of Found _ m -> return m _error -> throwGhcException $ CmdLineError $ showSDoc dflags $+#if __GLASGOW_HASKELL__ >= 802+ cannotFindModule dflags modname r+#else cannotFindInterface dflags modname r+#endif mods <- mapM find_it (map fst strs) let get_iface modl = loadUserInterface False (text "abiHash") modl+#if __GLASGOW_HASKELL__ >= 802+ ifaces <- initIfaceCheck (text "") hsc_env $ mapM get_iface mods+#else ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods+#endif bh <- openBinMem (3*1024) -- just less than a block put_ bh hiVersion
src/test/Main.hs view
@@ -5,6 +5,7 @@ import Control.Exception import Control.Monad.IO.Class+import Control.Monad (forM_) import Data.Char import System.IO import System.IO.Temp@@ -88,6 +89,18 @@ , "Ok, modules loaded: Main." , "Collecting type info for 1 module(s) ... "])) it+ ":l X.hs; :extensions X"+ (do result <-+ withIntero+ []+ (\dir repl -> do+ writeFile (dir ++ "/X.hs") "{-# LANGUAGE ScopedTypeVariables #-}\nmodule X where\nx = 'a'"+ _ <- repl (":l X.hs")+ repl (":extensions X"))+ shouldBe+ (filter (== "ScopedTypeVariables") (words result))+ ["ScopedTypeVariables"])+ it ":l NonExistent.hs" (do result <- withIntero [] (\_ repl -> repl (":l NonExistent.hs")) shouldBe@@ -316,6 +329,12 @@ "f (Just x) = 'a' : x" (1, 20, 1, 21, "x") (unlines ["X.hs:(1,9)-(1,10)"]))+ it+ "To other module"+ (locAtMultiple+ [("X.hs", "import Y"), ("Y.hs", "module Y where")]+ (1, 8, 1, 9, "Y")+ (unlines ["./Y.hs:(1,8)-(1,9)"])) issue "To unexported thing" "https://github.com/commercialhaskell/intero/issues/98"@@ -400,20 +419,24 @@ -- Combinators for running and interacting with intero -- | Find the definition for the thing at point.-locAt :: String -> (Int, Int, Int, Int, String) -> String -> Expectation-locAt file (line,col,line',col',name) expected = do+locAtMultiple :: [(String, String)] -> (Int, Int, Int, Int, String) -> String -> Expectation+locAtMultiple files (line,col,line',col',name) expected = do result <- withIntero [] (\dir repl -> do- writeFile (dir ++ "/X.hs") file- _ <- repl (":l X.hs")+ forM_ files $ \(fileName, fileContents) ->+ writeFile (dir ++ "/" ++ fileName) fileContents+ _ <- repl (":l " ++ fst (head files)) repl- (":loc-at X.hs " +++ (":loc-at " ++ fst (head files) ++ " " ++ unwords (map show [line, col, line', col']) ++ " " ++ name)) shouldBe result expected let x = return () x++locAt :: String -> (Int, Int, Int, Int, String) -> String -> Expectation+locAt file = locAtMultiple [("X.hs", file)] -- | Find use-sites for the given place. uses