diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-interactive-mode.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-interactive-mode.el | 1129 |
1 files changed, 0 insertions, 1129 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-interactive-mode.el b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-interactive-mode.el deleted file mode 100644 index c218c6c3facb..000000000000 --- a/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180913.348/haskell-interactive-mode.el +++ /dev/null @@ -1,1129 +0,0 @@ -;;; 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 |