--- /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)