2018-09-10 20:51:14 +02:00
|
|
|
|
;;; lsp-haskell.el --- Haskell support for lsp-mode
|
|
|
|
|
|
|
|
|
|
|
|
;; Version: 1.0
|
2018-10-02 15:54:39 +02:00
|
|
|
|
;; Package-Version: 20180828.838
|
2018-09-10 20:51:14 +02:00
|
|
|
|
;; Package-Requires: ((lsp-mode "3.0") (haskell-mode "1.0"))
|
|
|
|
|
|
;; Keywords: haskell
|
|
|
|
|
|
;; URL: https://github.com/emacs-lsp/lsp-haskell
|
|
|
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
|
|
(require 'haskell)
|
|
|
|
|
|
(require 'lsp-mode)
|
|
|
|
|
|
(require 'projectile nil 'noerror)
|
|
|
|
|
|
|
|
|
|
|
|
;; ---------------------------------------------------------------------
|
|
|
|
|
|
;; Configuration
|
|
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
|
(defgroup lsp-haskell nil
|
|
|
|
|
|
"Customization group for ‘lsp-haskell’."
|
|
|
|
|
|
:group 'lsp-mode)
|
|
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
|
(defcustom lsp-haskell-process-path-hie
|
|
|
|
|
|
;; "hie"
|
|
|
|
|
|
"hie-wrapper"
|
|
|
|
|
|
"The path for starting the haskell-ide-engine
|
|
|
|
|
|
server. hie-wrapper exists on HIE master from 2018-06-10"
|
|
|
|
|
|
:group 'lsp-haskell
|
|
|
|
|
|
:type '(choice string))
|
|
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
|
(defcustom lsp-haskell-process-args-hie
|
|
|
|
|
|
'("-d" "-l" "/tmp/hie.log")
|
|
|
|
|
|
"The arguments for starting the haskell-ide-engine server.
|
|
|
|
|
|
For a debug log, use `-d -l /tmp/hie.log'."
|
|
|
|
|
|
:group 'lsp-haskell
|
|
|
|
|
|
:type '(repeat (string :tag "Argument")))
|
|
|
|
|
|
|
|
|
|
|
|
;; ---------------------------------------------------------------------
|
|
|
|
|
|
;; HaRe functions
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-demote ()
|
|
|
|
|
|
"Demote a function to the level it is used"
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:demote"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:pos ,(lsp-point-to-position (point))))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-duplicate-definition (newname)
|
|
|
|
|
|
"Duplicate a definition"
|
|
|
|
|
|
(interactive "sNew definition name: ")
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:dupdef"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:pos ,(lsp-point-to-position (point))
|
|
|
|
|
|
:text ,newname))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-if-to-case ()
|
|
|
|
|
|
"Convert an if statement to a case statement"
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:iftocase"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:start_pos ,(lsp-get-start-position)
|
|
|
|
|
|
:end_pos ,(lsp-get-end-position)))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-lift-level ()
|
|
|
|
|
|
"Lift a function to the top level"
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:liftonelevel"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:pos ,(lsp-point-to-position (point))))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-lift-to-top ()
|
|
|
|
|
|
"Lift a function to the top level"
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:lifttotoplevel"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:pos ,(lsp-point-to-position (point))))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-delete-definition ()
|
|
|
|
|
|
"Delete a definition"
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:deletedef"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:pos ,(lsp-point-to-position (point))))))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-generalise-applicative ()
|
|
|
|
|
|
"Generalise a monadic function to use applicative"
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(lsp--cur-workspace-check)
|
|
|
|
|
|
(lsp--send-execute-command
|
|
|
|
|
|
"hare:genapplicative"
|
|
|
|
|
|
(vector `(:file ,(concat "file://" buffer-file-name)
|
|
|
|
|
|
:pos ,(lsp-point-to-position (point))))))
|
|
|
|
|
|
|
|
|
|
|
|
;; ---------------------------------------------------------------------
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-haskell--session-cabal-dir ()
|
|
|
|
|
|
"Get the session cabal-dir."
|
|
|
|
|
|
(let* ((cabal-file (haskell-cabal-find-file))
|
|
|
|
|
|
(cabal-dir (if cabal-file
|
|
|
|
|
|
(file-name-directory cabal-file)
|
|
|
|
|
|
"." ;; no cabal file, use directory only
|
|
|
|
|
|
)))
|
|
|
|
|
|
(progn
|
|
|
|
|
|
(message "cabal-dir: %s" cabal-dir)
|
|
|
|
|
|
cabal-dir)))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-haskell--get-root ()
|
|
|
|
|
|
"Get project root directory.
|
|
|
|
|
|
|
|
|
|
|
|
First searches for root via projectile. Tries to find cabal file
|
|
|
|
|
|
if projectile way fails"
|
2018-10-02 15:54:39 +02:00
|
|
|
|
(if (and (fboundp 'projectile-project-root) (projectile-project-root))
|
2018-09-10 20:51:14 +02:00
|
|
|
|
(projectile-project-root)
|
|
|
|
|
|
(let ((dir (lsp-haskell--session-cabal-dir)))
|
|
|
|
|
|
(if (string= dir "/")
|
|
|
|
|
|
(user-error (concat "Couldn't find cabal file, using:" dir))
|
|
|
|
|
|
dir))))
|
|
|
|
|
|
|
|
|
|
|
|
;; ---------------------------------------------------------------------
|
|
|
|
|
|
|
|
|
|
|
|
;;----------------------------------------------------------------------
|
|
|
|
|
|
;; AZ: Not sure where this section should go, putting it here for now
|
|
|
|
|
|
|
|
|
|
|
|
;; AZ: This section based on/inspired by the intero 'intero-apply-suggestions' code, at
|
|
|
|
|
|
;; https://github.com/commercialhaskell/intero/blob/master/elisp/intero.el
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp-apply-commands ()
|
|
|
|
|
|
"Prompt and apply any codeAction commands."
|
|
|
|
|
|
(interactive)
|
|
|
|
|
|
(if (null lsp-code-actions)
|
|
|
|
|
|
(message "No actions to apply")
|
|
|
|
|
|
(let ((to-apply
|
|
|
|
|
|
(lsp--intero-multiswitch
|
|
|
|
|
|
(format "There are %d suggestions to apply:" (length lsp-code-actions))
|
|
|
|
|
|
(cl-remove-if-not
|
|
|
|
|
|
#'identity
|
|
|
|
|
|
(mapcar
|
|
|
|
|
|
(lambda (suggestion)
|
|
|
|
|
|
;; (pcase (plist-get suggestion :type)
|
|
|
|
|
|
;; (add-extension
|
|
|
|
|
|
;; (list :key suggestion
|
|
|
|
|
|
;; :title (concat "Add {-# LANGUAGE "
|
|
|
|
|
|
;; (plist-get suggestion :extension)
|
|
|
|
|
|
;; " #-}")
|
|
|
|
|
|
;; :default t))
|
|
|
|
|
|
;; (redundant-constraint
|
|
|
|
|
|
;; (list :key suggestion
|
|
|
|
|
|
;; :title (concat
|
|
|
|
|
|
;; "Remove redundant constraints: "
|
|
|
|
|
|
;; (string-join (plist-get suggestion :redundancies)
|
|
|
|
|
|
;; ", ")
|
|
|
|
|
|
;; "\n from the "
|
|
|
|
|
|
;; (plist-get suggestion :signature))
|
|
|
|
|
|
;; :default nil)))
|
|
|
|
|
|
;; (message "lsp-apply-command:suggestion command=%s" (gethash "command" suggestion))
|
|
|
|
|
|
;; (message "lsp-apply-command:suggestion ommand=args%s" (gethash "arguments" suggestion))
|
|
|
|
|
|
(list :key (gethash "title" suggestion)
|
|
|
|
|
|
:title (gethash "title" suggestion)
|
|
|
|
|
|
:type "codeAction"
|
|
|
|
|
|
:default t
|
|
|
|
|
|
:command suggestion)
|
|
|
|
|
|
)
|
|
|
|
|
|
lsp-code-actions)))))
|
|
|
|
|
|
(if (null to-apply)
|
|
|
|
|
|
(message "No changes selected to apply.")
|
|
|
|
|
|
(let ((sorted (sort to-apply
|
|
|
|
|
|
(lambda (lt gt)
|
|
|
|
|
|
(let ((lt-line (or (plist-get lt :line) 0))
|
|
|
|
|
|
(lt-column (or (plist-get lt :column) 0))
|
|
|
|
|
|
(gt-line (or (plist-get gt :line) 0))
|
|
|
|
|
|
(gt-column (or (plist-get gt :column) 0)))
|
|
|
|
|
|
(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 ;; (message "lsp-apply-commands:suggestion=%s" suggestion)
|
|
|
|
|
|
(pcase (plist-get suggestion :type)
|
|
|
|
|
|
(otherwise
|
|
|
|
|
|
(lsp--execute-lsp-server-command suggestion))))
|
|
|
|
|
|
;; # Changes that do not increase/decrease line numbers
|
|
|
|
|
|
;;
|
|
|
|
|
|
;; Update in-place suggestions
|
|
|
|
|
|
|
|
|
|
|
|
;; # Changes that do increase/decrease line numbers
|
|
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
|
;; Add extensions to the top of the file
|
|
|
|
|
|
)))))
|
|
|
|
|
|
|
|
|
|
|
|
;; The following is copied directly from intero. I suspect it would be better to
|
|
|
|
|
|
;; have it in a dependency somewhere
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp--intero-multiswitch (title options)
|
|
|
|
|
|
"Displaying TITLE, read multiple flags from a list of OPTIONS.
|
|
|
|
|
|
Each option is a plist of (:key :default :title) wherein:
|
|
|
|
|
|
|
|
|
|
|
|
:key should be something comparable with EQUAL
|
|
|
|
|
|
:title should be a string
|
|
|
|
|
|
:default (boolean) specifies the default checkedness"
|
|
|
|
|
|
(let ((available-width (window-total-width)))
|
|
|
|
|
|
(save-window-excursion
|
|
|
|
|
|
(lsp--intero-with-temp-buffer
|
|
|
|
|
|
(rename-buffer (generate-new-buffer-name "multiswitch"))
|
|
|
|
|
|
(widget-insert (concat title "\n\n"))
|
|
|
|
|
|
(widget-insert (propertize "Hit " 'face 'font-lock-comment-face))
|
|
|
|
|
|
(widget-create 'push-button :notify
|
|
|
|
|
|
(lambda (&rest ignore)
|
|
|
|
|
|
(exit-recursive-edit))
|
|
|
|
|
|
"C-c C-c")
|
|
|
|
|
|
(widget-insert (propertize " to apply these choices.\n\n" 'face 'font-lock-comment-face))
|
|
|
|
|
|
(let* ((me (current-buffer))
|
|
|
|
|
|
(choices (mapcar (lambda (option)
|
|
|
|
|
|
(append option (list :value (plist-get option :default))))
|
|
|
|
|
|
options)))
|
|
|
|
|
|
(cl-loop for option in choices
|
|
|
|
|
|
do (widget-create
|
|
|
|
|
|
'toggle
|
|
|
|
|
|
:notify (lambda (widget &rest ignore)
|
|
|
|
|
|
(setq choices
|
|
|
|
|
|
(mapcar (lambda (choice)
|
|
|
|
|
|
(if (equal (plist-get choice :key)
|
|
|
|
|
|
(plist-get (cdr widget) :key))
|
|
|
|
|
|
(plist-put choice :value (plist-get (cdr widget) :value))
|
|
|
|
|
|
choice))
|
|
|
|
|
|
choices)))
|
|
|
|
|
|
:on (concat "[x] " (plist-get option :title))
|
|
|
|
|
|
:off (concat "[ ] " (plist-get option :title))
|
|
|
|
|
|
:value (plist-get option :default)
|
|
|
|
|
|
:key (plist-get option :key)
|
|
|
|
|
|
:command (plist-get option :command)))
|
|
|
|
|
|
(let ((lines (line-number-at-pos)))
|
|
|
|
|
|
(select-window (split-window-below))
|
|
|
|
|
|
(switch-to-buffer me)
|
|
|
|
|
|
(goto-char (point-min)))
|
|
|
|
|
|
(use-local-map
|
|
|
|
|
|
(let ((map (copy-keymap widget-keymap)))
|
|
|
|
|
|
(define-key map (kbd "C-c C-c") 'exit-recursive-edit)
|
|
|
|
|
|
(define-key map (kbd "C-g") 'abort-recursive-edit)
|
|
|
|
|
|
map))
|
|
|
|
|
|
(widget-setup)
|
|
|
|
|
|
(recursive-edit)
|
|
|
|
|
|
(kill-buffer me)
|
|
|
|
|
|
(mapcar (lambda (choice)
|
|
|
|
|
|
(plist-get choice :command))
|
|
|
|
|
|
(cl-remove-if-not (lambda (choice)
|
|
|
|
|
|
(plist-get choice :value))
|
|
|
|
|
|
choices)))))))
|
|
|
|
|
|
|
|
|
|
|
|
;; The following is copied directly from intero. I suspect it would be better to
|
|
|
|
|
|
;; have it in a dependency somewhere
|
|
|
|
|
|
(defmacro lsp--intero-with-temp-buffer (&rest body)
|
|
|
|
|
|
"Run BODY in `with-temp-buffer', but inherit certain local variables from the current buffer first."
|
|
|
|
|
|
(declare (indent 0) (debug t))
|
|
|
|
|
|
`(let ((initial-buffer (current-buffer)))
|
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
|
(lsp--intero-inherit-local-variables initial-buffer)
|
|
|
|
|
|
,@body)))
|
|
|
|
|
|
|
|
|
|
|
|
;; The following is copied directly from intero. I suspect it would be better to
|
|
|
|
|
|
;; have it in a dependency somewhere
|
|
|
|
|
|
(defun lsp--intero-inherit-local-variables (buffer)
|
|
|
|
|
|
"Make the current buffer inherit values of certain local variables from BUFFER."
|
|
|
|
|
|
(let ((variables '(
|
|
|
|
|
|
;; TODO: shouldn’t more of the above be here?
|
|
|
|
|
|
)))
|
|
|
|
|
|
(cl-loop for v in variables do
|
|
|
|
|
|
(set (make-local-variable v) (buffer-local-value v buffer)))))
|
|
|
|
|
|
;; ---------------------------------------------------------------------
|
|
|
|
|
|
|
|
|
|
|
|
(lsp-define-stdio-client lsp-haskell "haskell" #'lsp-haskell--get-root
|
|
|
|
|
|
;; '("hie" "--lsp" "-d" "-l" "/tmp/hie.log"))
|
|
|
|
|
|
;; '("hie" "--lsp" "-d" "-l" "/tmp/hie.log" "--vomit"))
|
|
|
|
|
|
(lsp--haskell-hie-command))
|
|
|
|
|
|
|
|
|
|
|
|
(defun lsp--haskell-hie-command ()
|
|
|
|
|
|
"Comamnd and arguments for launching the inferior hie process.
|
|
|
|
|
|
These are assembled from the customizable variables
|
|
|
|
|
|
`lsp-haskell-process-path-hie' and
|
|
|
|
|
|
`lsp-haskell-process-args-hie'. If the hie executable is
|
|
|
|
|
|
installed via its Makefile, there will be compiler-specific
|
|
|
|
|
|
versions with names like 'hie-8.0.2' or 'hie-8.2.2'."
|
|
|
|
|
|
(append (list lsp-haskell-process-path-hie "--lsp") lsp-haskell-process-args-hie) )
|
|
|
|
|
|
|
|
|
|
|
|
(provide 'lsp-haskell)
|
|
|
|
|
|
;;; lsp-haskell.el ends here
|
