;;; 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