1130 lines
46 KiB
EmacsLisp
1130 lines
46 KiB
EmacsLisp
|
;;; haskell-interactive-mode.el --- The interactive Haskell mode -*- lexical-binding: t -*-
|
||
|
|
|
||
|
|
;; Copyright © 2011-2012 Chris Done
|
||
|
|
;; 2016 Arthur Fayzrakhmanov
|
||
|
|
|
||
|
|
;; Author: Chris Done <chrisdone@gmail.com>
|
||
|
|
|
||
|
|
;; This file is not part of GNU Emacs.
|
||
|
|
|
||
|
|
;; 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 GNU Emacs; see the file COPYING. If not, write to
|
||
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||
|
|
;; Boston, MA 02110-1301, USA.
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;;; Todo:
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'haskell-mode)
|
||
|
|
(require 'haskell-compile)
|
||
|
|
(require 'haskell-process)
|
||
|
|
(require 'haskell-session)
|
||
|
|
(require 'haskell-font-lock)
|
||
|
|
(require 'haskell-presentation-mode)
|
||
|
|
(require 'haskell-utils)
|
||
|
|
(require 'haskell-string)
|
||
|
|
(require 'ansi-color)
|
||
|
|
(require 'cl-lib)
|
||
|
|
(require 'etags)
|
||
|
|
|
||
|
|
(defvar-local haskell-interactive-mode-history-index 0)
|
||
|
|
|
||
|
|
(defvar-local haskell-interactive-mode-history (list))
|
||
|
|
|
||
|
|
(defvar-local haskell-interactive-mode-old-prompt-start nil
|
||
|
|
"Mark used for the old beginning of the prompt.")
|
||
|
|
|
||
|
|
(defun haskell-interactive-prompt-regex ()
|
||
|
|
"Generate a regex for searching for any occurence of the prompt\
|
||
|
|
at the beginning of the line. This should prevent any
|
||
|
|
interference with prompts that look like haskell expressions."
|
||
|
|
(concat "^" (regexp-quote haskell-interactive-prompt)))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; Globals used internally
|
||
|
|
|
||
|
|
(declare-function haskell-interactive-kill "haskell")
|
||
|
|
|
||
|
|
(defvar haskell-interactive-mode-map
|
||
|
|
(let ((map (make-sparse-keymap)))
|
||
|
|
(define-key map (kbd "RET") 'haskell-interactive-mode-return)
|
||
|
|
(define-key map (kbd "SPC") 'haskell-interactive-mode-space)
|
||
|
|
(define-key map (kbd "C-j") 'haskell-interactive-mode-newline-indent)
|
||
|
|
(define-key map (kbd "C-a") 'haskell-interactive-mode-beginning)
|
||
|
|
(define-key map (kbd "<home>") 'haskell-interactive-mode-beginning)
|
||
|
|
(define-key map (kbd "C-c C-k") 'haskell-interactive-mode-clear)
|
||
|
|
(define-key map (kbd "C-c C-c") 'haskell-process-interrupt)
|
||
|
|
(define-key map (kbd "C-c C-f") 'next-error-follow-minor-mode)
|
||
|
|
(define-key map (kbd "C-c C-z") 'haskell-interactive-switch-back)
|
||
|
|
(define-key map (kbd "M-p") 'haskell-interactive-mode-history-previous)
|
||
|
|
(define-key map (kbd "M-n") 'haskell-interactive-mode-history-next)
|
||
|
|
(define-key map (kbd "C-c C-p") 'haskell-interactive-mode-prompt-previous)
|
||
|
|
(define-key map (kbd "C-c C-n") 'haskell-interactive-mode-prompt-next)
|
||
|
|
(define-key map (kbd "C-<up>") 'haskell-interactive-mode-history-previous)
|
||
|
|
(define-key map (kbd "C-<down>") 'haskell-interactive-mode-history-next)
|
||
|
|
(define-key map (kbd "TAB") 'haskell-interactive-mode-tab)
|
||
|
|
(define-key map (kbd "<C-S-backspace>") 'haskell-interactive-mode-kill-whole-line)
|
||
|
|
map)
|
||
|
|
"Keymap used in `haskell-interactive-mode'.")
|
||
|
|
|
||
|
|
(define-derived-mode haskell-interactive-mode fundamental-mode "Interactive-Haskell"
|
||
|
|
"Interactive mode for Haskell.
|
||
|
|
|
||
|
|
Key bindings:
|
||
|
|
\\{haskell-interactive-mode-map}"
|
||
|
|
:group 'haskell-interactive
|
||
|
|
:syntax-table haskell-mode-syntax-table
|
||
|
|
|
||
|
|
(setq haskell-interactive-mode-history (list))
|
||
|
|
(setq haskell-interactive-mode-history-index 0)
|
||
|
|
|
||
|
|
(setq next-error-function #'haskell-interactive-next-error-function)
|
||
|
|
(add-hook 'completion-at-point-functions
|
||
|
|
#'haskell-interactive-mode-completion-at-point-function nil t)
|
||
|
|
(add-hook 'kill-buffer-hook #'haskell-interactive-kill nil t)
|
||
|
|
(haskell-interactive-mode-prompt))
|
||
|
|
|
||
|
|
(defvar haskell-interactive-mode-prompt-start
|
||
|
|
nil
|
||
|
|
"Mark used for the beginning of the prompt.")
|
||
|
|
|
||
|
|
(defvar haskell-interactive-mode-result-end
|
||
|
|
nil
|
||
|
|
"Mark used to figure out where the end of the current result output is.
|
||
|
|
Used to distinguish betwen user input.")
|
||
|
|
|
||
|
|
(defvar-local haskell-interactive-previous-buffer nil
|
||
|
|
"Records the buffer to which `haskell-interactive-switch-back' should jump.
|
||
|
|
This is set by `haskell-interactive-switch', and should otherwise
|
||
|
|
be nil.")
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; Hooks
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; Mode
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; Faces
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defface haskell-interactive-face-prompt
|
||
|
|
'((t :inherit font-lock-function-name-face))
|
||
|
|
"Face for the prompt."
|
||
|
|
:group 'haskell-interactive)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defface haskell-interactive-face-prompt2
|
||
|
|
'((t :inherit font-lock-keyword-face))
|
||
|
|
"Face for the prompt2 in multi-line mode."
|
||
|
|
:group 'haskell-interactive)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defface haskell-interactive-face-compile-error
|
||
|
|
'((t :inherit compilation-error))
|
||
|
|
"Face for compile errors."
|
||
|
|
:group 'haskell-interactive)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defface haskell-interactive-face-compile-warning
|
||
|
|
'((t :inherit compilation-warning))
|
||
|
|
"Face for compiler warnings."
|
||
|
|
:group 'haskell-interactive)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defface haskell-interactive-face-result
|
||
|
|
'((t :inherit font-lock-string-face))
|
||
|
|
"Face for the result."
|
||
|
|
:group 'haskell-interactive)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defface haskell-interactive-face-garbage
|
||
|
|
'((t :inherit font-lock-string-face))
|
||
|
|
"Face for trailing garbage after a command has completed."
|
||
|
|
:group 'haskell-interactive)
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; Actions
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-newline-indent ()
|
||
|
|
"Make newline and indent."
|
||
|
|
(interactive)
|
||
|
|
(newline)
|
||
|
|
(indent-to (length haskell-interactive-prompt))
|
||
|
|
(indent-relative))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-kill-whole-line ()
|
||
|
|
"Kill the whole REPL line."
|
||
|
|
(interactive)
|
||
|
|
(kill-region haskell-interactive-mode-prompt-start
|
||
|
|
(line-end-position)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-switch-back ()
|
||
|
|
"Switch back to the buffer from which this interactive buffer was reached."
|
||
|
|
(interactive)
|
||
|
|
(if haskell-interactive-previous-buffer
|
||
|
|
(switch-to-buffer-other-window haskell-interactive-previous-buffer)
|
||
|
|
(message "No previous buffer.")))
|
||
|
|
|
||
|
|
(defun haskell-interactive-copy-to-prompt ()
|
||
|
|
"Copy the current line to the prompt, overwriting the current prompt."
|
||
|
|
(interactive)
|
||
|
|
(let ((l (buffer-substring-no-properties (line-beginning-position)
|
||
|
|
(line-end-position))))
|
||
|
|
;; If it looks like the prompt is at the start of the line, chop
|
||
|
|
;; it off.
|
||
|
|
(when (and (>= (length l) (length haskell-interactive-prompt))
|
||
|
|
(string= (substring l 0 (length haskell-interactive-prompt))
|
||
|
|
haskell-interactive-prompt))
|
||
|
|
(setq l (substring l (length haskell-interactive-prompt))))
|
||
|
|
|
||
|
|
(haskell-interactive-mode-set-prompt l)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-space (n)
|
||
|
|
"Handle the space key."
|
||
|
|
(interactive "p")
|
||
|
|
(if (and (bound-and-true-p god-local-mode)
|
||
|
|
(fboundp 'god-mode-self-insert))
|
||
|
|
(call-interactively 'god-mode-self-insert)
|
||
|
|
(if (haskell-interactive-at-compile-message)
|
||
|
|
(next-error-no-select 0)
|
||
|
|
(self-insert-command n))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-at-prompt (&optional end-line)
|
||
|
|
"If at prompt, return start position of user-input, otherwise return nil.
|
||
|
|
If END-LINE is non-nil, then return non-nil when the end of line
|
||
|
|
is at the prompt."
|
||
|
|
(if (>= (if end-line (line-end-position) (point))
|
||
|
|
haskell-interactive-mode-prompt-start)
|
||
|
|
haskell-interactive-mode-prompt-start
|
||
|
|
nil))
|
||
|
|
|
||
|
|
(define-derived-mode haskell-error-mode
|
||
|
|
special-mode "Error"
|
||
|
|
"Major mode for viewing Haskell compile errors.")
|
||
|
|
|
||
|
|
;; (define-key haskell-error-mode-map (kbd "q") 'quit-window)
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-handle-h ()
|
||
|
|
"Handle ^H in output."
|
||
|
|
(let ((bound (point-min))
|
||
|
|
(inhibit-read-only t))
|
||
|
|
(save-excursion
|
||
|
|
(while (search-backward "\b" bound t 1)
|
||
|
|
(save-excursion
|
||
|
|
(forward-char)
|
||
|
|
(let ((end (point)))
|
||
|
|
(if (search-backward-regexp "[^\b]" bound t 1)
|
||
|
|
(forward-char)
|
||
|
|
(goto-char (point-min)))
|
||
|
|
(let ((start (point)))
|
||
|
|
(delete-region (max (- (point) (- end start))
|
||
|
|
(point-min))
|
||
|
|
end))))))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-multi-line (expr)
|
||
|
|
"If a multi-line expression EXPR has been entered, then reformat it to be:
|
||
|
|
|
||
|
|
:{
|
||
|
|
do the
|
||
|
|
multi-liner
|
||
|
|
expr
|
||
|
|
:}"
|
||
|
|
(if (not (string-match-p "\n" expr))
|
||
|
|
expr
|
||
|
|
(let ((pre (format "^%s" (regexp-quote haskell-interactive-prompt)))
|
||
|
|
(lines (split-string expr "\n")))
|
||
|
|
(cl-loop for elt on (cdr lines) do
|
||
|
|
(setcar elt (replace-regexp-in-string pre "" (car elt))))
|
||
|
|
;; Temporarily set prompt2 to be empty to avoid unwanted output
|
||
|
|
(concat ":set prompt2 \"\"\n"
|
||
|
|
":{\n"
|
||
|
|
(mapconcat #'identity lines "\n")
|
||
|
|
"\n:}\n"
|
||
|
|
(format ":set prompt2 \"%s\"" haskell-interactive-prompt2)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-line-is-query (line)
|
||
|
|
"Is LINE actually a :t/:k/:i?"
|
||
|
|
(and (string-match "^:[itk] " line)
|
||
|
|
t))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-beginning ()
|
||
|
|
"Go to the start of the line."
|
||
|
|
(interactive)
|
||
|
|
(if (haskell-interactive-at-prompt)
|
||
|
|
(goto-char haskell-interactive-mode-prompt-start)
|
||
|
|
(move-beginning-of-line nil)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-input-partial ()
|
||
|
|
"Get the interactive mode input up to point."
|
||
|
|
(let ((input-start (haskell-interactive-at-prompt)))
|
||
|
|
(unless input-start
|
||
|
|
(error "not at prompt"))
|
||
|
|
(buffer-substring-no-properties input-start (point))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-input ()
|
||
|
|
"Get the interactive mode input."
|
||
|
|
(buffer-substring-no-properties
|
||
|
|
haskell-interactive-mode-prompt-start
|
||
|
|
(point-max)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-prompt (&optional session)
|
||
|
|
"Show a prompt at the end of the REPL buffer.
|
||
|
|
If SESSION is non-nil, use the REPL buffer associated with
|
||
|
|
SESSION, otherwise operate on the current buffer."
|
||
|
|
(with-current-buffer (if session
|
||
|
|
(haskell-session-interactive-buffer session)
|
||
|
|
(current-buffer))
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-max))
|
||
|
|
(let ((prompt (propertize haskell-interactive-prompt
|
||
|
|
'font-lock-face 'haskell-interactive-face-prompt
|
||
|
|
'prompt t
|
||
|
|
'read-only haskell-interactive-prompt-read-only
|
||
|
|
'rear-nonsticky t)))
|
||
|
|
;; At the time of writing, front-stickying the first char gives an error
|
||
|
|
;; Has unfortunate side-effect of being able to insert before the prompt
|
||
|
|
(insert (substring prompt 0 1)
|
||
|
|
(propertize (substring prompt 1)
|
||
|
|
'front-sticky t)))
|
||
|
|
(let ((marker (setq-local haskell-interactive-mode-prompt-start (make-marker))))
|
||
|
|
(set-marker marker (point))))
|
||
|
|
(when (haskell-interactive-at-prompt t)
|
||
|
|
(haskell-interactive-mode-scroll-to-bottom))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-eval-result (session text)
|
||
|
|
"Insert the result of an eval as plain text."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(let ((at-end (eobp))
|
||
|
|
(prop-text (propertize text
|
||
|
|
'font-lock-face 'haskell-interactive-face-result
|
||
|
|
'front-sticky t
|
||
|
|
'prompt t
|
||
|
|
'read-only haskell-interactive-mode-read-only
|
||
|
|
'rear-nonsticky t
|
||
|
|
'result t)))
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-max))
|
||
|
|
(when (string= text haskell-interactive-prompt2)
|
||
|
|
(setq prop-text
|
||
|
|
(propertize prop-text
|
||
|
|
'font-lock-face 'haskell-interactive-face-prompt2
|
||
|
|
'read-only haskell-interactive-prompt-read-only)))
|
||
|
|
(insert (ansi-color-apply prop-text))
|
||
|
|
(haskell-interactive-mode-handle-h)
|
||
|
|
(let ((marker (setq-local haskell-interactive-mode-result-end (make-marker))))
|
||
|
|
(set-marker marker (point))))
|
||
|
|
(when at-end
|
||
|
|
(haskell-interactive-mode-scroll-to-bottom)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-scroll-to-bottom ()
|
||
|
|
"Scroll to bottom."
|
||
|
|
(let ((w (get-buffer-window (current-buffer))))
|
||
|
|
(when w
|
||
|
|
(goto-char (point-max))
|
||
|
|
(set-window-point w (point)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-compile-error (session message)
|
||
|
|
"Echo an error."
|
||
|
|
(haskell-interactive-mode-compile-message
|
||
|
|
session message 'haskell-interactive-face-compile-error))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-compile-warning (session message)
|
||
|
|
"Warning message."
|
||
|
|
(haskell-interactive-mode-compile-message
|
||
|
|
session message 'haskell-interactive-face-compile-warning))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-compile-message (session message type)
|
||
|
|
"Echo a compiler warning."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(setq next-error-last-buffer (current-buffer))
|
||
|
|
(save-excursion
|
||
|
|
(haskell-interactive-mode-goto-end-point)
|
||
|
|
(let ((lines (string-match "^\\(.*\\)\n\\([[:unibyte:][:nonascii:]]+\\)" message)))
|
||
|
|
(if lines
|
||
|
|
(progn
|
||
|
|
(insert (propertize (concat (match-string 1 message) " …\n")
|
||
|
|
'expandable t
|
||
|
|
'font-lock-face type
|
||
|
|
'front-sticky t
|
||
|
|
'read-only haskell-interactive-mode-read-only
|
||
|
|
'rear-nonsticky t))
|
||
|
|
(insert (propertize (concat (match-string 2 message) "\n")
|
||
|
|
'collapsible t
|
||
|
|
'font-lock-face type
|
||
|
|
'front-sticky t
|
||
|
|
'invisible haskell-interactive-mode-hide-multi-line-errors
|
||
|
|
'message-length (length (match-string 2 message))
|
||
|
|
'read-only haskell-interactive-mode-read-only
|
||
|
|
'rear-nonsticky t)))
|
||
|
|
(insert (propertize (concat message "\n")
|
||
|
|
'font-lock-face type
|
||
|
|
'front-sticky t
|
||
|
|
'read-only haskell-interactive-mode-read-only
|
||
|
|
'rear-nonsticky t)))))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-insert (session message)
|
||
|
|
"Echo a read only piece of text before the prompt."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(save-excursion
|
||
|
|
(haskell-interactive-mode-goto-end-point)
|
||
|
|
(insert (propertize message
|
||
|
|
'front-sticky t
|
||
|
|
'read-only t
|
||
|
|
'rear-nonsticky t)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-goto-end-point ()
|
||
|
|
"Go to the 'end' of the buffer (before the prompt)."
|
||
|
|
(goto-char haskell-interactive-mode-prompt-start)
|
||
|
|
(goto-char (line-beginning-position)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-history-add (input)
|
||
|
|
"Add INPUT to the history."
|
||
|
|
(setq haskell-interactive-mode-history
|
||
|
|
(cons ""
|
||
|
|
(cons input
|
||
|
|
(cl-remove-if (lambda (i) (or (string= i input) (string= i "")))
|
||
|
|
haskell-interactive-mode-history))))
|
||
|
|
(setq haskell-interactive-mode-history-index
|
||
|
|
0))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-tab ()
|
||
|
|
"Do completion if at prompt or else try collapse/expand."
|
||
|
|
(interactive)
|
||
|
|
(cond
|
||
|
|
((haskell-interactive-at-prompt)
|
||
|
|
(completion-at-point))
|
||
|
|
((get-text-property (point) 'collapsible)
|
||
|
|
(let ((column (current-column)))
|
||
|
|
(search-backward-regexp "^[^ ]")
|
||
|
|
(haskell-interactive-mode-tab-expand)
|
||
|
|
(goto-char (+ column (line-beginning-position)))))
|
||
|
|
(t (haskell-interactive-mode-tab-expand))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-tab-expand ()
|
||
|
|
"Expand the rest of the message."
|
||
|
|
(cond ((get-text-property (point) 'expandable)
|
||
|
|
(let* ((pos (1+ (line-end-position)))
|
||
|
|
(visibility (get-text-property pos 'invisible))
|
||
|
|
(length (1+ (get-text-property pos 'message-length))))
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(put-text-property pos
|
||
|
|
(+ pos length)
|
||
|
|
'invisible
|
||
|
|
(not visibility)))))))
|
||
|
|
|
||
|
|
(defconst haskell-interactive-mode-error-regexp
|
||
|
|
"^\\(\\(?:[A-Z]:\\)?[^ \r\n:][^\r\n:]*\\):\\([0-9()-:]+\\):?")
|
||
|
|
|
||
|
|
(defun haskell-interactive-at-compile-message ()
|
||
|
|
"Am I on a compile message?"
|
||
|
|
(and (not (haskell-interactive-at-prompt))
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (line-beginning-position))
|
||
|
|
(looking-at haskell-interactive-mode-error-regexp))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-error-backward (&optional count)
|
||
|
|
"Go backward to the previous error."
|
||
|
|
(interactive)
|
||
|
|
(search-backward-regexp haskell-interactive-mode-error-regexp nil t count))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-error-forward (&optional count)
|
||
|
|
"Go forward to the next error, or return to the REPL."
|
||
|
|
(interactive)
|
||
|
|
(goto-char (line-end-position))
|
||
|
|
(if (search-forward-regexp haskell-interactive-mode-error-regexp nil t count)
|
||
|
|
(progn (goto-char (line-beginning-position))
|
||
|
|
t)
|
||
|
|
(progn (goto-char (point-max))
|
||
|
|
nil)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-delete-compile-messages (session &optional file-name)
|
||
|
|
"Delete compile messages in REPL buffer.
|
||
|
|
If FILE-NAME is non-nil, restrict to removing messages concerning
|
||
|
|
FILE-NAME only."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(when (search-forward-regexp "^Compilation failed.$" nil t 1)
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(delete-region (line-beginning-position)
|
||
|
|
(1+ (line-end-position))))
|
||
|
|
(goto-char (point-min)))
|
||
|
|
(while (when (re-search-forward haskell-interactive-mode-error-regexp nil t)
|
||
|
|
(let ((msg-file-name (match-string-no-properties 1))
|
||
|
|
(msg-startpos (line-beginning-position)))
|
||
|
|
;; skip over hanging continuation message lines
|
||
|
|
(while (progn (forward-line) (looking-at "^[ ]+")))
|
||
|
|
|
||
|
|
(when (or (not file-name) (string= file-name msg-file-name))
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(set-text-properties msg-startpos (point) nil))
|
||
|
|
(delete-region msg-startpos (point))
|
||
|
|
))
|
||
|
|
t)))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun haskell-interactive-mode-reset-error (session)
|
||
|
|
"Reset the error cursor position."
|
||
|
|
(interactive)
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(haskell-interactive-mode-goto-end-point)
|
||
|
|
(let ((mrk (point-marker)))
|
||
|
|
(haskell-session-set session 'next-error-locus nil)
|
||
|
|
(haskell-session-set session 'next-error-region (cons mrk (copy-marker mrk t))))
|
||
|
|
(goto-char (point-max))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; Misc
|
||
|
|
|
||
|
|
(declare-function haskell-interactive-switch "haskell")
|
||
|
|
(declare-function haskell-session "haskell")
|
||
|
|
|
||
|
|
(defun haskell-session-interactive-buffer (s)
|
||
|
|
"Get the session interactive buffer."
|
||
|
|
(let ((buffer (haskell-session-get s 'interactive-buffer)))
|
||
|
|
(if (and buffer (buffer-live-p buffer))
|
||
|
|
buffer
|
||
|
|
(let ((buffer-name (format "*%s*" (haskell-session-name s)))
|
||
|
|
(index 0))
|
||
|
|
(while (get-buffer buffer-name)
|
||
|
|
(setq buffer-name (format "*%s <%d>*" (haskell-session-name s) index))
|
||
|
|
(setq index (1+ index)))
|
||
|
|
(let ((buffer (get-buffer-create buffer-name)))
|
||
|
|
(haskell-session-set-interactive-buffer s buffer)
|
||
|
|
(with-current-buffer buffer
|
||
|
|
(haskell-interactive-mode)
|
||
|
|
(haskell-session-assign s))
|
||
|
|
(haskell-interactive-switch)
|
||
|
|
buffer)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-buffer ()
|
||
|
|
"Get the interactive buffer of the session."
|
||
|
|
(haskell-session-interactive-buffer (haskell-session)))
|
||
|
|
|
||
|
|
(defun haskell-process-cabal-live (state buffer)
|
||
|
|
"Do live updates for Cabal processes."
|
||
|
|
(haskell-interactive-mode-insert
|
||
|
|
(haskell-process-session (cadr state))
|
||
|
|
(replace-regexp-in-string
|
||
|
|
haskell-process-prompt-regex
|
||
|
|
""
|
||
|
|
(substring buffer (cl-cadddr state))))
|
||
|
|
(setf (cl-cdddr state) (list (length buffer)))
|
||
|
|
nil)
|
||
|
|
|
||
|
|
(defun haskell-process-parse-error (string)
|
||
|
|
"Parse the line number from the error string STRING."
|
||
|
|
(let ((span nil))
|
||
|
|
(cl-loop for regex
|
||
|
|
in haskell-compilation-error-regexp-alist
|
||
|
|
do (when (string-match (car regex) string)
|
||
|
|
(setq span
|
||
|
|
(list :file (match-string 1 string)
|
||
|
|
:line (string-to-number (match-string 2 string))
|
||
|
|
:col (string-to-number (match-string 4 string))
|
||
|
|
:line2 (when (match-string 3 string)
|
||
|
|
(string-to-number (match-string 3 string)))
|
||
|
|
:col2 (when (match-string 5 string)
|
||
|
|
(string-to-number (match-string 5 string)))))))
|
||
|
|
span))
|
||
|
|
|
||
|
|
(defun haskell-process-suggest-add-package (session msg)
|
||
|
|
"Add the (matched) module to your cabal file.
|
||
|
|
Cabal file is selected using SESSION's name, module matching is done in MSG."
|
||
|
|
(let* ((suggested-package (match-string 1 msg))
|
||
|
|
(package-name (replace-regexp-in-string "-[^-]+$" "" suggested-package))
|
||
|
|
(version (progn (string-match "\\([^-]+\\)$" suggested-package)
|
||
|
|
(match-string 1 suggested-package)))
|
||
|
|
(cabal-file (concat (haskell-session-name session)
|
||
|
|
".cabal")))
|
||
|
|
(haskell-mode-toggle-interactive-prompt-state)
|
||
|
|
(unwind-protect
|
||
|
|
(when (y-or-n-p
|
||
|
|
(format "Add `%s' to %s?"
|
||
|
|
package-name
|
||
|
|
cabal-file))
|
||
|
|
(haskell-cabal-add-dependency package-name version nil t)
|
||
|
|
(when (y-or-n-p (format "Enable -package %s in the GHCi session?" package-name))
|
||
|
|
(haskell-process-queue-without-filters
|
||
|
|
(haskell-session-process session)
|
||
|
|
(format ":set -package %s" package-name))))
|
||
|
|
(haskell-mode-toggle-interactive-prompt-state t))))
|
||
|
|
|
||
|
|
(defun haskell-process-suggest-remove-import (session file import line)
|
||
|
|
"Suggest removing or commenting out import statement.
|
||
|
|
Asks user to handle redundant import statement using interactive
|
||
|
|
SESSION in specified FILE to remove IMPORT on given LINE."
|
||
|
|
(let ((first t))
|
||
|
|
(haskell-mode-toggle-interactive-prompt-state)
|
||
|
|
(unwind-protect
|
||
|
|
(cl-case (read-event
|
||
|
|
(propertize (format "%sThe import line `%s' is redundant. Remove? (y, n, c: comment out) "
|
||
|
|
(if (not first)
|
||
|
|
"Please answer n, y or c: "
|
||
|
|
"")
|
||
|
|
import)
|
||
|
|
'face
|
||
|
|
'minibuffer-prompt))
|
||
|
|
(?y
|
||
|
|
(haskell-process-find-file session file)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(forward-line (1- line))
|
||
|
|
(goto-char (line-beginning-position))
|
||
|
|
(delete-region (line-beginning-position)
|
||
|
|
(line-end-position))))
|
||
|
|
(?n
|
||
|
|
(message "Ignoring redundant import %s" import))
|
||
|
|
(?c
|
||
|
|
(haskell-process-find-file session file)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(forward-line (1- line))
|
||
|
|
(goto-char (line-beginning-position))
|
||
|
|
(insert "-- "))))
|
||
|
|
;; unwind
|
||
|
|
(haskell-mode-toggle-interactive-prompt-state t))))
|
||
|
|
|
||
|
|
(defun haskell-process-find-file (session file)
|
||
|
|
"Find the given file in the project."
|
||
|
|
(find-file (cond ((file-exists-p (concat (haskell-session-current-dir session) "/" file))
|
||
|
|
(concat (haskell-session-current-dir session) "/" file))
|
||
|
|
((file-exists-p (concat (haskell-session-cabal-dir session) "/" file))
|
||
|
|
(concat (haskell-session-cabal-dir session) "/" file))
|
||
|
|
(t file))))
|
||
|
|
|
||
|
|
(defun haskell-process-suggest-pragma (session pragma extension file)
|
||
|
|
"Suggest to add something to the top of the file.
|
||
|
|
SESSION is used to search given file. Adds PRAGMA and EXTENSION
|
||
|
|
wrapped in compiler directive at the top of FILE."
|
||
|
|
(let ((string (format "{-# %s %s #-}" pragma extension)))
|
||
|
|
(haskell-mode-toggle-interactive-prompt-state)
|
||
|
|
(unwind-protect
|
||
|
|
(when (y-or-n-p (format "Add %s to the top of the file? " string))
|
||
|
|
(haskell-process-find-file session file)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(insert (concat string "\n"))))
|
||
|
|
(haskell-mode-toggle-interactive-prompt-state t))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-insert-error (response)
|
||
|
|
"Insert an error message."
|
||
|
|
(insert "\n"
|
||
|
|
(haskell-fontify-as-mode
|
||
|
|
response
|
||
|
|
'haskell-mode))
|
||
|
|
(haskell-interactive-mode-prompt))
|
||
|
|
|
||
|
|
(defun haskell-interactive-popup-error (response)
|
||
|
|
"Popup an error."
|
||
|
|
(if haskell-interactive-popup-errors
|
||
|
|
(let ((buf (get-buffer-create "*HS-Error*")))
|
||
|
|
(pop-to-buffer buf nil t)
|
||
|
|
(with-current-buffer buf
|
||
|
|
|
||
|
|
(haskell-error-mode)
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(erase-buffer)
|
||
|
|
(insert (propertize response
|
||
|
|
'font-lock-face
|
||
|
|
'haskell-interactive-face-compile-error))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(delete-blank-lines)
|
||
|
|
(insert (propertize "-- Hit `q' to close this window.\n\n"
|
||
|
|
'font-lock-face 'font-lock-comment-face))
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-max))
|
||
|
|
(insert (propertize "\n-- To disable popups, customize `haskell-interactive-popup-errors'.\n\n"
|
||
|
|
'font-lock-face 'font-lock-comment-face))))))
|
||
|
|
(haskell-interactive-mode-insert-error response)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-next-error-function (&optional n reset)
|
||
|
|
"See `next-error-function' for more information."
|
||
|
|
|
||
|
|
(let* ((session (haskell-interactive-session))
|
||
|
|
(next-error-region (haskell-session-get session 'next-error-region))
|
||
|
|
(next-error-locus (haskell-session-get session 'next-error-locus))
|
||
|
|
(reset-locus nil))
|
||
|
|
|
||
|
|
(when (and next-error-region (or reset (and (/= n 0) (not next-error-locus))))
|
||
|
|
(goto-char (car next-error-region))
|
||
|
|
(unless (looking-at haskell-interactive-mode-error-regexp)
|
||
|
|
(haskell-interactive-mode-error-forward))
|
||
|
|
|
||
|
|
(setq reset-locus t)
|
||
|
|
(unless (looking-at haskell-interactive-mode-error-regexp)
|
||
|
|
(error "no errors found")))
|
||
|
|
|
||
|
|
;; move point if needed
|
||
|
|
(cond
|
||
|
|
(reset-locus nil)
|
||
|
|
((> n 0) (unless (haskell-interactive-mode-error-forward n)
|
||
|
|
(error "no more errors")))
|
||
|
|
|
||
|
|
((< n 0) (unless (haskell-interactive-mode-error-backward (- n))
|
||
|
|
(error "no more errors"))))
|
||
|
|
|
||
|
|
(let ((orig-line (buffer-substring-no-properties (line-beginning-position) (line-end-position))))
|
||
|
|
|
||
|
|
(when (string-match haskell-interactive-mode-error-regexp orig-line)
|
||
|
|
(let* ((msgmrk (set-marker (make-marker) (line-beginning-position)))
|
||
|
|
(location (haskell-process-parse-error orig-line))
|
||
|
|
(file (plist-get location :file))
|
||
|
|
(line (plist-get location :line))
|
||
|
|
(col1 (plist-get location :col))
|
||
|
|
(col2 (plist-get location :col2))
|
||
|
|
|
||
|
|
(cabal-relative-file (expand-file-name file (haskell-session-cabal-dir session)))
|
||
|
|
(src-relative-file (expand-file-name file (haskell-session-current-dir session)))
|
||
|
|
|
||
|
|
(real-file (cond ((file-exists-p cabal-relative-file) cabal-relative-file)
|
||
|
|
((file-exists-p src-relative-file) src-relative-file))))
|
||
|
|
|
||
|
|
(haskell-session-set session 'next-error-locus msgmrk)
|
||
|
|
|
||
|
|
(if real-file
|
||
|
|
(let ((m1 (make-marker))
|
||
|
|
(m2 (make-marker)))
|
||
|
|
(with-current-buffer (find-file-noselect real-file)
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(forward-line (1- line))
|
||
|
|
(set-marker m1 (+ col1 (point) -1))
|
||
|
|
|
||
|
|
(when col2
|
||
|
|
(set-marker m2 (- (point) col2)))))
|
||
|
|
;; ...finally select&hilight error locus
|
||
|
|
(compilation-goto-locus msgmrk m1 (and (marker-position m2) m2)))
|
||
|
|
(error "don't know where to find %S" file)))))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-session ()
|
||
|
|
"Get the `haskell-session', throw an error if it's not available."
|
||
|
|
(or (haskell-session-maybe)
|
||
|
|
(haskell-session-assign
|
||
|
|
(or (haskell-session-from-buffer)
|
||
|
|
(haskell-session-choose)
|
||
|
|
(error "No session associated with this buffer. Try M-x haskell-session-change or report this as a bug.")))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-process ()
|
||
|
|
"Get the Haskell session."
|
||
|
|
(or (haskell-session-process (haskell-interactive-session))
|
||
|
|
(error "No Haskell session/process associated with this
|
||
|
|
buffer. Maybe run M-x haskell-process-restart?")))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-do-presentation (expr)
|
||
|
|
"Present the given expression EXPR.
|
||
|
|
Requires the `present' package to be installed.
|
||
|
|
Will automatically import it qualified as Present."
|
||
|
|
(let ((p (haskell-interactive-process)))
|
||
|
|
;; If Present.code isn't available, we probably need to run the
|
||
|
|
;; setup.
|
||
|
|
(unless (string-match "^Present" (haskell-process-queue-sync-request p ":t Present.encode"))
|
||
|
|
(haskell-interactive-mode-setup-presentation p))
|
||
|
|
;; Happily, let statements don't affect the `it' binding in any
|
||
|
|
;; way, so we can fake it, no pun intended.
|
||
|
|
(let ((error (haskell-process-queue-sync-request
|
||
|
|
p (concat "let it = Present.asData (" expr ")"))))
|
||
|
|
(if (not (string= "" error))
|
||
|
|
(haskell-interactive-mode-eval-result (haskell-interactive-session) (concat error "\n"))
|
||
|
|
(let ((hash (haskell-interactive-mode-presentation-hash)))
|
||
|
|
(haskell-process-queue-sync-request
|
||
|
|
p (format "let %s = Present.asData (%s)" hash expr))
|
||
|
|
(let* ((presentation (haskell-interactive-mode-present-id
|
||
|
|
hash
|
||
|
|
(list 0))))
|
||
|
|
(insert "\n")
|
||
|
|
(haskell-interactive-mode-insert-presentation hash presentation)
|
||
|
|
(haskell-interactive-mode-eval-result (haskell-interactive-session) "\n"))))
|
||
|
|
(haskell-interactive-mode-prompt (haskell-interactive-session)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-present-id (hash id)
|
||
|
|
"Generate a presentation for the current expression at ID."
|
||
|
|
;; See below for commentary of this statement.
|
||
|
|
(let ((p (haskell-interactive-process)))
|
||
|
|
(haskell-process-queue-without-filters
|
||
|
|
p "let _it = it")
|
||
|
|
(let* ((text (haskell-process-queue-sync-request
|
||
|
|
p
|
||
|
|
(format "Present.putStr (Present.encode (Present.fromJust (Present.present (Present.fromJust (Present.fromList [%s])) %s)))"
|
||
|
|
(mapconcat 'identity (mapcar 'number-to-string id) ",")
|
||
|
|
hash)))
|
||
|
|
(reply
|
||
|
|
(if (string-match "^*** " text)
|
||
|
|
'((rep nil))
|
||
|
|
(read text))))
|
||
|
|
;; Not necessary, but nice to restore it to the expression that
|
||
|
|
;; the user actually typed in.
|
||
|
|
(haskell-process-queue-without-filters
|
||
|
|
p "let it = _it")
|
||
|
|
reply)))
|
||
|
|
|
||
|
|
(defun haskell-presentation-present-slot (btn)
|
||
|
|
"The callback to evaluate the slot and present it in place of the button BTN."
|
||
|
|
(let ((id (button-get btn 'presentation-id))
|
||
|
|
(hash (button-get btn 'hash))
|
||
|
|
(parent-rep (button-get btn 'parent-rep))
|
||
|
|
(continuation (button-get btn 'continuation)))
|
||
|
|
(let ((point (point)))
|
||
|
|
(button-put btn 'invisible t)
|
||
|
|
(delete-region (button-start btn) (button-end btn))
|
||
|
|
(haskell-interactive-mode-insert-presentation
|
||
|
|
hash
|
||
|
|
(haskell-interactive-mode-present-id hash id)
|
||
|
|
parent-rep
|
||
|
|
continuation)
|
||
|
|
(when (> (point) point)
|
||
|
|
(goto-char (1+ point))))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-presentation-slot (hash slot parent-rep &optional continuation)
|
||
|
|
"Make a slot at point, pointing to ID."
|
||
|
|
(let ((type (car slot))
|
||
|
|
(id (cadr slot)))
|
||
|
|
(if (member (intern type) '(Integer Char Int Float Double))
|
||
|
|
(haskell-interactive-mode-insert-presentation
|
||
|
|
hash
|
||
|
|
(haskell-interactive-mode-present-id hash id)
|
||
|
|
parent-rep
|
||
|
|
continuation)
|
||
|
|
(haskell-interactive-mode-presentation-slot-button slot parent-rep continuation hash))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-presentation-slot-button (slot parent-rep continuation hash)
|
||
|
|
(let ((start (point))
|
||
|
|
(type (car slot))
|
||
|
|
(id (cadr slot)))
|
||
|
|
(insert (propertize type 'font-lock-face '(:height 0.8 :underline t :inherit font-lock-comment-face)))
|
||
|
|
(let ((button (make-text-button start (point)
|
||
|
|
:type 'haskell-presentation-slot-button)))
|
||
|
|
(button-put button 'hide-on-click t)
|
||
|
|
(button-put button 'presentation-id id)
|
||
|
|
(button-put button 'parent-rep parent-rep)
|
||
|
|
(button-put button 'continuation continuation)
|
||
|
|
(button-put button 'hash hash))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-insert-presentation (hash presentation &optional parent-rep continuation)
|
||
|
|
"Insert the presentation, hooking up buttons for each slot."
|
||
|
|
(let* ((rep (cadr (assoc 'rep presentation)))
|
||
|
|
(text (cadr (assoc 'text presentation)))
|
||
|
|
(slots (cadr (assoc 'slots presentation)))
|
||
|
|
(nullary (null slots)))
|
||
|
|
(cond
|
||
|
|
((string= "integer" rep)
|
||
|
|
(insert (propertize text 'font-lock-face 'font-lock-constant)))
|
||
|
|
((string= "floating" rep)
|
||
|
|
(insert (propertize text 'font-lock-face 'font-lock-constant)))
|
||
|
|
((string= "char" rep)
|
||
|
|
(insert (propertize
|
||
|
|
(if (string= "string" parent-rep)
|
||
|
|
(replace-regexp-in-string "^'\\(.+\\)'$" "\\1" text)
|
||
|
|
text)
|
||
|
|
'font-lock-face 'font-lock-string-face)))
|
||
|
|
((string= "tuple" rep)
|
||
|
|
(insert "(")
|
||
|
|
(let ((first t))
|
||
|
|
(cl-loop for slot in slots
|
||
|
|
do (unless first (insert ","))
|
||
|
|
do (haskell-interactive-mode-presentation-slot hash slot rep)
|
||
|
|
do (setq first nil)))
|
||
|
|
(insert ")"))
|
||
|
|
((string= "list" rep)
|
||
|
|
(if (null slots)
|
||
|
|
(if continuation
|
||
|
|
(progn (delete-char -1)
|
||
|
|
(delete-indentation))
|
||
|
|
(insert "[]"))
|
||
|
|
(let ((i 0))
|
||
|
|
(unless continuation
|
||
|
|
(insert "["))
|
||
|
|
(let ((start-column (current-column)))
|
||
|
|
(cl-loop for slot in slots
|
||
|
|
do (haskell-interactive-mode-presentation-slot
|
||
|
|
hash
|
||
|
|
slot
|
||
|
|
rep
|
||
|
|
(= i (1- (length slots))))
|
||
|
|
do (when (not (= i (1- (length slots))))
|
||
|
|
(insert "\n")
|
||
|
|
(indent-to (1- start-column))
|
||
|
|
(insert ","))
|
||
|
|
do (setq i (1+ i))))
|
||
|
|
(unless continuation
|
||
|
|
(insert "]")))))
|
||
|
|
((string= "string" rep)
|
||
|
|
(unless (string= "string" parent-rep)
|
||
|
|
(insert (propertize "\"" 'font-lock-face 'font-lock-string-face)))
|
||
|
|
(cl-loop for slot in slots
|
||
|
|
do (haskell-interactive-mode-presentation-slot hash slot rep))
|
||
|
|
(unless (string= "string" parent-rep)
|
||
|
|
(insert (propertize "\"" 'font-lock-face 'font-lock-string-face))))
|
||
|
|
((string= "alg" rep)
|
||
|
|
(when (and parent-rep
|
||
|
|
(not nullary)
|
||
|
|
(not (string= "list" parent-rep)))
|
||
|
|
(insert "("))
|
||
|
|
(let ((start-column (current-column)))
|
||
|
|
(insert (propertize text 'font-lock-face 'font-lock-type-face))
|
||
|
|
(cl-loop for slot in slots
|
||
|
|
do (insert "\n")
|
||
|
|
do (indent-to (+ 2 start-column))
|
||
|
|
do (haskell-interactive-mode-presentation-slot hash slot rep)))
|
||
|
|
(when (and parent-rep
|
||
|
|
(not nullary)
|
||
|
|
(not (string= "list" parent-rep)))
|
||
|
|
(insert ")")))
|
||
|
|
((string= "record" rep)
|
||
|
|
(let ((start-column (current-column)))
|
||
|
|
(insert (propertize text 'font-lock-face 'font-lock-type-face)
|
||
|
|
" { ")
|
||
|
|
(cl-loop for field in slots
|
||
|
|
do (insert "\n")
|
||
|
|
do (indent-to (+ 2 start-column))
|
||
|
|
do (let ((name (nth 0 field))
|
||
|
|
(slot (nth 1 field)))
|
||
|
|
(insert name " = ")
|
||
|
|
(haskell-interactive-mode-presentation-slot hash slot rep)))
|
||
|
|
(insert "\n")
|
||
|
|
(indent-to start-column)
|
||
|
|
(insert "}")))
|
||
|
|
((eq rep nil)
|
||
|
|
(insert (propertize "?" 'font-lock-face 'font-lock-warning)))
|
||
|
|
(t
|
||
|
|
(let ((err "Unable to present! This very likely means Emacs
|
||
|
|
is out of sync with the `present' package. You should make sure
|
||
|
|
they're both up to date, or report a bug."))
|
||
|
|
(insert err)
|
||
|
|
(error err))))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-setup-presentation (p)
|
||
|
|
"Setup the GHCi REPL for using presentations.
|
||
|
|
|
||
|
|
Using asynchronous queued commands as opposed to sync at this
|
||
|
|
stage, as sync would freeze up the UI a bit, and we actually
|
||
|
|
don't care when the thing completes as long as it's soonish."
|
||
|
|
;; Import dependencies under Present.* namespace
|
||
|
|
(haskell-process-queue-without-filters p "import qualified Data.Maybe as Present")
|
||
|
|
(haskell-process-queue-without-filters p "import qualified Data.ByteString.Lazy as Present")
|
||
|
|
(haskell-process-queue-without-filters p "import qualified Data.AttoLisp as Present")
|
||
|
|
(haskell-process-queue-without-filters p "import qualified Present.ID as Present")
|
||
|
|
(haskell-process-queue-without-filters p "import qualified Present as Present")
|
||
|
|
;; Make a dummy expression to avoid "Loading package" nonsense
|
||
|
|
(haskell-process-queue-without-filters
|
||
|
|
p "Present.present (Present.fromJust (Present.fromList [0])) ()"))
|
||
|
|
|
||
|
|
(defvar haskell-interactive-mode-presentation-hash 0
|
||
|
|
"Counter for the hash.")
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-presentation-hash ()
|
||
|
|
"Generate a presentation hash."
|
||
|
|
(format "_present_%s"
|
||
|
|
(setq haskell-interactive-mode-presentation-hash
|
||
|
|
(1+ haskell-interactive-mode-presentation-hash))))
|
||
|
|
|
||
|
|
(define-button-type 'haskell-presentation-slot-button
|
||
|
|
'action 'haskell-presentation-present-slot
|
||
|
|
'follow-link t
|
||
|
|
'help-echo "Click to expand…")
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-history-toggle (n)
|
||
|
|
"Toggle the history N items up or down."
|
||
|
|
(unless (null haskell-interactive-mode-history)
|
||
|
|
(setq haskell-interactive-mode-history-index
|
||
|
|
(mod (+ haskell-interactive-mode-history-index n)
|
||
|
|
(length haskell-interactive-mode-history)))
|
||
|
|
(unless (zerop haskell-interactive-mode-history-index)
|
||
|
|
(message "History item: %d" haskell-interactive-mode-history-index))
|
||
|
|
(haskell-interactive-mode-set-prompt
|
||
|
|
(nth haskell-interactive-mode-history-index
|
||
|
|
haskell-interactive-mode-history))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-set-prompt (p)
|
||
|
|
"Set (and overwrite) the current prompt."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer (haskell-interactive-session))
|
||
|
|
(goto-char haskell-interactive-mode-prompt-start)
|
||
|
|
(delete-region (point) (point-max))
|
||
|
|
(insert p)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-history-previous (arg)
|
||
|
|
"Cycle backwards through input history."
|
||
|
|
(interactive "*p")
|
||
|
|
(when (haskell-interactive-at-prompt)
|
||
|
|
(if (not (zerop arg))
|
||
|
|
(haskell-interactive-mode-history-toggle arg)
|
||
|
|
(setq haskell-interactive-mode-history-index 0)
|
||
|
|
(haskell-interactive-mode-history-toggle 1))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-history-next (arg)
|
||
|
|
"Cycle forward through input history."
|
||
|
|
(interactive "*p")
|
||
|
|
(when (haskell-interactive-at-prompt)
|
||
|
|
(if (not (zerop arg))
|
||
|
|
(haskell-interactive-mode-history-toggle (- arg))
|
||
|
|
(setq haskell-interactive-mode-history-index 0)
|
||
|
|
(haskell-interactive-mode-history-toggle -1))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-prompt-previous ()
|
||
|
|
"Jump to the previous prompt."
|
||
|
|
(interactive)
|
||
|
|
(let ((prev-prompt-pos
|
||
|
|
(save-excursion
|
||
|
|
(beginning-of-line) ;; otherwise prompt at current line matches
|
||
|
|
(and (search-backward-regexp (haskell-interactive-prompt-regex) nil t)
|
||
|
|
(match-end 0)))))
|
||
|
|
(when prev-prompt-pos (goto-char prev-prompt-pos))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-prompt-next ()
|
||
|
|
"Jump to the next prompt."
|
||
|
|
(interactive)
|
||
|
|
(search-forward-regexp (haskell-interactive-prompt-regex) nil t))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-clear ()
|
||
|
|
"Clear the screen and put any current input into the history."
|
||
|
|
(interactive)
|
||
|
|
(let ((session (haskell-interactive-session)))
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(set-text-properties (point-min) (point-max) nil))
|
||
|
|
(delete-region (point-min) (point-max))
|
||
|
|
(remove-overlays)
|
||
|
|
(haskell-interactive-mode-prompt session)
|
||
|
|
(haskell-session-set session 'next-error-region nil)
|
||
|
|
(haskell-session-set session 'next-error-locus nil))
|
||
|
|
(with-current-buffer (get-buffer-create "*haskell-process-log*")
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(delete-region (point-min) (point-max)))
|
||
|
|
(remove-overlays))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-completion-at-point-function ()
|
||
|
|
"Offer completions for partial expression between prompt and point.
|
||
|
|
This completion function is used in interactive REPL buffer itself."
|
||
|
|
(when (haskell-interactive-at-prompt)
|
||
|
|
(let* ((process (haskell-interactive-process))
|
||
|
|
(inp (haskell-interactive-mode-input-partial))
|
||
|
|
(resp2 (haskell-process-get-repl-completions process inp))
|
||
|
|
(rlen (- (length inp) (length (car resp2))))
|
||
|
|
(coll (append (if (string-prefix-p inp "import") '("import"))
|
||
|
|
(if (string-prefix-p inp "let") '("let"))
|
||
|
|
(cdr resp2))))
|
||
|
|
(list (- (point) rlen) (point) coll))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-trigger-compile-error (state response)
|
||
|
|
"Look for an <interactive> compile error.
|
||
|
|
If there is one, pop that up in a buffer, similar to `debug-on-error'."
|
||
|
|
(when (and haskell-interactive-types-for-show-ambiguous
|
||
|
|
(string-match "^\n<interactive>:[-0-9]+:[-0-9]+:" response)
|
||
|
|
(not (string-match "^\n<interactive>:[-0-9]+:[-0-9]+:[\n ]+[Ww]arning:" response)))
|
||
|
|
(let ((inhibit-read-only t))
|
||
|
|
(delete-region haskell-interactive-mode-prompt-start (point))
|
||
|
|
(set-marker haskell-interactive-mode-prompt-start
|
||
|
|
haskell-interactive-mode-old-prompt-start)
|
||
|
|
(goto-char (point-max)))
|
||
|
|
(cond
|
||
|
|
((and (not (haskell-interactive-mode-line-is-query (elt state 2)))
|
||
|
|
(or (string-match "No instance for (?Show[ \n]" response)
|
||
|
|
(string-match "Ambiguous type variable " response)))
|
||
|
|
(haskell-process-reset (haskell-interactive-process))
|
||
|
|
(let ((resp (haskell-process-queue-sync-request
|
||
|
|
(haskell-interactive-process)
|
||
|
|
(concat ":t "
|
||
|
|
(buffer-substring-no-properties
|
||
|
|
haskell-interactive-mode-prompt-start
|
||
|
|
(point-max))))))
|
||
|
|
(cond
|
||
|
|
((not (string-match "<interactive>:" resp))
|
||
|
|
(haskell-interactive-mode-insert-error resp))
|
||
|
|
(t (haskell-interactive-popup-error response)))))
|
||
|
|
(t (haskell-interactive-popup-error response)
|
||
|
|
t))
|
||
|
|
t))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun haskell-interactive-mode-echo (session message &optional mode)
|
||
|
|
"Echo a read only piece of text before the prompt."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(save-excursion
|
||
|
|
(haskell-interactive-mode-goto-end-point)
|
||
|
|
(insert (if mode
|
||
|
|
(haskell-fontify-as-mode
|
||
|
|
(concat message "\n")
|
||
|
|
mode)
|
||
|
|
(propertize (concat message "\n")
|
||
|
|
'front-sticky t
|
||
|
|
'read-only t
|
||
|
|
'rear-nonsticky t))))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-splices-buffer (session)
|
||
|
|
"Get the splices buffer for the current SESSION."
|
||
|
|
(get-buffer-create (haskell-interactive-mode-splices-buffer-name session)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-splices-buffer-name (session)
|
||
|
|
(format "*%s:splices*" (haskell-session-name session)))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-compile-splice (session message)
|
||
|
|
"Echo a compiler splice."
|
||
|
|
(with-current-buffer (haskell-interactive-mode-splices-buffer session)
|
||
|
|
(unless (eq major-mode 'haskell-mode)
|
||
|
|
(haskell-mode))
|
||
|
|
(let* ((parts (split-string message "\n ======>\n"))
|
||
|
|
(file-and-decl-lines (split-string (nth 0 parts) "\n"))
|
||
|
|
(file (nth 0 file-and-decl-lines))
|
||
|
|
(decl (mapconcat #'identity (cdr file-and-decl-lines) "\n"))
|
||
|
|
(output (nth 1 parts)))
|
||
|
|
(insert "-- " file "\n")
|
||
|
|
(let ((start (point)))
|
||
|
|
(insert decl "\n")
|
||
|
|
(indent-rigidly start (point) -4))
|
||
|
|
(insert "-- =>\n")
|
||
|
|
(let ((start (point)))
|
||
|
|
(insert output "\n")
|
||
|
|
(indent-rigidly start (point) -4)))))
|
||
|
|
|
||
|
|
(defun haskell-interactive-mode-insert-garbage (session message)
|
||
|
|
"Echo a read only piece of text before the prompt."
|
||
|
|
(with-current-buffer (haskell-session-interactive-buffer session)
|
||
|
|
(save-excursion
|
||
|
|
(haskell-interactive-mode-goto-end-point)
|
||
|
|
(insert (propertize message
|
||
|
|
'front-sticky t
|
||
|
|
'font-lock-face 'haskell-interactive-face-garbage
|
||
|
|
'read-only t
|
||
|
|
'rear-nonsticky t)))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun haskell-process-show-repl-response (line)
|
||
|
|
"Send LINE to the GHCi process and echo the result in some fashion.
|
||
|
|
Result will be printed in the minibuffer or presented using
|
||
|
|
function `haskell-presentation-present', depending on variable
|
||
|
|
`haskell-process-use-presentation-mode'."
|
||
|
|
(let ((process (haskell-interactive-process)))
|
||
|
|
(haskell-process-queue-command
|
||
|
|
process
|
||
|
|
(make-haskell-command
|
||
|
|
:state (cons process line)
|
||
|
|
:go (lambda (state)
|
||
|
|
(haskell-process-send-string (car state) (cdr state)))
|
||
|
|
:complete (lambda (state response)
|
||
|
|
(if haskell-process-use-presentation-mode
|
||
|
|
(haskell-presentation-present
|
||
|
|
(haskell-process-session (car state))
|
||
|
|
response)
|
||
|
|
(haskell-mode-message-line response)))))))
|
||
|
|
|
||
|
|
(provide 'haskell-interactive-mode)
|
||
|
|
|
||
|
|
;;; haskell-interactive-mode.el ends here
|