diff --git a/elisp/intero.el b/elisp/intero.el --- a/elisp/intero.el +++ b/elisp/intero.el @@ -54,7 +54,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Configuration -(defconst intero-package-version "0.1.13" +(defconst intero-package-version "0.1.15" "Package version to auto-install.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -256,7 +256,8 @@ (intero-get-worker-create 'backend targets (current-buffer)))) (defun intero-destroy (&optional worker) - "Stop the current worker process and kill its associated." + "Stop the current worker process and kill its associated +process buffer." (interactive) (if worker (intero-delete-worker worker) @@ -425,6 +426,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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) (interactive (list 'interactive)) (cl-case command @@ -440,14 +448,43 @@ (unless (intero-gave-up 'backend) (let ((prefix-info (intero-completions-grab-prefix))) (when prefix-info - (cl-destructuring-bind - (beg end prefix _type) prefix-info - (intero-get-completions beg end)))))))) + (cons :async + (-partial 'intero-company-callback + (current-buffer) + prefix-info)))))))) +(defun intero-company-callback (source-buffer prefix-info cont) + "Generate completions and call CONT on the results." + (cl-destructuring-bind + (beg end prefix type) prefix-info + (or (cl-case type + (haskell-completions-module-name-prefix + (intero-get-repl-completions source-buffer (concat "import " prefix) cont)) + (haskell-completions-identifier-prefix + (intero-get-completions source-buffer beg end cont)) + (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))) + (haskell-completions-pragma-name-prefix + (funcall cont + (cl-remove-if-not + (lambda (candidate) + (string-match (concat "^" prefix) candidate)) + intero-pragmas)))) + (intero-get-repl-completions source-buffer prefix cont)))) + (defun intero-completions-grab-prefix (&optional minlen) "Grab prefix at point for possible completion." (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) @@ -498,6 +535,76 @@ (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 @@ -768,25 +875,49 @@ (1+ (current-column))) (buffer-substring-no-properties beg end))))) -(defun intero-get-completions (beg end) +(defun intero-get-completions (source-buffer beg end cont) "Get completions for a PREFIX." - (split-string - (intero-blocking-call - 'backend - (format ":complete-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))) - "\n" - t)) + (intero-async-call + 'backend + (format ":complete-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)) + (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)))))))) +(defun intero-get-repl-completions (source-buffer prefix cont) + "Get REPL completions for PREFIX, calling CONT with the results +in buffer 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 @@ -909,8 +1040,8 @@ (intero-make-options-list (or targets (let ((package-name (buffer-local-value 'intero-package-name buffer))) - (unless (equal "" package-name) - (list package-name)))) + (unless (equal "" package-name) + (list package-name)))) (not (buffer-local-value 'intero-try-with-build buffer)))) (arguments options) (process (with-current-buffer buffer diff --git a/intero.cabal b/intero.cabal --- a/intero.cabal +++ b/intero.cabal @@ -1,7 +1,7 @@ name: intero version: - 0.1.14 + 0.1.15 synopsis: Complete interactive development program for Haskell license: @@ -47,7 +47,7 @@ main-is: Main.hs ghc-options: - -Wall -O2 -threaded + -Wall -O2 -threaded -rtsopts include-dirs: cbits/ hs-source-dirs: