17ee0e400b
After moving off of Meta, Dotfiles has a greater responsibility to manage configs. Vim, Tmux, and Emacs are now within Stow's purview.
301 lines
12 KiB
EmacsLisp
301 lines
12 KiB
EmacsLisp
;;; lsp-haskell.el --- Haskell support for lsp-mode
|
||
|
||
;; Version: 1.0
|
||
;; Package-Version: 20180826.1119
|
||
;; 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"
|
||
(if (fboundp 'projectile-project-root)
|
||
(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
|