Trying stack-ide-mode.
--- a/elisp/haskell-init.el Tue Sep 15 14:40:04 2015 -0500
+++ b/elisp/haskell-init.el Wed Sep 16 16:53:07 2015 -0500
@@ -5,13 +5,15 @@
(require 'package-require)
(package-require '(haskell-mode yasnippet haskell-snippets flycheck flycheck-haskell shm))
+(add-to-list 'load-path "~/.emacs.d/elisp/stack-mode")
+
;; Load haskell-mode from source
;; (add-to-list 'load-path "~/Code/elisp/haskell-mode/")
;; (require 'haskell-mode-autoloads)
(require 'haskell)
(require 'haskell-mode)
-(require 'haskell-process)
+(require 'stack-mode)
(require 'haskell-interactive-mode)
(require 'haskell-snippets)
(require 'shm)
@@ -33,23 +35,6 @@
(rename-buffer "*who-calls*")
(switch-to-buffer-other-window buffer)))))
-(defun haskell-process-all-types ()
- "List all types in a grep-mode buffer."
- (interactive)
- (let ((session (haskell-session)))
- (switch-to-buffer (get-buffer-create (format "*%s:all-types*"
- (haskell-session-name (haskell-session)))))
- (setq haskell-session session)
- (cd (haskell-session-current-dir session))
- (let ((inhibit-read-only t))
- (erase-buffer)
- (let ((haskell-process-log nil))
- (insert (haskell-process-queue-sync-request (haskell-process) ":all-types")))
- (unless (eq major-mode 'compilation-mode)
- (compilation-mode)
- (setq compilation-error-regexp-alist
- haskell-compilation-error-regexp-alist)))))
-
;;; haskell-mode
(add-hook
'haskell-mode-hook
@@ -57,7 +42,9 @@
;; (imenu-add-menubar-index)
(flycheck-mode)
(flycheck-haskell-setup)
+ (flycheck-disable-checker 'haskell-ghc)
;; (haskell-indentation-mode t)
+ (stack-mode)
(subword-mode)
(electric-indent-mode 0)
(structured-haskell-mode t)
@@ -71,66 +58,69 @@
'(haskell-indentation-layout-offset 4)
'(haskell-indentation-left-offset 4)
- '(shm-use-presentation-mode t)
- '(shm-auto-insert-skeletons t)
- '(shm-auto-insert-bangs t)
-
- '(haskell-process-type 'cabal-repl)
- ;; '(haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans" "--with-ghc=ghci-ng")) ;; ghci-ng
- ;; '(haskell-process-path-ghci "ghci-ng") ;; ghci-ng
- '(haskell-process-args-ghci "-ferror-spans")
- '(haskell-process-suggest-remove-import-lines t)
- '(haskell-process-auto-import-loaded-modules t)
- '(haskell-process-log t)
- '(haskell-process-reload-with-fbytecode nil)
- '(haskell-process-use-presentation-mode t)
- '(haskell-process-suggest-haskell-docs-imports t)
- '(haskell-process-suggest-hoogle-imports t)
- '(haskell-process-generate-tags nil)
- '(haskell-process-show-debug-tips nil)
+ '(haskell-interactive-mode-eval-pretty t)
+ '(haskell-interactive-mode-scroll-to-bottom t)
+ '(haskell-interactive-mode-eval-mode 'haskell-mode)
'(haskell-notify-p t)
'(haskell-align-imports-pad-after-name t)
'(haskell-ask-also-kill-buffers nil)
'(haskell-import-mapping t)
- '(haskell-interactive-mode-eval-pretty t)
- '(haskell-interactive-mode-scroll-to-bottom t)
- '(haskell-interactive-mode-eval-mode 'haskell-mode))
+ '(shm-use-presentation-mode t)
+ '(shm-auto-insert-skeletons t)
+ '(shm-auto-insert-bangs t))
+
-;; haskell-interactive-mode keybindings
-(define-key interactive-haskell-mode-map (kbd "C-c C-l") 'haskell-process-load-or-reload)
-(define-key interactive-haskell-mode-map (kbd "M-,") 'haskell-who-calls)
-(define-key interactive-haskell-mode-map (kbd "M-.") 'haskell-mode-goto-loc)
-(define-key interactive-haskell-mode-map (kbd "C-?") 'haskell-mode-find-uses)
-(define-key interactive-haskell-mode-map (kbd "C-c C-c") 'haskell-process-cabal-build)
-(define-key interactive-haskell-mode-map (kbd "C-c C-t") 'haskell-mode-show-type-at)
-(define-key interactive-haskell-mode-map (kbd "C-`") 'haskell-interactive-bring)
-(define-key interactive-haskell-mode-map (kbd "C-c C-k") 'haskell-process-clear)
-(define-key interactive-haskell-mode-map (kbd "C-c c") 'haskell-process-cabal)
+;; ;; '(haskell-process-type 'cabal-repl)
+;; ;; ;; '(haskell-process-args-cabal-repl '("--ghc-option=-ferror-spans" "--with-ghc=ghci-ng")) ;; ghci-ng
+;; ;; ;; '(haskell-process-path-ghci "ghci-ng") ;; ghci-ng
+;; ;; '(haskell-process-args-ghci "-ferror-spans")
+;; ;; '(haskell-process-suggest-remove-import-lines t)
+;; ;; '(haskell-process-auto-import-loaded-modules t)
+;; ;; '(haskell-process-log t)
+;; ;; '(haskell-process-reload-with-fbytecode nil)
+;; ;; '(haskell-process-use-presentation-mode t)
+;; ;; '(haskell-process-suggest-haskell-docs-imports t)
+;; ;; '(haskell-process-suggest-hoogle-imports t)
+;; ;; '(haskell-process-generate-tags nil)
+;; ;; '(haskell-process-show-debug-tips nil)
+
+
-(define-key haskell-interactive-mode-map (kbd "C-c C-i") 'haskell-process-do-info)
-(define-key haskell-interactive-mode-map (kbd "C-<left>") 'haskell-interactive-mode-error-backward)
-(define-key haskell-interactive-mode-map (kbd "C-<right>") 'haskell-interactive-mode-error-forward)
-(define-key haskell-interactive-mode-map (kbd "C-c c") 'haskell-process-cabal)
+;; ;; haskell-interactive-mode keybindings
+;; (define-key interactive-haskell-mode-map (kbd "C-c C-l") 'haskell-process-load-or-reload)
+;; (define-key interactive-haskell-mode-map (kbd "M-,") 'haskell-who-calls)
+;; (define-key interactive-haskell-mode-map (kbd "M-.") 'haskell-mode-goto-loc)
+;; (define-key interactive-haskell-mode-map (kbd "C-?") 'haskell-mode-find-uses)
+;; (define-key interactive-haskell-mode-map (kbd "C-c C-c") 'haskell-process-cabal-build)
+;; (define-key interactive-haskell-mode-map (kbd "C-c C-t") 'haskell-mode-show-type-at)
+;; (define-key interactive-haskell-mode-map (kbd "C-`") 'haskell-interactive-bring)
+;; (define-key interactive-haskell-mode-map (kbd "C-c C-k") 'haskell-process-clear)
+;; (define-key interactive-haskell-mode-map (kbd "C-c c") 'haskell-process-cabal)
+
+;; (define-key haskell-interactive-mode-map (kbd "C-c C-i") 'haskell-process-do-info)
+;; (define-key haskell-interactive-mode-map (kbd "C-<left>") 'haskell-interactive-mode-error-backward)
+;; (define-key haskell-interactive-mode-map (kbd "C-<right>") 'haskell-interactive-mode-error-forward)
+;; (define-key haskell-interactive-mode-map (kbd "C-c c") 'haskell-process-cabal)
-;; haskell-mode
-(define-key haskell-mode-map (kbd "C-c C-l") 'haskell-process-load-or-reload)
-(define-key haskell-mode-map (kbd "C-`") 'haskell-interactive-bring)
-(define-key haskell-mode-map (kbd "C-c C-t") 'haskell-process-do-type)
-(define-key haskell-mode-map (kbd "C-c i") 'haskell-navigate-imports)
-(define-key haskell-mode-map (kbd "C-c C-i") 'haskell-process-do-info)
-(define-key haskell-mode-map (kbd "C-c C-c") 'haskell-process-cabal-build)
-(define-key haskell-mode-map (kbd "C-c C-d") 'haskell-describe)
-(define-key haskell-mode-map (kbd "C-c C-k") 'haskell-process-clear)
-(define-key haskell-mode-map (kbd "C-c c") 'haskell-process-cabal)
-(define-key haskell-mode-map (kbd "SPC") 'haskell-mode-contextual-space)
+;; ;; haskell-mode
+;; (define-key haskell-mode-map (kbd "C-c C-l") 'haskell-process-load-or-reload)
+;; (define-key haskell-mode-map (kbd "C-`") 'haskell-interactive-bring)
+;; (define-key haskell-mode-map (kbd "C-c C-t") 'haskell-process-do-type)
+;; (define-key haskell-mode-map (kbd "C-c i") 'haskell-navigate-imports)
+;; (define-key haskell-mode-map (kbd "C-c C-i") 'haskell-process-do-info)
+;; (define-key haskell-mode-map (kbd "C-c C-c") 'haskell-process-cabal-build)
+;; (define-key haskell-mode-map (kbd "C-c C-d") 'haskell-describe)
+;; (define-key haskell-mode-map (kbd "C-c C-k") 'haskell-process-clear)
+;; (define-key haskell-mode-map (kbd "C-c c") 'haskell-process-cabal)
+;; (define-key haskell-mode-map (kbd "SPC") 'haskell-mode-contextual-space)
-;; cabal
-(define-key haskell-cabal-mode-map (kbd "C-`") 'haskell-interactive-bring)
-(define-key haskell-cabal-mode-map (kbd "C-c C-k") 'haskell-process-clear)
-(define-key haskell-cabal-mode-map (kbd "C-c C-c") 'haskell-process-cabal-build)
-(define-key haskell-cabal-mode-map (kbd "C-c c") 'haskell-process-cabal)
+;; ;; cabal
+;; (define-key haskell-cabal-mode-map (kbd "C-`") 'haskell-interactive-bring)
+;; (define-key haskell-cabal-mode-map (kbd "C-c C-k") 'haskell-process-clear)
+;; (define-key haskell-cabal-mode-map (kbd "C-c C-c") 'haskell-process-cabal-build)
+;; (define-key haskell-cabal-mode-map (kbd "C-c c") 'haskell-process-cabal)
;; shm
(define-key shm-map (kbd "C-c C-p") 'shm/expand-pattern)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/elisp/stack-mode/LICENSE Wed Sep 16 16:53:07 2015 -0500
@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2015
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/elisp/stack-mode/README.md Wed Sep 16 16:53:07 2015 -0500
@@ -0,0 +1,1 @@
+# stack-mode
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/elisp/stack-mode/checklist.el Wed Sep 16 16:53:07 2015 -0500
@@ -0,0 +1,94 @@
+;;; checklist.el --- Simple checklist UI functionality
+
+;; Copyright (c) 2015 Chris Done. All rights reserved.
+
+;; 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:
+
+(defvar checklist-read-checklist-result nil)
+(make-variable-buffer-local 'checklist-read-checklist-result)
+
+(defun checklist-read-checklist (prompt choices)
+ "Prompt with PROMPT to choose one or more from the list of CHOICES."
+ (switch-to-buffer (generate-new-buffer-name "checklist"))
+ (let ((inhibit-read-only t))
+ (special-mode)
+ (setq buffer-read-only t)
+ (setq cursor-type 'box)
+ (insert (concat prompt "\n\n"))
+ (use-local-map (copy-keymap special-mode-map))
+ (local-set-key "n" 'next-line)
+ (local-set-key "p" 'previous-line)
+ (local-set-key (kbd "RET") 'checklist-checklist-choose)
+ (local-set-key (kbd "SPC") 'checklist-checklist-choose)
+ (local-set-key (kbd "C-c C-c") 'checklist-checklist-done)
+ (save-excursion
+ (cl-loop for choice in choices
+ do (insert (propertize (concat "[ ] " (cdr choice) "\n")
+ 'checklist-check-item (car choice))))
+ (insert "\n")
+ (insert "Hit " (propertize "C-c C-c" 'face 'bold) " to finish."))
+ (add-hook 'post-command-hook #'checklist-highlight-section t t)
+ (setq checklist-read-checklist-result nil)
+ (recursive-edit)
+ (let ((result checklist-read-checklist-result)
+ (kill-buffer-query-functions nil))
+ (kill-buffer (current-buffer))
+ result)))
+
+(defun checklist-checklist-done ()
+ "Done with the checklist, return the result."
+ (interactive)
+ (throw 'exit nil))
+
+(defun checklist-highlight-section ()
+ "Highlight the item at point."
+ (remove-overlays)
+ (when (get-text-property (point) 'checklist-check-item)
+ (let ((o (make-overlay (line-beginning-position)
+ (1+ (line-end-position)))))
+ (overlay-put o 'face 'secondary-selection))))
+
+(defun checklist-checklist-choose ()
+ "Choose the current item at point."
+ (interactive)
+ (let ((inhibit-read-only t)
+ (checked (get-text-property (point) 'checklist-item-checked)))
+ (when (get-text-property (point) 'checklist-check-item)
+ (if checked
+ (setq checklist-read-checklist-result
+ (delete (get-text-property (point) 'checklist-check-item)
+ checklist-read-checklist-result))
+ (add-to-list 'checklist-read-checklist-result
+ (get-text-property (point) 'checklist-check-item)
+ t))
+ (save-excursion (goto-char (line-beginning-position))
+ (delete-region (line-beginning-position)
+ (+ (line-beginning-position) (length "[ ]")))
+ (if checked
+ (insert "[ ]")
+ (insert "[x]")))
+ (put-text-property (line-beginning-position)
+ (1+ (line-end-position))
+ 'checklist-item-checked (not checked))
+ (put-text-property (line-beginning-position)
+ (1+ (line-end-position))
+ 'face (if checked nil 'bold))
+ (put-text-property (line-beginning-position)
+ (1+ (line-end-position))
+ 'checklist-check-item t)
+ (checklist-highlight-section))))
+
+(provide 'checklist)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/elisp/stack-mode/fifo.el Wed Sep 16 16:53:07 2015 -0500
@@ -0,0 +1,55 @@
+;;; fifo.el --- FIFO queue.
+
+;; 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:
+
+(require 'cl-lib)
+
+(defun fifo-make ()
+ "Make a fifo queue."
+ (cons 0 nil))
+
+(defun fifo-push (q a)
+ "Push a new item onto the queue."
+ (cl-assert (consp q) nil "Must be a queue.")
+ (setcar q (1+ (car q)))
+ (let ((next q)
+ (continue t))
+ (while (not (null (cdr next)))
+ (setq next (cdr next)))
+ (setcdr next (cons a nil)))
+ q)
+
+(defun fifo-pop (q)
+ "Pop the next item on the queue."
+ (cl-assert (consp q) nil "Must be a queue.")
+ (cl-assert (consp (cdr q)) nil "No items to pop from queue.")
+ (setcar q (1- (car q)))
+ (let ((a (car (cdr q))))
+ (setcdr q (cdr (cdr q)))
+ a))
+
+(defun fifo-size (q)
+ "Get the size of the queue."
+ (cl-assert (consp q) nil "Must be a queue.")
+ (car q))
+
+(defun fifo-null-p (q)
+ "Is the queue empty?"
+ (= (fifo-size q) 0))
+
+(provide 'fifo)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/elisp/stack-mode/stack-mode.el Wed Sep 16 16:53:07 2015 -0500
@@ -0,0 +1,927 @@
+;;; 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))
+ "")
+ (haskell-fontify-as-mode line 'javascript-mode))
+ (when (let* ((error-msg nil)
+ (json (condition-case e
+ (json-read-from-string line)
+ (error "Problem reading JSON from server, probably an error message:\n%s" line)))
+ (ret (condition-case e
+ (funcall cont data json)
+ (error (setq error-msg e)
+ :error))))
+ (cl-ecase ret
+ (:done t)
+ (:continue nil)
+ (:error
+ (setq stack-mode-buffer "")
+ (setq stack-mode-current-command nil)
+ (setq stack-mode-queue nil)
+ (error "Command handler error: %S\n\nThe command queue has been cleared."
+ error-msg))
+ (t
+ (error "A command handler must return either :done or :continue,
+but it returned: %S
+command was: %S" ret stack-mode-current-command))))
+ (cl-loop for line in lines
+ do (stack-mode-log
+ "Extraneous lines after command completed: %s"
+ (haskell-fontify-as-mode line 'javascript-mode)))
+ (setq stack-mode-current-command nil)
+ (setq lines nil)
+ (stack-mode-queue-trigger))))))
+ (stack-mode-log "Ignoring: %s"
+ (haskell-fontify-as-mode response 'javascript-mode)))))
+
+(defun stack-mode-sentinel (process event)
+ (with-current-buffer (stack-mode-buffer (stack-mode-name-from-process process))
+ (stack-mode-log "Process event: %s" event)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Command queue
+
+(defvar stack-mode-current-command nil
+ "Current command handler.")
+(make-variable-buffer-local 'stack-mode-current-command)
+
+(defvar stack-mode-buffer ""
+ "A buffer for the process.")
+(make-variable-buffer-local 'stack-mode-buffer)
+
+(defvar stack-mode-queue nil
+ "Command queue.")
+(make-variable-buffer-local 'stack-mode-queue)
+
+(defun stack-mode-queue ()
+ "Get the FIFO queue of this process."
+ (or stack-mode-queue
+ (setq stack-mode-queue (fifo-make))))
+
+(defun stack-mode-back-queue ()
+ "Get the FIFO back queue of this process."
+ (or stack-mode-back-queue
+ (setq stack-mode-back-queue (fifo-make))))
+
+(defun stack-mode-enqueue-front (json data cont &optional label)
+ "Enqueue a JSON command to the command queue, calling (CONT
+DATA line) for each response line until CONT returns nil. This is
+the first priority queue, anything pushed to this queue will be
+run before anything in the back queue."
+ (cond
+ ((stack-mode-live-p)
+ (stack-mode-log "[%s] => %s" label (haskell-fontify-as-mode (json-encode json) 'javascript-mode))
+ (fifo-push (stack-mode-queue)
+ (list :json json :data data :cont cont :label label))
+ (stack-mode-queue-trigger))
+ (t (stack-mode-try-start))))
+
+(defun stack-mode-enqueue (json data cont &optional label)
+ "Same as `stack-mode-front', but puts it on the back
+queue. Items are only moved onto the front queue when the front
+queue is empty. This lets a command which consists of a few back
+and forth steps to continue its processing uninterrupted."
+ (cond
+ ((stack-mode-live-p)
+ (stack-mode-log "[%s] ~> %s" label (haskell-fontify-as-mode (json-encode json) 'javascript-mode))
+ (fifo-push (stack-mode-back-queue)
+ (list :json json :data data :cont cont :label label))
+ (stack-mode-queue-trigger))
+ (t (stack-mode-try-start))))
+
+(defun stack-mode-try-start ()
+ "Try to start, but only try once."
+ (cond
+ ((not stack-mode-tried-to-start)
+ (setq stack-mode-tried-to-start t)
+ (message "Starting a Stack IDE backend process for this project: %s, stack directory: %s"
+ (stack-mode-cabal-name)
+ (stack-mode-dir))
+ (stack-mode-start))
+ (t (message "Attempted to run a Stack IDE command, but the server isn't started. We already tried once this session. Run `M-x stack-mode-restart` to confirm that you want to start it."))))
+
+(defun stack-mode-call (json)
+ "Call a JSON command. Wait for any existing queued commands to
+complete, then sends the request, blocking on the
+response. Returns the response."
+ (let ((data (list nil)))
+ (stack-mode-enqueue
+ json data
+ (lambda (data reply)
+ (setcar data reply)
+ :done))
+ (stack-mode-queue-flush)
+ (car-safe data)))
+
+(defun stack-mode-queue-processed-p ()
+ "Return t if command queue has been completely processed."
+ (and (fifo-null-p stack-mode-queue)
+ (null stack-mode-current-command)))
+
+(defun stack-mode-queue-flush ()
+ "Block till PROCESS's command queue has been completely processed.
+This uses `accept-process-output' internally."
+ (let ((proc (stack-mode-process)))
+ (while (not (stack-mode-queue-processed-p))
+ (stack-mode-queue-trigger)
+ (accept-process-output proc 1))))
+
+(defun stack-mode-queue-trigger ()
+ "Trigger the next command in the queue if there is no current
+command."
+ (if stack-mode-current-command
+ (unless (fifo-null-p (stack-mode-queue))
+ (stack-mode-log "Stack command queue is currently active, waiting ..."))
+ (when (fifo-null-p (stack-mode-queue))
+ (stack-mode-log "Command queue is now empty.")
+ (unless (fifo-null-p (stack-mode-back-queue))
+ (stack-mode-log "Pushing next item from back queue to front queue ...")
+ (fifo-push (stack-mode-queue)
+ (fifo-pop (stack-mode-back-queue)))))
+ (unless (fifo-null-p (stack-mode-queue))
+ (setq stack-mode-current-command
+ (fifo-pop (stack-mode-queue)))
+ (stack-mode-log
+ "[%S] -> %s"
+ (plist-get stack-mode-current-command :label)
+ (haskell-fontify-as-mode
+ (json-encode (plist-get stack-mode-current-command :json))
+ 'javascript-mode))
+ (process-send-string
+ (stack-mode-process)
+ (concat (json-encode (plist-get stack-mode-current-command :json))
+ "\n")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Project functions
+
+(defun stack-mode-packages ()
+ "Get packages for the Stack configuration."
+ (split-string (shell-command-to-string "stack ide packages") "\n" t))
+
+(defun stack-mode-process ()
+ "Get the current process."
+ (get-process (stack-mode-process-name (stack-mode-name))))
+
+(defun stack-mode-buffer (&optional name)
+ "The inferior buffer."
+ (let ((default-directory (stack-mode-dir)))
+ (get-buffer-create
+ (stack-mode-buffer-name
+ (or name
+ (stack-mode-name))))))
+
+(defun stack-mode-name-from-process (proc)
+ "Get the name of the project from the process."
+ (substring (process-name proc) (length "stack:")))
+
+(defun stack-mode-process-name (name)
+ "Name for the inferior process."
+ (format "stack:%s"
+ name))
+
+(defun stack-mode-buffer-name (name)
+ "Name for the inferior buffer."
+ (format "*stack:%s*"
+ name))
+
+(defun stack-mode-dir ()
+ "The directory for the project."
+ (file-name-directory (haskell-cabal-find-file)))
+
+(defun stack-mode-name ()
+ "The name for the current project based on the current
+directory."
+ (or stack-mode-name
+ (setq stack-mode-name
+ (stack-mode-cabal-name))))
+
+(defun stack-mode-cabal-name ()
+ "Get the name of the session to use, based on the cabal file."
+ (let ((cabal-file (haskell-cabal-find-file)))
+ (if (string-match "\\([^\\/]+\\)\\.cabal$" cabal-file)
+ (let ((name (match-string 1 cabal-file)))
+ (when (not (member name (stack-mode-packages)))
+ (message "This cabal project “%s” isn't in your stack.yaml configuration." name))
+ name)
+ (progn (message "Couldn't figure out cabal file, assuming no project.")
+ nil))))
+
+(defun stack-mode-log (&rest args)
+ "Log a string to the inferior buffer."
+ (with-current-buffer (stack-mode-buffer)
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert (apply #'format args)
+ "\n"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Commands
+
+(defun stack-mode-reload ()
+ "Compile the code and fetch compile errors."
+ (with-current-buffer (stack-mode-buffer)
+ (stack-mode-enqueue
+ `((tag . "RequestUpdateSession")
+ (contents . []))
+ nil
+ 'stack-mode-loading-callback)))
+
+;; (defun stack-mode-load-buffer ()
+;; "Compile the code and fetch compile errors."
+;; (interactive)
+;; (with-current-buffer (stack-mode-buffer)
+;; (stack-mode-enqueue
+;; `((tag . "RequestUpdateSession")
+;; (contents . [((tag . "RequestUpdateTargets")
+;; (contents . ((tag . "TargetsInclude")
+;; (contents . ["src/Stack/Package.hs"]))))]))
+;; nil
+;; 'stack-mode-loading-callback)))
+
+(defun stack-mode-get-span-info (module file span)
+ "Get the span info of the given location."
+ (with-current-buffer (stack-mode-buffer)
+ (stack-mode-call
+ `((tag . "RequestGetSpanInfo")
+ (contents
+ . ((spanFilePath . ,file)
+ (spanFromLine . ,(plist-get span :sl))
+ (spanFromColumn . ,(plist-get span :sc))
+ (spanToLine . ,(plist-get span :el))
+ (spanToColumn . ,(plist-get span :ec))))))))
+
+(defun stack-mode-get-exp-types (module file span)
+ "Get the type info of the given location."
+ (with-current-buffer (stack-mode-buffer)
+ (stack-mode-call
+ `((tag . "RequestGetExpTypes")
+ (contents
+ . ((spanFilePath . ,file)
+ (spanFromLine . ,(plist-get span :sl))
+ (spanFromColumn . ,(plist-get span :sc))
+ (spanToLine . ,(plist-get span :el))
+ (spanToColumn . ,(plist-get span :ec))))))))
+
+(defun stack-mode-get-use-sites (module file span)
+ "Get all uses of an identifier."
+ )
+
+(defun stack-mode-get-completions (module string)
+ "Get all uses of an identifier."
+ )
+
+(defun stack-mode-loading-callback (_ reply)
+ "Callback for when loading modules."
+ (let ((tag (stack-tag reply)))
+ (cond
+ ((string= tag "ResponseUpdateSession")
+ (let* ((contents (stack-contents reply))
+ (tag (stack-tag contents)))
+ (cond
+ ((string= tag "UpdateStatusProgress")
+ (stack-mode-progress-callback _ reply)
+ :continue)
+ ((string= tag "UpdateStatusDone")
+ (stack-mode-enqueue-front
+ `((tag . "RequestGetSourceErrors")
+ (contents . []))
+ nil
+ 'stack-mode-get-source-errors-callback)
+ :done)
+ (t :continue))))
+ (t
+ :continue))))
+
+(defun stack-mode-progress-callback (_ reply)
+ "Callback for status reports. Utilized in multiple places."
+ (let* ((contents (stack-contents reply))
+ (update (stack-contents contents))
+ (step (stack-lookup 'progressStep update))
+ (total (stack-lookup 'progressNumSteps update))
+ (msg (stack-lookup 'progressParsedMsg update)))
+ (message "[%s/%s] %s"
+ (propertize (number-to-string step) 'face 'compilation-line-number)
+ (propertize (number-to-string total) 'face 'compilation-line-number)
+ msg)))
+
+(defun stack-mode-get-source-errors-callback (_ reply)
+ "Handle the reply from getting source errors."
+ (let ((tag (stack-tag reply)))
+ (cond
+ ((string= tag "ResponseGetSourceErrors")
+ (let ((any-errors nil)
+ (warnings 0))
+ (cl-loop
+ for item in (mapcar #'identity (stack-contents reply))
+ do (let* ((kind (stack-lookup 'errorKind item))
+ (span (stack-contents (stack-lookup 'errorSpan item)))
+ (msg (stack-lookup 'errorMsg item))
+ (fp (stack-lookup 'spanFilePath span))
+ (sl (stack-lookup 'spanFromLine span))
+ (sc (stack-lookup 'spanFromColumn span))
+ (el (stack-lookup 'spanToLine span))
+ (ec (stack-lookup 'spanToColumn span)))
+ (cond ((string= kind "KindError")
+ (setq any-errors t))
+ ((string= kind "KindWarning")
+ (setq warnings (1+ warnings))))
+ (when
+ stack-mode-print-error-messages
+ (message "%s"
+ (propertize
+ (format "%s:(%d,%d)-(%d,%d): \n%s"
+ fp sl sc el ec msg)
+ 'face
+ (cond
+ ((string= kind "KindWarning")
+ 'compilation-warning)
+ ((string= kind "KindError")
+ 'compilation-error)))))))
+ (unless any-errors
+ (if (= 0 warnings)
+ (message "OK.")
+ (message (propertize "OK (%d warning%s)." 'face 'compilation-warning)
+ warnings
+ (if (= 1 warnings) "" "s")))))
+ :done)
+ (t :done))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Span functions
+
+(defun stack-mode-points ()
+ "Get the current points; either a selected region or an
+identifier's points."
+ (if (region-active-p)
+ (cons (region-beginning) (region-end))
+ (let ((ident (haskell-ident-pos-at-point)))
+ (cons (car ident)
+ (cdr ident)))))
+
+(defun stack-mode-span-from-points (beg end)
+ "Get the span representation for the span from BEG to END."
+ (save-excursion
+ (list :sl (progn (goto-char beg)
+ (line-number-at-pos))
+ :sc (1+ (current-column))
+ :el (progn (goto-char end)
+ (line-number-at-pos))
+ :ec (1+ (current-column)))))
+
+(defun stack-mode-span ()
+ "Get the span from the haskell points."
+ (let ((points (or (haskell-spanable-pos-at-point)
+ (haskell-ident-pos-at-point)
+ (stack-mode-loose-ident-at-point))))
+ (if points
+ (stack-mode-span-from-points (car points) (cdr points))
+ (error "No identifier at point."))))
+
+(defun stack-mode-goto-span (span)
+ "Get buffer points from a span."
+ (with-current-buffer (stack-mode-buffer)
+ (find-file (stack-lookup 'spanFilePath span))
+ (goto-char (point-min))
+ (let ((beg (point)))
+ (goto-char (point-min))
+ (forward-line (1- (stack-lookup 'spanFromLine span)))
+ (goto-char (line-beginning-position))
+ (forward-char (1- (stack-lookup 'spanFromColumn span))))))
+
+(defun stack-mode-loose-ident-at-point ()
+ "Get the loose ident at point."
+ nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; JSON helpers
+
+(defun stack-mode-list->hashtable (xs)
+ "Convert a list to a hashtable."
+ (let ((h (make-hash-table)))
+ (cl-loop for (key . val)
+ in xs
+ do (puthash key val h))
+ h))
+
+(defun stack-lookup (key object)
+ "Get from a JSON object."
+ (cdr (assoc key (mapcar #'identity object))))
+
+(defun stack-contents (object)
+ "Get from a JSON object."
+ (stack-lookup 'contents object))
+
+(defun stack-tag (object)
+ "Get the tag of an object."
+ (stack-lookup 'tag object))
+
+(defun stack-lookup-contents (key object)
+ "Get from a JSON object."
+ (stack-contents (stack-lookup key object)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Flycheck integration
+
+(defun stack-mode-flycheck-start (checker flycheck-callback &optional buffer attempt-count)
+ "Run a compile on demand, triggered by Flycheck."
+ (when buffer (set-buffer buffer))
+ (let ((max-attempts 2))
+ (if (not (stack-mode-live-p))
+ (if (> (or attempt-count 0) max-attempts)
+ (stack-mode-log "Stack backend isn't ready for Flycheck use. Giving up (waited %d seconds)."
+ max-attempts)
+ (stack-mode-log "Stack backend isn't ready. Waiting (%d attempts) ..."
+ (or attempt-count 0))
+ (progn (stack-mode-log "Flycheck tried to use the Stack backend, but the Stack backend isn't started yet. Starting it ...")
+ (stack-mode-try-start)
+ (run-with-idle-timer 1 nil 'stack-mode-flycheck-start checker flycheck-callback
+ (current-buffer)
+ (1+ (or attempt-count 0)))))
+ (progn (stack-mode-log "Running Flycheck with Stack backend ...")
+ (write-region (point-min) (point-max) (buffer-file-name))
+ (clear-visited-file-modtime)
+ (let ((source-buffer (current-buffer))
+ (label (format "flycheck %s" (buffer-name (current-buffer)))))
+ (with-current-buffer (stack-mode-buffer)
+ (stack-mode-enqueue
+ `((tag . "RequestUpdateSession")
+ (contents . []))
+ (list :flycheck-callback flycheck-callback
+ :stack-buffer (current-buffer)
+ :source-buffer source-buffer
+ :label label)
+ 'stack-mode-flycheck-callback
+ label)))))))
+
+(defun stack-mode-flycheck-callback (state reply)
+ "Callback for the flycheck loading. Once done, it will report
+ errors/warnings to CALLBACK."
+ (let ((tag (stack-tag reply)))
+ (cond
+ ((string= tag "ResponseUpdateSession")
+ (let* ((contents (stack-contents reply))
+ (tag (stack-tag contents)))
+ (cond
+ ((string= tag "UpdateStatusProgress")
+ (stack-mode-progress-callback nil reply)
+ :continue)
+ ((string= tag "UpdateStatusDone")
+ (stack-mode-enqueue-front
+ `((tag . "RequestGetSourceErrors")
+ (contents . []))
+ state
+ 'stack-mode-flycheck-errors-callback
+ (plist-get state :label))
+ :done)
+ (t :continue))))
+ (t
+ :continue))))
+
+(defun stack-mode-flycheck-errors-callback (state reply)
+ "Collect error messages and pass them to FLYCHECK-CALLBACK."
+ (let ((tag (stack-tag reply)))
+ (cond
+ ((string= tag "ResponseGetSourceErrors")
+ (let ((messages (list)))
+ (cl-loop
+ for item in (mapcar #'identity (stack-contents reply))
+ do (let* ((kind (stack-lookup 'errorKind item))
+ (span (stack-contents (stack-lookup 'errorSpan item)))
+ (msg (stack-lookup 'errorMsg item))
+ (filename (stack-lookup 'spanFilePath span))
+ (sl (stack-lookup 'spanFromLine span))
+ (sc (stack-lookup 'spanFromColumn span))
+ (el (stack-lookup 'spanToLine span))
+ (ec (stack-lookup 'spanToColumn span)))
+ (let ((orig (current-buffer))
+ (buffer
+ (with-current-buffer (plist-get state :stack-buffer)
+ (let ((value (get-file-buffer filename)))
+ (if (listp value)
+ (car value)
+ value)))))
+ (if (not (null buffer))
+ (add-to-list
+ 'messages
+ (flycheck-error-new-at
+ sl sc
+ (cond
+ ((string= kind "KindWarning") 'warning)
+ ((string= kind "KindError") 'error)
+ (t (message "kind: %s" kind)'error))
+ msg
+ :checker 'stack-ide
+ :buffer buffer)
+ t))
+ (set-buffer orig))))
+ ;; Calling it asynchronously is necessary for flycheck to
+ ;; work properly. See
+ ;; <https://github.com/flycheck/flycheck/pull/524#issuecomment-64947118>
+ ;;
+ ;; Also, the `stack-mode-call-in-buffer' utility is also
+ ;; needed because the reply needs to be called in the same
+ ;; buffer.
+ (run-with-idle-timer 0
+ nil
+ 'stack-mode-call-in-buffer
+ (plist-get state :source-buffer)
+ (plist-get state :flycheck-callback)
+ 'finished
+ messages)
+ (message "Flycheck done."))
+ :done)
+ (t :done))))
+
+(defun stack-mode-call-in-buffer (buffer func &rest args)
+ "Utility function which calls FUNC in BUFFER with ARGS."
+ (with-current-buffer buffer
+ (apply func args)))
+
+(flycheck-define-generic-checker 'stack-ide
+ "A syntax and type checker for Haskell using Stack's IDE support."
+ :start 'stack-mode-flycheck-start
+ :modes '(haskell-mode))
+
+(provide 'stack-mode)