diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.1.29: + * Support GHC 8.4 + 0.1.27: * Add experimental :fill command. diff --git a/elisp/intero.el b/elisp/intero.el --- a/elisp/intero.el +++ b/elisp/intero.el @@ -70,7 +70,7 @@ :group 'haskell) (defcustom intero-package-version - "0.1.27" + "0.1.28" "Package version to auto-install. This version does not necessarily have to be the latest version @@ -177,6 +177,7 @@ (add-hook 'completion-at-point-functions 'intero-completion-at-point nil t) (add-to-list (make-local-variable 'company-backends) 'intero-company) (company-mode) + (setq-local company-minimum-prefix-length 1) (unless eldoc-documentation-function (setq-local eldoc-documentation-function #'ignore)) (add-function :before-until (local 'eldoc-documentation-function) #'intero-eldoc) @@ -803,9 +804,10 @@ line column type msg :checker checker - :buffer (when (intero-paths-for-same-file temp-file file) - buffer) - :filename (intero-buffer-file-name buffer)) + :buffer buffer + :filename (if (intero-paths-for-same-file temp-file file) + (intero-buffer-file-name buffer) + file)) messages))) (forward-line -1)) (delete-dups @@ -870,6 +872,30 @@ (when completions (list beg end completions))))))) +(defun intero-repl-completion-at-point () + "A (blocking) function suitable for use in `completion-at-point-functions'. +Should only be used in the repl" + (let* ((beg (save-excursion (intero-repl-beginning-of-line) (point))) + (end (point)) + (str (buffer-substring-no-properties beg end)) + (repl-buffer (current-buffer)) + (proc (get-buffer-process (current-buffer)))) + (with-temp-buffer + (comint-redirect-send-command-to-process + (format ":complete repl %S" str) ;; command + (current-buffer) ;; output buffer + proc ;; target process + nil ;; echo + t) ;; no-display + (while (not (with-current-buffer repl-buffer + comint-redirect-completed)) + (sleep-for 0.01)) + (let* ((completions (intero-completion-response-to-list (buffer-string))) + (first-line (car completions))) + (when (string-match "[^ ]* [^ ]* " first-line) ;; "2 2 :load src/" + (setq first-line (replace-match "" nil nil first-line)) + (list (+ beg (length first-line)) end (cdr completions))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Company integration (auto-completion) @@ -890,8 +916,9 @@ (unless (intero-gave-up 'backend) (or (let ((hole (intero-grab-hole))) (when hole - (goto-char (cdr hole)) - (buffer-substring (car hole) (cdr hole)))) + (save-excursion + (goto-char (cdr hole)) + (buffer-substring (car hole) (cdr hole))))) (let ((prefix-info (intero-completions-grab-prefix))) (when prefix-info (cl-destructuring-bind @@ -952,7 +979,6 @@ considered." (when (intero-completions-can-grab-prefix) (let ((prefix (cond - ((intero-completions-grab-ghci-command)) ((intero-completions-grab-pragma-prefix)) ((intero-completions-grab-identifier-prefix))))) (cond ((and minlen prefix) @@ -969,24 +995,6 @@ (backward-char) (not (looking-at-p (rx (| space line-end))))))))) -(defun intero-completions-grab-ghci-command () - "Grab prefix for a ghci command like :set. -Returns (prefix-start-position prefix-end-position prefix-value prefix-type)" - (when (derived-mode-p 'intero-repl-mode) - (save-excursion - (let ((end (point))) - (when (save-excursion - (beginning-of-line) - (looking-at-p (rx (* " ") - ":set" - (* " ")))) - (skip-syntax-backward "^ >") - (let ((start (point))) - (list start - end - (concat ":set " (buffer-substring-no-properties start end)) - 'haskell-completions-repl-command))))))) - (defun intero-completions-grab-identifier-prefix () "Grab identifier prefix." (let ((pos-at-point (intero-ident-pos-at-point)) @@ -1109,15 +1117,20 @@ (1+ (current-column)))) (list :buffer (current-buffer) :cont cont) (lambda (state reply) - (unless (or (string-match "^Couldn't guess" reply) - (string-match "^Unable to " reply)) + (if (or (string-match "^Couldn't guess" reply) + (string-match "^Unable to " reply) + (intero-parse-error reply)) + (funcall (plist-get state :cont) (list)) (with-current-buffer (plist-get state :buffer) - (let ((candidates (split-string - (replace-regexp-in-string - "\n$" "" - reply) - "[\r\n]"))) - (funcall (plist-get state :cont) candidates)))))))) + (let ((candidates + (split-string + (replace-regexp-in-string + "\n$" "" + reply) + "[\r\n]" + t))) + (when candidates + (funcall (plist-get state :cont) candidates))))))))) (defun intero-grab-hole () "When user is at a hole _ or _foo, return the starting point of @@ -1125,7 +1138,7 @@ (let ((beg-end (intero-ident-pos-at-point))) (when beg-end (let ((string (buffer-substring-no-properties (car beg-end) (cdr beg-end)))) - (when (string-match "^_" string) + (when (string-match-p "^_" string) beg-end))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1333,8 +1346,7 @@ (setq-local comint-prompt-regexp intero-prompt-regexp) (setq-local warning-suppress-types (cons '(undo discard-info) warning-suppress-types)) (setq-local comint-prompt-read-only t) - (add-hook 'completion-at-point-functions 'intero-completion-at-point nil t) - (add-to-list (make-local-variable 'company-backends) 'intero-company) + (add-hook 'completion-at-point-functions 'intero-repl-completion-at-point nil t) (company-mode)) (defun intero-repl-mode-start (backend-buffer targets prompt-options stack-yaml) @@ -1690,8 +1702,8 @@ (intero-make-temp-file "intero" nil (concat "-TEMP." (if (buffer-file-name) - (file-name-extension (buffer-file-name)) - "hs"))))) + (file-name-extension (buffer-file-name)) + "hs"))))) (puthash intero-temp-file-name (current-buffer) intero-temp-file-buffer-mapping) @@ -1705,8 +1717,8 @@ (intero-make-temp-file "intero" nil (concat "-STAGING." (if (buffer-file-name) - (file-name-extension (buffer-file-name)) - "hs")))))) + (file-name-extension (buffer-file-name)) + "hs")))))) (with-temp-file fname (insert contents)) fname))) @@ -2061,39 +2073,33 @@ (error "Intero process is not running: run M-x intero-restart to start it")))) (defun intero-network-call-sentinel (process event) - (let ((buf (process-buffer process))) - (cl-flet ((cleanup () - (delete-process process) - (kill-buffer buf))) - (if (string= "open\n" event) - (let ((cmd - (with-current-buffer buf - (when intero-debug (message "Connected to service, sending %S" intero-async-network-cmd)) - (setq intero-async-network-connected t) - (and intero-async-network-cmd - (concat intero-async-network-cmd "\n"))))) - (if cmd - (process-send-string process cmd) - (cleanup))) - (with-current-buffer buf - (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. + (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 "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)))) + (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. - (cleanup))))) + (delete-process process))))) (defun intero-async-call (worker cmd &optional state callback) "Send WORKER the command string CMD. @@ -2783,12 +2789,49 @@ (note nil)) ;; Messages of this format: ;; + ;; • Constructor ‘Assert’ does not have the required strict field(s): assertName, + ;; assertDoc, assertExpression, + ;; assertSection + (let ((start 0)) + (while (or + (string-match "does not have the required strict field.*?:[\n\t\r ]" text start) + (string-match "Fields of .*? not initialised:[\n\t\r ]" text start)) + (let* ((match-end (match-end 0)) + (fields + (let ((reached-end nil)) + (mapcar + (lambda (field) + (with-temp-buffer + (insert field) + (goto-char (point-min)) + (intero-ident-at-point))) + (cl-remove-if + (lambda (field) + (or reached-end + (when (string-match "[\r\n]" field) + (setq reached-end t) + nil))) + (split-string + (substring text match-end) + "[\n\t\r ]*,[\n\t\r ]*" t)))))) + (setq note t) + (add-to-list + 'intero-suggestions + (list :type 'add-missing-fields + :fields fields + :line (flycheck-error-line msg) + :column (flycheck-error-column msg))) + (setq start (min (length text) (1+ match-end)))))) + + ;; Messages of this format: + ;; ;; Can't make a derived instance of ‘Functor X’: ;; You need DeriveFunctor to derive an instance for this class ;; Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension ;; In the newtype declaration for ‘X’ (let ((start 0)) - (while (string-match extension-regex text start) + (while (let ((case-fold-search nil)) + (string-match extension-regex text start)) (setq note t) (add-to-list 'intero-suggestions (list :type 'add-extension @@ -3025,6 +3068,15 @@ (plist-get suggestion :ident) (plist-get suggestion :module)) :default t)) + (add-missing-fields + (list :key suggestion + :default t + :title + (format "Add missing fields to record: %s" + (mapconcat (lambda (ident) + (concat "‘" ident "’")) + (plist-get suggestion :fields) + ", ")))) (redundant-import-item (list :key suggestion :title @@ -3157,7 +3209,16 @@ (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)))))) + (insert (plist-get suggestion :replacement)))) + (add-missing-fields + (save-excursion + (goto-char (point-min)) + (forward-line (1- (plist-get suggestion :line))) + (move-to-column (- (plist-get suggestion :column) 1)) + (search-forward "{") + (insert (mapconcat (lambda (field) (concat field " = _")) + (plist-get suggestion :fields) + ", ")))))) ;; # Changes that do increase/decrease line numbers ;; ;; Remove redundant constraints diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.28 + 0.1.29 synopsis: Complete interactive development program for Haskell license: