;;; stack-mode.el --- A minor mode enabling various features based on

;;; stack-ide.

;; Copyright (c) 2015 Chris Done.

;; This file is free software; you can redistribute it and/or modify

;; it under the terms of the GNU General Public License as published by

;; the Free Software Foundation; either version 3, or (at your option)

;; any later version.

;; This file is distributed in the hope that it will be useful,

;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License

;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Code:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Imports

(require 'haskell-mode)

(require 'haskell-cabal)

(require 'cl-lib)

(require 'fifo)

(require 'flycheck)

(require 'json)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Modes

(define-minor-mode stack-mode

  "A minor mode enabling various features based on stack-ide.

Automatically starts and stops flycheck-mode when you

enable/disable it. It makes this assumption in the interest of

easier user experience. Disable with `stack-mode-manage-flycheck'."

  :lighter " Stack"

  :keymap (let ((map (make-sparse-keymap)))

            (define-key map (kbd "M-.") 'stack-mode-goto)

            (define-key map (kbd "C-c C-k") 'stack-mode-clear)

            (define-key map (kbd "C-c C-t") 'stack-mode-type)

            (define-key map (kbd "C-c C-i") 'stack-mode-info)

            (define-key map (kbd "C-c C-l") 'stack-mode-load)

            map)

  (when (buffer-file-name)

    (if stack-mode

        (progn (when (bound-and-true-p interactive-haskell-mode)

                 (when (y-or-n-p "interactive-haskell-mode is enabled. Disable it?")

                   (interactive-haskell-mode -1)))

               (when stack-mode-manage-flycheck

                 (flycheck-mode 1)

                 (flycheck-select-checker 'stack-ide)

                 (flycheck-buffer)))

      (when stack-mode-manage-flycheck

        (flycheck-mode -1)))))

(define-derived-mode inferior-stack-mode fundamental-mode "Inferior-Stack-IDE"

  "Major mode for interacting with an inferior stack-ide process.")

(define-key inferior-stack-mode-map (kbd "C-c C-c") 'stack-mode-stop)

(define-key inferior-stack-mode-map (kbd "C-c C-k") 'stack-mode-clear)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Customization

(defgroup stack-mode nil

  "IDE backend support for Haskell."

  :group 'haskell)

(defcustom stack-mode-proc-path

  "stack"

  "Path to the stack executable."

  :type 'string

  :group 'stack-mode)

(defcustom stack-mode-manage-flycheck

  t

  "Automatically start and stop flycheck when the minor mode is

enabled/disabled."

  :type 'boolean

  :group 'stack-mode)

(defcustom stack-mode-print-error-messages

  nil

  "Print error messages after loading the project?"

  :type 'boolean

  :group 'stack-mode)

(defcustom stack-mode-show-popup

  nil

  "Show type and info messages in a popup?"

  :type 'boolean

  :group 'stack-mode)

(defvar stack-mode-queue nil)

(make-variable-buffer-local 'stack-mode-queue)

(defvar stack-mode-back-queue nil)

(make-variable-buffer-local 'stack-mode-back-queue)

(defvar stack-mode-buffer nil)

(make-variable-buffer-local 'stack-mode-buffer)

(defvar stack-mode-name nil)

(make-variable-buffer-local 'stack-mode-name)

(defvar stack-mode-tried-to-start nil)

(make-variable-buffer-local 'stack-mode-tried-to-start)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Interactive functions

(defun stack-mode-status ()

  "Print the status of the current stack process."

  (interactive)

  (if (stack-mode-buffer)

      (if (stack-mode-process)

          (if (process-live-p (stack-mode-process))

              (message "The process is live.")

            (message "There is a Stack process, but it's dead."))

        (message "There is a stack buffer, but no Stack process."))

    (message "There is no Stack buffer.")))

(defun stack-mode-start ()

  "Start an inferior process and buffer."

  (interactive)

  (if (stack-mode-live-p)

      (switch-to-buffer (stack-mode-buffer))

    (with-current-buffer (stack-mode-buffer)

      (setq buffer-read-only t)

      (inferior-stack-mode)

      (stack-mode-set-initial-command)

      (setq stack-mode-buffer "")

      (let* ((project-name (stack-mode-name))

             (name (stack-mode-process-name project-name))

             (args (append (list name

                                 nil

                                 stack-mode-proc-path

                                 "ide"

                                 "start")

                           (list project-name)))

             (process (or (get-process name)

                          (progn (stack-mode-log "Starting: %S" args)

                                 (apply #'start-process

                                        args)))))

        (set-process-sentinel process 'stack-mode-sentinel)

        (set-process-filter process 'stack-mode-filter)))))

(defun stack-mode-set-initial-command ()

  "Set the initial command callback. The `stack ide` command will

reload targets on start-up, so that's the default command we'll

start with."

  (setq stack-mode-current-command

        (list :json nil

              :data nil

              :cont 'stack-mode-loading-callback

              :label nil))

  (setq stack-mode-queue (fifo-make))

  (stack-mode-log "Set initial command."))

(defun stack-mode-stop ()

  "Stop the process."

  (interactive)

  (with-current-buffer (stack-mode-buffer)

    (when (stack-mode-process)

      (setq stack-mode-current-command nil)

      (setq stack-mode-buffer "")

      (kill-process (stack-mode-process))

      (delete-process (stack-mode-process)))))

(defun stack-mode-reset ()

  "Reset the process."

  (interactive)

  (with-current-buffer (stack-mode-buffer)

    (when (stack-mode-process)

      (setq stack-mode-current-command nil)

      (setq stack-mode-buffer "")

      (setq stack-mode-queue (fifo-make)))))

(defun stack-mode-restart ()

  "Restart the process with a fresh command queue."

  (interactive)

  (stack-mode-stop)

  (stack-mode-start))

(defun stack-mode-live-p ()

  "Is the process alive?"

  (and (stack-mode-process)

       (process-live-p (stack-mode-process))))

(defun stack-mode-clear ()

  "Clear the interaction buffer."

  (interactive)

  (with-current-buffer (stack-mode-buffer)

    (let ((inhibit-read-only t))

      (erase-buffer))))

(defun stack-mode-load ()

  "Load the current buffer's file."

  (interactive)

  (save-buffer)

  (with-current-buffer (stack-mode-buffer)

    (stack-mode-reload)))

(defun stack-mode-goto ()

  "Go to definition of thing at point."

  (interactive)

  (let ((filename (buffer-file-name))

        (module-name (haskell-guess-module-name))

        (span (stack-mode-span)))

    (let* ((span-info

            (stack-mode-get-span-info

             module-name

             (with-current-buffer (stack-mode-buffer)

               (file-relative-name filename default-directory))

             span))

           (infos

            (stack-contents

             span-info))

           (_ (when (and (vectorp infos) (= 0 (length infos)))

                (error "Couldn't find location for this. Is the module loaded in the backend?

Run `M-x stack-mode-list-loaded-modules' to see what's loaded.")))

           (parts (mapcar #'identity (elt infos 0)))

           (info (stack-contents (elt parts 0)))

           (span (elt parts 1))

           (scope (stack-lookup 'tag (stack-lookup 'idScope info)))

           (def-span (stack-lookup-contents

                      'idDefSpan

                      (stack-lookup 'idProp info))))

      (cond

       ((listp def-span)

        (stack-mode-goto-span def-span))

       (t

        (let* ((imported-from

                (stack-lookup

                 'idImportedFrom

                 (stack-lookup 'idScope info)))

               (imported-module (stack-lookup 'moduleName imported-from))

               (defined-in (stack-lookup

                            'idDefinedIn

                            (stack-lookup 'idProp info)))

               (package (stack-lookup 'modulePackage defined-in))

               (package-name (stack-lookup 'packageName package))

               (package-ver (stack-lookup 'packageVersion package))

               (module (stack-lookup 'moduleName defined-in)))

          (message "Imported via %s, defined in %s (%s-%s)"

                   (haskell-fontify-as-mode imported-module 'haskell-mode)

                   (haskell-fontify-as-mode module 'haskell-mode)

                   package-name

                   package-ver)))))))

(defun stack-mode-list-loaded-modules ()

  "List the loaded modules in the backend."

  (interactive)

  (let ((modules

         (stack-contents

          (with-current-buffer (stack-mode-buffer)

            (stack-mode-call

             `((tag . "RequestGetLoadedModules")

               (contents

                . [])))))))

    (pop-to-buffer (stack-mode-buffer))

    (stack-mode-log "Loaded modules: %s"

                    (mapconcat #'identity

                               (sort (mapcar #'identity modules) #'string<)

                               "\n"))))

(defun stack-mode-info ()

  "Display the info of the thing at point."

  (interactive)

  (let* ((filename (buffer-file-name))

         (module-name (haskell-guess-module-name))

         (points (stack-mode-points))

         (orig (point))

         (span (stack-mode-span-from-points (car points)

                                            (cdr points)))

         (info (stack-mode-get-span-info

                module-name

                (with-current-buffer (stack-mode-buffer)

                  (file-relative-name filename default-directory))

                span))

         (info-contents (stack-contents (elt (elt (stack-contents info) 0) 0)))

         (scope (stack-lookup 'idScope info-contents))

         (prop (stack-lookup 'idProp info-contents))

         (qual (stack-lookup 'idImportQual scope))

         (from (stack-lookup 'idImportedFrom scope))

         (span (stack-lookup 'idImportSpan scope))

         (space (stack-lookup 'idSpace prop))

         (idDefSpan (stack-lookup 'idDefSpan prop))

         (idDefinedIn (stack-lookup 'idDefinedIn prop))

         (modulePackage (stack-lookup 'modulePackage idDefinedIn))

         (moduleName (stack-lookup 'moduleName idDefinedIn))

         (packageVersion (stack-lookup 'packageVersion modulePackage))

         (packageKey (stack-lookup 'packageKey modulePackage))

         (packageName (stack-lookup 'packageKey modulePackage))

         (idType (stack-lookup 'idType prop))

         (idName (stack-lookup 'idName prop)))

    (let ((info-string (concat

                        "Identifier: " (haskell-fontify-as-mode idName 'haskell-mode) "\n"

                        "Type: " (haskell-fontify-as-mode idType 'haskell-mode) "\n"

                        "Module: " (haskell-fontify-as-mode moduleName 'haskell-mode) "\n"

                        "Package: "  (if (string= "main" packageName)

                                         "(this one)"

                                       packageName))))

      (cond (stack-mode-show-popup

             (when (boundp popup-tip)

               (popup-tip info-string)))

            (t (message info-string))))))

(defun stack-mode-type (&optional insert-value)

  "Display type info of thing at point."

  (interactive "P")

  (let* ((filename (buffer-file-name))

         (module-name (haskell-guess-module-name))

         (points (stack-mode-points))

         (orig (point))

         (span (stack-mode-span-from-points (car points)

                                            (cdr points))))

    (let* ((types (stack-contents

                   (stack-mode-get-exp-types

                    module-name

                    (with-current-buffer (stack-mode-buffer)

                      (file-relative-name filename default-directory))

                    span)))

           (types (mapcar #'identity types))

           (code (buffer-substring-no-properties

                  (car points)

                  (cdr points)))

           (type (stack-contents (car types)))

           (ty (stack-lookup 'text type)))

      (if insert-value

          (let ((ident-pos (haskell-ident-pos-at-point)))

            (cond

             ((region-active-p)

              (delete-region (region-beginning)

                             (region-end))

              (insert "(" code " :: " ty ")")

              (goto-char (1+ orig)))

             ((= (line-beginning-position) (car ident-pos))

              (goto-char (line-beginning-position))

              (insert code " :: " (haskell-fontify-as-mode ty 'haskell-mode)

                      "\n"))

             (t

              (save-excursion

                (goto-char (car ident-pos))

                (let ((col (current-column)))

                  (save-excursion (insert "\n")

                                  (indent-to col))

                  (insert code " :: " (haskell-fontify-as-mode ty 'haskell-mode)))))))

        (unless (null types)

          (let ((type-string (format "%s"

                                     (mapconcat (lambda (type)

                                                  (haskell-fontify-as-mode

                                                   (concat

                                                    code

                                                    " :: "

                                                    (elt type 0))

                                                   'haskell-mode))

                                                (cl-subseq types 0 1)

                                                "\n"))))

            (cond (stack-mode-show-popup (popup-tip type-string))

                  (t (message type-string)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Process filters and sentinel

(defun stack-mode-filter (process response)

  (with-current-buffer (stack-mode-buffer (stack-mode-name-from-process process))

    (if stack-mode-current-command

        (let* ((lines (split-string (concat stack-mode-buffer response) "\n")))

          (setq stack-mode-buffer (car (last lines)))

          (setq lines (butlast lines))

          (let ((data (plist-get stack-mode-current-command :data))

                (cont (plist-get stack-mode-current-command :cont)))

            (while lines

              (let ((line (pop lines)))

                (stack-mode-log

                 "%s <- %s"

                 (if (plist-get stack-mode-current-command :label)

                     (format "[%s]" (plist-get stack-mode-current-command :label))

                   "")