diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.1.31: + * Collecting type info no longer prints messages + 0.1.29: * Support GHC 8.4 diff --git a/elisp/intero.el b/elisp/intero.el --- a/elisp/intero.el +++ b/elisp/intero.el @@ -74,7 +74,7 @@ ;; Until is fixed: (windows-nt "0.1.28") (cygwin "0.1.28") - (t "0.1.29")) + (t "0.1.30")) "Package version to auto-install. This version does not necessarily have to be the latest version @@ -286,6 +286,12 @@ (defvar-local intero-targets (list) "Targets used for the stack process.") +(defvar-local intero-repl-last-loaded nil + "Last loaded module in the REPL.") + +(defvar-local intero-repl-send-after-load nil + "Send a command after every load.") + (defvar-local intero-start-time nil "Start time of the stack process.") @@ -330,10 +336,6 @@ (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.") @@ -550,7 +552,7 @@ (intero-with-dump-splices (let* ((output (intero-blocking-call 'backend - (concat ":load " (intero-localize-path (intero-temp-file-name))))) + (concat ":load " (intero-path-for-ghci (intero-temp-file-name))))) (msgs (intero-parse-errors-warnings-splices nil (current-buffer) output)) (line (line-number-at-pos)) (column (if (save-excursion @@ -703,22 +705,13 @@ cont 'interrupted) (let* ((file-buffer (current-buffer)) - (staging-file (intero-localize-path (intero-staging-file-name))) - (temp-file (intero-localize-path (intero-temp-file-name)))) + (staging-file (intero-path-for-ghci (intero-staging-file-name))) + (temp-file (intero-path-for-ghci (intero-temp-file-name)))) ;; We queue up to :move the staging file to the target temp ;; file, which also updates its modified time. (intero-async-call 'backend - (format ":move \"%s\" \"%s\"" - ;; TODO: This is a temporary fix. I don't want to use - ;; %S as that may escape things that Haskell doesn't - ;; consider escapable; Intero's function reads with - ;; 'read' (not my implementation!). Instead, I should - ;; implement an alternative reading function for Intero - ;; which would consume only "strings" and treat any - ;; non-double-quote characters as-is. - (replace-regexp-in-string "\\\\" "\\\\\\\\" staging-file) - (replace-regexp-in-string "\\\\" "\\\\\\\\" temp-file))) + (format ":move %s %s" staging-file temp-file)) ;; We load up the target temp file, which has only been updated ;; by the copy above. (intero-async-call @@ -1113,8 +1106,8 @@ (intero-async-call 'backend (format - ":fill %S %d %d" - (intero-localize-path (intero-temp-file-name)) + ":fill %s %d %d" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1249,17 +1242,44 @@ (when intero-pop-to-repl (pop-to-buffer ,repl-buffer))))) +(defun intero-repl-after-load () + "Set the command to run after load." + (interactive) + (if (eq major-mode 'intero-repl-mode) + (setq intero-repl-send-after-load + (read-from-minibuffer + "Command to run: " + (or intero-repl-send-after-load + (car (ring-elements comint-input-ring)) + ""))) + (error "Run this in the REPL."))) + (defun intero-repl-load (&optional prompt-options) "Load the current file in the REPL. If PROMPT-OPTIONS is non-nil, prompt with an options list." (interactive "P") (save-buffer) - (let ((file (intero-localize-path (intero-buffer-file-name)))) + (let ((file (intero-path-for-ghci (intero-buffer-file-name)))) (intero-with-repl-buffer prompt-options (comint-simple-send - (get-buffer-process (current-buffer)) - (concat ":load " file)) - (setq intero-repl-last-loaded file)))) + (get-buffer-process (current-buffer)) + ":set prompt \"\\n\"") + (if (or (not intero-repl-last-loaded) + (not (equal file intero-repl-last-loaded))) + (progn + (comint-simple-send + (get-buffer-process (current-buffer)) + (concat ":load " file)) + (setq intero-repl-last-loaded file)) + (comint-simple-send + (get-buffer-process (current-buffer)) + ":reload")) + (when intero-repl-send-after-load + (comint-simple-send + (get-buffer-process (current-buffer)) + intero-repl-send-after-load)) + (comint-simple-send (get-buffer-process (current-buffer)) + ":set prompt \"\\4 \"")))) (defun intero-repl-eval-region (begin end &optional prompt-options) "Evaluate the code in region from BEGIN to END in the REPL. @@ -1360,8 +1380,8 @@ 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) + (setq intero-repl-last-loaded nil) (when stack-yaml (setq intero-stack-yaml stack-yaml)) (when prompt-options @@ -1727,6 +1747,14 @@ (insert contents)) fname))) +(defun intero-quote-path-for-ghci (path) + "Quote PATH as necessary so that it can be passed to a GHCi :command." + (concat "\"" (replace-regexp-in-string "\\([\\\"]\\)" "\\\\\\1" path nil nil) "\"")) + +(defun intero-path-for-ghci (path) + "Turn a possibly-remote PATH into one that can be passed to a GHCi :command." + (intero-quote-path-for-ghci (intero-localize-path path))) + (defun intero-localize-path (path) "Turn a possibly-remote PATH to a purely local one. This is used to create paths which a remote intero process can load." @@ -1801,8 +1829,8 @@ (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)) + (format ":type-at %s %d %d %d %d %S" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1832,7 +1860,7 @@ (unless (member 'save flycheck-check-syntax-automatically) (intero-async-call 'backend - (concat ":load " (intero-localize-path (intero-temp-file-name))))) + (concat ":load " (intero-path-for-ghci (intero-temp-file-name))))) (intero-async-call 'backend ":set -fobject-code") @@ -1861,8 +1889,8 @@ "\n$" "" (intero-blocking-network-call 'backend - (format ":loc-at %S %d %d %d %d %S" - (intero-localize-path (intero-temp-file-name)) + (format ":loc-at %s %d %d %d %d %S" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1879,8 +1907,8 @@ "\n$" "" (intero-blocking-call 'backend - (format ":loc-at %S %d %d %d %d %S" - (intero-localize-path (intero-temp-file-name)) + (format ":loc-at %s %d %d %d %d %S" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1907,8 +1935,8 @@ "\n$" "" (intero-blocking-network-call 'backend - (format ":uses %S %d %d %d %d %S" - (intero-localize-path (intero-temp-file-name)) + (format ":uses %s %d %d %d %d %S" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1925,8 +1953,8 @@ "\n$" "" (intero-blocking-call 'backend - (format ":uses %S %d %d %d %d %S" - (intero-localize-path (intero-temp-file-name)) + (format ":uses %s %d %d %d %d %S" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -1943,8 +1971,8 @@ passed to CONT in SOURCE-BUFFER." (intero-async-network-call 'backend - (format ":complete-at %S %d %d %d %d %S" - (intero-localize-path (intero-temp-file-name)) + (format ":complete-at %s %d %d %d %d %S" + (intero-path-for-ghci (intero-temp-file-name)) (save-excursion (goto-char beg) (line-number-at-pos)) (save-excursion (goto-char beg) @@ -2077,34 +2105,41 @@ (error "Intero process is not running: run M-x intero-restart to start it")))) (defun intero-network-call-sentinel (process event) - (with-current-buffer (process-buffer process) - (if (string= "open\n" event) - (progn - (when intero-debug (message "Connected to service, sending %S" intero-async-network-cmd)) - (setq intero-async-network-connected t) - (if intero-async-network-cmd - (process-send-string process (concat intero-async-network-cmd "\n")) - (delete-process process))) - (progn - (if intero-async-network-connected - (when intero-async-network-callback - (when intero-debug (message "Calling callback with %S" (buffer-string))) - (funcall intero-async-network-callback - intero-async-network-state - (buffer-string))) - ;; We didn't successfully connect, so let's fallback to the - ;; process pipe. - (when intero-async-network-callback - (when intero-debug (message "Failed to connect, falling back ... ")) - (setq intero-async-network-callback nil) - (intero-async-call - intero-async-network-worker - intero-async-network-cmd - intero-async-network-state - intero-async-network-callback))) - ;; In any case we clean up the connection. - (delete-process process))))) + (pcase event + ;; This event sometimes gets sent when (delete-process) is called, but + ;; inconsistently. We can't rely on it for killing buffers, but we need to + ;; handle the possibility. + ("deleted\n") + ("open\n" + (with-current-buffer (process-buffer process) + (when intero-debug (message "Connected to service, sending %S" intero-async-network-cmd)) + (setq intero-async-network-connected t) + (if intero-async-network-cmd + (process-send-string process (concat intero-async-network-cmd "\n")) + (delete-process process) + (kill-buffer (process-buffer process))))) + (_ + (with-current-buffer (process-buffer process) + (if intero-async-network-connected + (when intero-async-network-callback + (when intero-debug (message "Calling callback with %S" (buffer-string))) + (funcall intero-async-network-callback + intero-async-network-state + (buffer-string))) + ;; We didn't successfully connect, so let's fallback to the + ;; process pipe. + (when intero-async-network-callback + (when intero-debug (message "Failed to connect, falling back ... ")) + (setq intero-async-network-callback nil) + (intero-async-call + intero-async-network-worker + intero-async-network-cmd + intero-async-network-state + intero-async-network-callback)))) + (delete-process process) + (kill-buffer (process-buffer process))))) + (defun intero-async-call (worker cmd &optional state callback) "Send WORKER the command string CMD. The result, along with the given STATE, is passed to CALLBACK @@ -3220,6 +3255,8 @@ (forward-line (1- (plist-get suggestion :line))) (move-to-column (- (plist-get suggestion :column) 1)) (search-forward "{") + (unless (looking-at "}") + (save-excursion (insert ", "))) (insert (mapconcat (lambda (field) (concat field " = _")) (plist-get suggestion :fields) ", ")))))) diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.30 + 0.1.31 synopsis: Complete interactive development program for Haskell license: diff --git a/src/GhciInfo.hs b/src/GhciInfo.hs --- a/src/GhciInfo.hs +++ b/src/GhciInfo.hs @@ -19,9 +19,11 @@ import Data.Time import DataCon import Desugar +import DynFlags import GHC import GhcMonad import GhciTypes +import HscTypes import Intero.Compat import Outputable import Prelude hiding (mod) @@ -82,12 +84,42 @@ do m <- getModSummary name p <- parseModule m let location = getModuleLocation (parsedSource p) - typechecked <- typecheckModule p + typechecked <- typecheckModuleSilent 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 location) + +-- | Type-check the module without logging messages. +typecheckModuleSilent :: GhcMonad m => ParsedModule -> m TypecheckedModule +#if MIN_VERSION_ghc(8,0,1) +typecheckModuleSilent parsed = do + typecheckModule + parsed + { GHC.pm_mod_summary = + (GHC.pm_mod_summary parsed) + { HscTypes.ms_hspp_opts = + (HscTypes.ms_hspp_opts (GHC.pm_mod_summary parsed)) + {log_action = nullLogAction} + } + } + where + nullLogAction _df _reason _sev _span _style _msgdoc = pure () +#else +typecheckModuleSilent parsed = do + typecheckModule + parsed + { GHC.pm_mod_summary = + (GHC.pm_mod_summary parsed) + { HscTypes.ms_hspp_opts = + (HscTypes.ms_hspp_opts (GHC.pm_mod_summary parsed)) + {log_action = nullLogAction} + } + } + where + nullLogAction _df _reason _sev _span _style = pure () +#endif getModuleLocation :: ParsedSource -> SrcSpan getModuleLocation pSource = case hsmodName (unLoc pSource) of