diff -r 12cf67bc486c -r ab9ebd922ccb elisp/stack-mode/stack-mode.el
--- a/elisp/stack-mode/stack-mode.el Fri Sep 18 17:39:07 2015 -0500
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,929 +0,0 @@
-;;; 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 .
-
-;;; 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-disable-checker 'haskell-ghc)
- (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
- ;;
- ;;
- ;; 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)
- :next-checkers '((warning . haskell-hlint)))
-
-(provide 'stack-mode)