diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.1.19: + * Support completion of qualified identifiers + 0.1.18: * Completion in the REPL gets updated properly when imports added/removed https://github.com/commercialhaskell/intero/issues/112 diff --git a/elisp/intero.el b/elisp/intero.el --- a/elisp/intero.el +++ b/elisp/intero.el @@ -54,6 +54,7 @@ (require 'company) (require 'comint) (require 'widget) +(require 'eldoc) (eval-when-compile (require 'wid-edit)) @@ -65,12 +66,12 @@ :group 'haskell) (defcustom intero-package-version - "0.1.15" + "0.1.18" "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 +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." @@ -118,14 +119,13 @@ (when (fboundp 'interactive-haskell-mode) (message "Disabling interactive-haskell-mode ...") (interactive-haskell-mode -1))) - (when (intero-buffer-file-name) - (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.")))) + (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."))) (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) @@ -298,7 +298,8 @@ (let ((file (match-string 1 result)) (line (string-to-number (match-string 2 result))) (col (string-to-number (match-string 3 result)))) - (find-file file) + (unless (string= file (intero-temp-file-name)) + (find-file file)) (pop-mark) (goto-char (point-min)) (forward-line (1- line)) @@ -392,10 +393,9 @@ cont 'interrupted) (let ((file-buffer (current-buffer))) - (intero-save-silently) (intero-async-call 'backend - (concat ":l " (intero-buffer-file-name)) + (concat ":l " (intero-temp-file-name)) (list :cont cont :file-buffer file-buffer :checker checker) @@ -420,38 +420,7 @@ nil (lambda (_st _)))))))))))) -(defun intero-original-write-region (&rest _) - "Place to store the original write-region function, to use later.") -(fset 'intero-original-write-region (symbol-function 'write-region)) -(defun intero-silent-write-region (start end filename &optional append visit lockname mustbenew) - "Same as `write-region', but with messages supressed." - (let ((result (intero-original-write-region start end filename append 'no-message lockname mustbenew))) - ;; This is what visit normally does: - (when visit - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - result)) - -(defun intero-save-silently () - "Silently save the current buffer, if it is modified: - -* Does not print messages. -* Does not trigger any hooks." - (interactive) - (let (;; Canonical list of hooks taken from: - ;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Saving-Buffers.html - auto-save-hook - require-final-newline - before-save-hook - after-save-hook - write-contents-functions - write-file-functions) - (when (buffer-modified-p) - ;; Supress message output. - (cl-letf (((symbol-function 'write-region) #'intero-silent-write-region)) - (basic-save-buffer))))) - (flycheck-define-generic-checker 'intero "A syntax and type checker for Haskell using an Intero worker process." @@ -466,7 +435,8 @@ (with-temp-buffer (insert string) (goto-char (point-min)) - (let ((messages (list))) + (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[^ ]") @@ -490,10 +460,9 @@ line column type msg :checker checker - :buffer (when (string= (intero-buffer-file-name buffer) - file) + :buffer (when (string= temp-file file) buffer) - :filename file) + :filename (intero-buffer-file-name buffer)) messages))) (forward-line -1)) (delete-dups messages)))) @@ -578,9 +547,11 @@ (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)) + (intero-get-repl-completions source-buffer (concat "import " prefix) cont) + t) (haskell-completions-identifier-prefix - (intero-get-completions source-buffer beg end cont)) + (intero-get-completions source-buffer beg end cont) + t) (haskell-completions-language-extension-prefix (intero-get-repl-completions source-buffer @@ -590,13 +561,15 @@ (mapcar (lambda (x) (replace-regexp-in-string "^-X" "" x)) results))) - cont))) + cont)) + t) (haskell-completions-pragma-name-prefix (funcall cont (cl-remove-if-not (lambda (candidate) (string-match (concat "^" prefix) candidate)) - intero-pragmas))))) + intero-pragmas)) + t))) (intero-get-repl-completions source-buffer prefix cont)))) (defun intero-completions-grab-prefix (&optional minlen) @@ -729,13 +702,75 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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* ((ty (apply #'intero-get-type-at (intero-thing-at-point))) - (is-error (string-match "^<.+>:.+:" ty))) - (unless is-error - (intero-fontify-expression (replace-regexp-in-string "[ \n]+" " " ty))))) + (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 +* \":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 "^:" first-line) + 'interactive-error) + (t 'no-error)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; REPL @@ -745,7 +780,8 @@ "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-clear-buffer () +(defun intero-repl-clear-buffer () + "Clear the current REPL buffer." (interactive) (let ((comint-buffer-maximum-size 0)) (comint-truncate-buffer))) @@ -755,7 +791,7 @@ If PROMPT-OPTIONS is non-nil, prompt with an options list." (interactive "P") (save-buffer) - (let ((file (intero-buffer-file-name)) + (let ((file (intero-temp-file-name)) (repl-buffer (intero-repl-buffer prompt-options t))) (with-current-buffer repl-buffer (comint-simple-send @@ -805,8 +841,7 @@ "Keymap for clicking on links in REPL.") (defun intero-find-file-with-line:char () - "Opens the file from 'file text property and moves to line:char -from 'line text property." + "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)) @@ -817,7 +852,7 @@ (forward-char (1- char)))) (defun intero-linkify-file-line-char (begin end) - "Linkify all occurances of ::: betwen begin and end" + "Linkify all occurences of ::: betwen BEGIN and END." (when (> end begin) (let ((end-marker (copy-marker end)) ;; match - /path/to/file.ext::: @@ -843,12 +878,11 @@ (defvar intero-last-output-newline-marker nil) -(defun intero-linkify-process-output (ignored) - "comint-output-filter-function to turn ::: into -links that can be clicked on. +(defun intero-linkify-process-output (_) + "Comint filter function to make ::: 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' +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)) @@ -933,26 +967,17 @@ (setq intero-repl-no-load (not (member "load-all" new-options))) (setq intero-repl-no-build (not (member "build-first" new-options)))))) -;; For live migration, remove later -(font-lock-remove-keywords - 'intero-repl-mode - '(("\\(\4\\)" - (0 (prog1 () - (compose-region (match-beginning 1) - (match-end 1) - ?λ)))))) - (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-clear-buffer) +(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 () @@ -1041,6 +1066,20 @@ (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-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")))) + (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 @@ -1070,18 +1109,40 @@ "\n$" "" (intero-blocking-call 'backend - (format ":type-at %S %d %d %d %d %S" - (intero-buffer-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))))) + (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 @@ -1101,7 +1162,7 @@ (unless (member 'save flycheck-check-syntax-automatically) (intero-async-call 'backend - (concat ":l " (intero-buffer-file-name)))) + (concat ":l " (intero-temp-file-name)))) (intero-async-call 'backend ":set -fobject-code") @@ -1119,7 +1180,7 @@ (intero-blocking-call 'backend (format ":loc-at %S %d %d %d %d %S" - (intero-buffer-file-name) + (intero-temp-file-name) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1137,7 +1198,7 @@ (intero-blocking-call 'backend (format ":uses %S %d %d %d %d %S" - (intero-buffer-file-name) + (intero-temp-file-name) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1155,7 +1216,7 @@ (intero-async-call 'backend (format ":complete-at %S %d %d %d %d %S" - (intero-buffer-file-name) + (intero-temp-file-name) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1171,10 +1232,12 @@ (plist-get state :source-buffer) (funcall (plist-get state :cont) - (mapcar - (lambda (x) - (replace-regexp-in-string "\\\"" "" x)) - (split-string reply "\n" t))))))) + (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. @@ -1514,7 +1577,7 @@ (funcall func state string)) (setq repeat t)) (when intero-debug - (warn "Received output but no callback in `intero-callbacks': %S" + (intero--warn "Received output but no callback in `intero-callbacks': %S" string))))) (delete-region (point-min) (point)))))) @@ -1578,7 +1641,7 @@ "--project-root" "--verbosity" "silent")) (0 (buffer-substring (line-beginning-position) (line-end-position))) - (t (warn "Couldn't get the Stack project root. + (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. @@ -1970,7 +2033,7 @@ (concat text "\n\n" (propertize "(Hit `C-c C-r' in the Haskell buffer to apply suggestions)" - 'face 'font-lock-warning))))))) + 'face 'font-lock-warning-face))))))) (setq intero-lighter (if (null intero-suggestions) " Intero" @@ -1989,7 +2052,7 @@ ;; Auto actions (defun intero-parse-comma-list (text) - "Parse a list of comma-separated expressions." + "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)) @@ -2147,6 +2210,11 @@ (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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.18 + 0.1.19 synopsis: Complete interactive development program for Haskell license: diff --git a/src/GhciFind.hs b/src/GhciFind.hs --- a/src/GhciFind.hs +++ b/src/GhciFind.hs @@ -13,6 +13,9 @@ import Module #endif import Control.Exception +#if __GLASGOW_HASKELL__ < 710 +import Data.Foldable (foldMap) +#endif import Data.List import Data.Map (Map) import qualified Data.Map as M @@ -28,6 +31,27 @@ import System.Directory import Var +-- | Check if there is are imported modules that should be searched +-- for the completion sample string. If so, returns the name qualifier +-- (i.e. module name or alias), the identifier prefix to search for, +-- and the `ModuleName`s of the modules in which to search. +findQualifiedSource :: [ImportDecl n] -> String + -> Maybe (String, String, [ModuleName]) +findQualifiedSource importDecls sample = + do (ident,qual) <- breakQual sample + mnames <- (\nms -> if null nms then Nothing else Just nms) + (foldMap (maybeToList . knownAs qual) importDecls) + return (qual++".", ident, mnames) + where breakQual xs = case break (== '.') (reverse xs) of + (h,_:t) -> Just (reverse h, reverse t) + _ -> Nothing + knownAs qual m + | qual == moduleNameString name || maybe False (qual ==) (asName m) = + Just name + | otherwise = Nothing + where name = unLoc (ideclName m) + asName = fmap moduleNameString . ideclAs + -- | Find completions for the sample, context given by the location. findCompletions :: (GhcMonad m) => Map ModuleName ModInfo @@ -49,12 +73,29 @@ return (Left ("No module info for the current file! Try loading it?")) Just moduleInf -> do df <- getDynFlags - let toplevelNames = - fromMaybe [] (modInfoTopLevelScope (modinfoInfo moduleInf)) + (qual, ident, minfs) <- + let noQual = ("", sample, [modinfoInfo moduleInf]) + getModInfo qmname = + findModule qmname Nothing >>= getModuleInfo + in if '.' `elem` sample + then case findQualifiedSource + (map unLoc (modinfoImports moduleInf)) + sample of + Just (qual, ident, qualModNames) -> do + minfos <- fmap catMaybes + (mapM getModInfo qualModNames) + if null minfos + then return noQual + else return (qual, ident, minfos) + Nothing -> return noQual + else return noQual + let toplevelNames = concat (mapMaybe modInfoTopLevelScope minfs) filteredToplevels = - filter (isPrefixOf sample) - (map (showppr df) toplevelNames) - localNames <- findLocalizedCompletions (modinfoSpans moduleInf) sample sl sc el ec + map (qual ++) + (filter (isPrefixOf ident) + (map (showppr df) toplevelNames)) + localNames <- findLocalizedCompletions (modinfoSpans moduleInf) + sample sl sc el ec return (Right (take 30 (nub (localNames ++ filteredToplevels)))) -- | Find completions within the local scope of a definition of a diff --git a/src/GhciInfo.hs b/src/GhciInfo.hs --- a/src/GhciInfo.hs +++ b/src/GhciInfo.hs @@ -76,10 +76,11 @@ do m <- getModSummary name p <- parseModule m 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) + return (ModInfo m allTypes i now imports) -- | Get ALL source spans in the module. processAllTypeCheckedModule :: GhcMonad m diff --git a/src/GhciTypes.hs b/src/GhciTypes.hs --- a/src/GhciTypes.hs +++ b/src/GhciTypes.hs @@ -20,6 +20,9 @@ -- ^ Again, useful from GHC for accessing information -- (exports, instances, scope) from a module. ,modinfoLastUpdate :: !UTCTime + -- ^ Last time the module was updated. + ,modinfoImports :: ![LImportDecl Name] + -- ^ Import declarations within this module. } -- | Type of some span of source code. Most of these fields are diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -343,8 +343,8 @@ repl req else return ("First step failed: " ++ reply)) shouldBe - reply - (unlines ["3 3 \"\"", "\"sort\"", "\"sortBy\"", "\"sortOn\""]))) + (filter (/= "\"sortOn\"") (drop 1 (lines reply))) + (["\"sort\"", "\"sortBy\""]))) describe "Completion in module context" (do it