;;; lsp-haskell.el --- Haskell support for lsp-mode ;; Version: 1.0 ;; Package-Version: 20180828.838 ;; 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 (and (fboundp 'projectile-project-root) (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