diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.1.20: + * More robust name finding, fixes bug https://github.com/commercialhaskell/intero/issues/98 + 0.1.19: * Support completion of qualified identifiers diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,6 +20,32 @@ `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. + +Find this line in your Emacs configuration and remove it: + +``` lisp +(add-hook 'haskell-mode-hook 'intero-mode) +``` + +To whitelist specific directories (and ignore everything else), use: + +``` lisp +(setq intero-whitelist '("/work/directories/" "/my/directories/")) +(add-hook 'haskell-mode-hook 'intero-mode-whitelist) +``` + +To blacklist specific directories (and allow everything else), use: + +``` lisp +(setq intero-blacklist '("/path/to/bad/project" "/path/to/ignore/me")) +(add-hook 'haskell-mode-hook 'intero-mode-blacklist) +``` + ## Intero for IDE writers Please see diff --git a/elisp/intero.el b/elisp/intero.el --- a/elisp/intero.el +++ b/elisp/intero.el @@ -1,7 +1,9 @@ ;;; 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 @@ -66,7 +68,7 @@ :group 'haskell) (defcustom intero-package-version - "0.1.18" + "0.1.20" "Package version to auto-install. This version does not necessarily have to be the latest version @@ -99,6 +101,28 @@ :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 @@ -127,6 +151,24 @@ (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) @@ -203,9 +245,19 @@ (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) @@ -240,7 +292,9 @@ "Return a haskell-fontified version of EXPRESSION." (with-temp-buffer (when (fboundp 'haskell-mode) - (haskell-mode)) + (let ((flycheck-checkers nil) + (haskell-mode-hook nil)) + (haskell-mode))) (insert expression) (if (fboundp 'font-lock-ensure) (font-lock-ensure) @@ -286,7 +340,8 @@ (goto-char (point-min)))))))) (defun intero-goto-definition () - "Jump to the definition of the thing at point." + "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]+\\))$" @@ -303,7 +358,8 @@ (pop-mark) (goto-char (point-min)) (forward-line (1- line)) - (forward-char (1- col)))))) + (forward-char (1- col)) + t)))) (defun intero-restart () "Simply restart the process with the same configuration as before." @@ -312,7 +368,8 @@ (let ((targets (with-current-buffer (intero-buffer 'backend) intero-targets))) (intero-destroy 'backend) - (intero-get-worker-create 'backend targets (current-buffer))))) + (intero-get-worker-create 'backend targets (current-buffer)) + (intero-repl-restart)))) (defun intero-targets () "Set the targets to use for stack ghci." @@ -333,7 +390,8 @@ " " t)))) (intero-destroy) - (intero-get-worker-create 'backend targets (current-buffer)))) + (intero-get-worker-create 'backend targets (current-buffer)) + (intero-repl-restart))) (defun intero-destroy (&optional worker) "Stop WORKER and kill its associated process buffer. @@ -722,20 +780,22 @@ (defun eldoc-intero () "ELDoc backend for intero." - (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)) + (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)) @@ -769,6 +829,8 @@ 'option-missing) ((string-match-p "^:" first-line) 'interactive-error) + ((string-match-p "^:" first-line) + 'inspection-error) (t 'no-error)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -796,7 +858,10 @@ (with-current-buffer repl-buffer (comint-simple-send (get-buffer-process (current-buffer)) - (concat ":l " file))) + (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) @@ -805,6 +870,24 @@ (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 @@ -933,21 +1016,28 @@ (insert (propertize (format "Starting:\n stack ghci %s\n" (combine-and-quote-strings arguments)) 'face 'font-lock-comment-face)) - (let ((script (with-current-buffer (find-file-noselect (make-temp-file "intero-script")) - (insert ":set prompt \"\" -:set -fobject-code + (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) - (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))))))) + (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.")))))) + (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. @@ -1021,44 +1111,134 @@ (buffer-substring-no-properties (car reg) (cdr reg))))) (defun intero-ident-pos-at-point () - "Return the span of the identifier under point, or nil if none found. -May return a qualified name." - (save-excursion - ;; Skip whitespace if we're on it. That way, if we're at "map ", we'll - ;; see the word "map". - (if (and (not (eobp)) - (eq ? (char-syntax (char-after)))) - (skip-chars-backward " \t")) - - (let ((case-fold-search nil)) - (cl-multiple-value-bind (start end) - (list - (progn (skip-syntax-backward "w_") (point)) - (progn (skip-syntax-forward "w_") (point))) - ;; If we're looking at a module ID that qualifies further IDs, add - ;; those IDs. - (goto-char start) - (while (and (looking-at "[[:upper:]]") (eq (char-after end) ?.) - ;; It's a module ID that qualifies further IDs. - (goto-char (1+ end)) - (save-excursion - (when (not (zerop (skip-syntax-forward - (if (looking-at "\\s_") "_" "w'")))) - (setq end (point)))))) - ;; If we're looking at an ID that's itself qualified by previous - ;; module IDs, add those too. - (goto-char start) - (if (eq (char-after) ?.) (forward-char 1)) ;Special case for "." - (while (and (eq (char-before) ?.) - (progn (forward-char -1) - (not (zerop (skip-syntax-backward "w'")))) - (skip-syntax-forward "'") - (looking-at "[[:upper:]]")) - (setq start (point))) - ;; This is it. - (unless (= start end) + "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." @@ -1069,13 +1249,30 @@ (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 (make-temp-file "intero" nil ".hs")))) + (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)))))) @@ -1466,7 +1663,7 @@ (list "--no-build")) (when no-load (list "--no-load")) - (let ((dir (make-temp-file "intero" t))) + (let ((dir (intero-make-temp-file "intero" t))) (list "--ghci-options" (concat "-odir=" dir) "--ghci-options" @@ -1534,6 +1731,9 @@ 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: " @@ -1578,7 +1778,7 @@ (setq repeat t)) (when intero-debug (intero--warn "Received output but no callback in `intero-callbacks': %S" - string))))) + string))))) (delete-region (point-min) (point)))))) (defun strip-carriage-returns (string) @@ -1645,7 +1845,14 @@ This can be caused by a syntax error in your stack.yaml file. Check that out. -Otherwise, please report this as a bug!") +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 () @@ -1665,7 +1872,10 @@ (with-temp-buffer (cl-case (call-process "stack" nil (current-buffer) t "ide" "targets") (0 - (split-string (buffer-string) nil t)) + (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) @@ -1916,6 +2126,18 @@ (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 @@ -2092,6 +2314,10 @@ (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 " @@ -2131,6 +2357,12 @@ (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 diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.19 + 0.1.20 synopsis: Complete interactive development program for Haskell license: @@ -69,7 +69,8 @@ bytestring, directory, filepath, - ghc >= 7.8 && <= 8.0.1, + -- We permit any 8.0.1.* + ghc >= 7.8 && < 8.0.2, ghc-paths, haskeline, process, diff --git a/src/GhciFind.hs b/src/GhciFind.hs --- a/src/GhciFind.hs +++ b/src/GhciFind.hs @@ -289,16 +289,22 @@ #endif showppr d modL))) Just info -> - case find (matchName name) + case find (reliableNameEquality name) (modInfoExports (modinfoInfo info)) of Just name' -> return (Right name') Nothing -> - return (Left "No matching export in any local modules.") - where matchName :: Name -> Name -> Bool - matchName x y = - occNameString (getOccName x) == - occNameString (getOccName y) + case find (reliableNameEquality name) + (fromMaybe [] (modInfoTopLevelScope (modinfoInfo info))) of + Just name' -> + return (Right name') + Nothing -> do + result <- lookupGlobalName name + case result of + Nothing -> + return (Left ("No matching export in any local modules: " ++ showppr d name)) + Just tyThing -> + return (Right (getName tyThing)) -- | Try to resolve the type display from the given span. resolveName :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Var diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -296,26 +296,38 @@ describe "Definition location" (do it - ":loc-at X.hs 1 1 1 1 x -- from definition site" + "From definition site" (locAt "x = 'a' : x" (1, 1, 1, 1, "x") (unlines ["X.hs:(1,1)-(1,2)"])) it - ":loc-at X.hs 1 11 1 12 x -- from use site" + "From use site" (locAt "x = 'a' : x" (1, 11, 1, 12, "x") (unlines ["X.hs:(1,1)-(1,12)"])) it - ":loc-at X.hs 1 11 1 12 x -- to function argument" + "To function argument" (locAt "f x = 'a' : x" (1, 13, 1, 14, "x") (unlines ["X.hs:(1,3)-(1,4)"])) it - ":loc-at X.hs 1 11 1 12 x -- to pattern match" + "To pattern match" (locAt "f (Just x) = 'a' : x" (1, 20, 1, 21, "x") - (unlines ["X.hs:(1,9)-(1,10)"]))) + (unlines ["X.hs:(1,9)-(1,10)"])) + issue + "To unexported thing" + "https://github.com/commercialhaskell/intero/issues/98" + (locAt + (unlines + [ "module X () where" + , "data MyType = MyCons" + , "t :: MyType" + , "t = MyCons :: MyType" + ]) + (3, 6, 3, 12, "MyType") + (unlines ["X.hs:(2,1)-(2,21)"]))) -- | Test interactive completions. completion :: Spec