316 lines
12 KiB
EmacsLisp
316 lines
12 KiB
EmacsLisp
;;; haskell-hugs.el --- simplistic interaction mode with a
|
||
|
||
;; Copyright 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
|
||
;; Copyright 1998, 1999 Guy Lapalme
|
||
|
||
;; Hugs interpreter for Haskell developped by
|
||
;; The University of Nottingham and Yale University, 1994-1997.
|
||
;; Web: http://www.haskell.org/hugs.
|
||
;; In standard Emacs terminology, this would be called
|
||
;; inferior-hugs-mode
|
||
|
||
;; Keywords: Hugs inferior mode, Hugs interaction mode
|
||
;; URL: http://cvs.haskell.org/cgi-bin/cvsweb.cgi/fptools/CONTRIB/haskell-modes/emacs/haskell-hugs.el?rev=HEAD
|
||
|
||
;; 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., 59 Temple Place - Suite 330,
|
||
;; Boston, MA 02111-1307, USA.
|
||
|
||
|
||
;;; Commentary:
|
||
|
||
;; Purpose:
|
||
;;
|
||
;; To send a Haskell buffer to another buffer running a Hugs interpreter
|
||
;; The functions are adapted from the Hugs Mode developed by
|
||
;; Chris Van Humbeeck <chris.vanhumbeeck@cs.kuleuven.ac.be>
|
||
;; which used to be available at:
|
||
;; http://www-i2.informatik.rwth-aachen.de/Forschung/FP/Haskell/hugs-mode.el
|
||
;;
|
||
;; Installation:
|
||
;;
|
||
;; To use with the Haskell mode of
|
||
;; Moss&Thorn <http://www.haskell.org/haskell-mode>
|
||
;; add this to .emacs:
|
||
;;
|
||
;; (add-hook 'haskell-mode-hook 'turn-on-haskell-hugs)
|
||
;;
|
||
;; Customisation:
|
||
;; The name of the hugs interpreter is in variable
|
||
;; haskell-hugs-program-name
|
||
;; Arguments can be sent to the Hugs interpreter when it is called
|
||
;; by setting the value of the variable
|
||
;; haskell-hugs-program-args
|
||
;; which by default contains '("+.") so that the progress of the
|
||
;; interpreter is visible without any "^H" in the *hugs* Emacs buffer.
|
||
;;
|
||
;; This value can be interactively by calling C-cC-s with an
|
||
;; argument.
|
||
;;
|
||
;; If the command does not seem to respond, see the
|
||
;; content of the `comint-prompt-regexp' variable
|
||
;; to check that it waits for the appropriate Hugs prompt
|
||
;; the current value is appropriate for Hugs 1.3 and 1.4
|
||
;;
|
||
;;
|
||
;; `haskell-hugs-hook' is invoked in the *hugs* once it is started.
|
||
;;
|
||
;;; All functions/variables start with
|
||
;;; `(turn-(on/off)-)haskell-hugs' or `haskell-hugs-'.
|
||
|
||
(defgroup haskell-hugs nil
|
||
"Major mode for interacting with an inferior Hugs session."
|
||
:group 'haskell
|
||
:prefix "haskell-hugs-")
|
||
|
||
(defun turn-on-haskell-hugs ()
|
||
"Turn on Haskell interaction mode with a Hugs interpreter running in an
|
||
another Emacs buffer named *hugs*.
|
||
Maps the followind commands in the haskell keymap.
|
||
\\[haskell-hugs-load-file]
|
||
to save the current buffer and load it by sending the :load command
|
||
to Hugs.
|
||
\\[haskell-hugs-reload-file]
|
||
to send the :reload command to Hugs without saving the buffer.
|
||
\\[haskell-hugs-show-hugs-buffer]
|
||
to show the Hugs buffer and go to it."
|
||
(local-set-key "\C-c\C-s" 'haskell-hugs-start-process)
|
||
(local-set-key "\C-c\C-l" 'haskell-hugs-load-file)
|
||
(local-set-key "\C-c\C-r" 'haskell-hugs-reload-file)
|
||
(local-set-key "\C-c\C-b" 'haskell-hugs-show-hugs-buffer))
|
||
|
||
(defun turn-off-haskell-hugs ()
|
||
"Turn off Haskell interaction mode with a Hugs interpreter within a buffer."
|
||
(local-unset-key "\C-c\C-s")
|
||
(local-unset-key "\C-c\C-l")
|
||
(local-unset-key "\C-c\C-r")
|
||
(local-unset-key "\C-c\C-b"))
|
||
|
||
(define-derived-mode haskell-hugs-mode comint-mode "Haskell Hugs"
|
||
;; called by haskell-hugs-start-process,
|
||
;; itself called by haskell-hugs-load-file
|
||
;; only when the file is loaded the first time
|
||
"Major mode for interacting with an inferior Hugs session.
|
||
|
||
The commands available from within a Haskell script are:
|
||
\\<haskell-mode-map>\\[haskell-hugs-load-file]
|
||
to save the current buffer and load it by sending the :load command
|
||
to Hugs.
|
||
\\[haskell-hugs-reload-file]
|
||
to send the :reload command to Hugs without saving the buffer.
|
||
\\[haskell-hugs-show-hugs-buffer]
|
||
to show the Hugs buffer and go to it.
|
||
|
||
\\<haskell-hugs-mode-map>
|
||
Commands:
|
||
Return at end of buffer sends line as input.
|
||
Return not at end copies rest of line to end and sends it.
|
||
\\[comint-kill-input] and \\[backward-kill-word] are kill commands,
|
||
imitating normal Unix input editing.
|
||
\\[comint-interrupt-subjob] interrupts the comint or its current
|
||
subjob if any.
|
||
\\[comint-stop-subjob] stops, likewise.
|
||
\\[comint-quit-subjob] sends quit signal."
|
||
)
|
||
|
||
;; Hugs-interface
|
||
|
||
(require 'comint)
|
||
(require 'shell)
|
||
|
||
(defvar haskell-hugs-process nil
|
||
"The active Hugs subprocess corresponding to current buffer.")
|
||
|
||
(defvar haskell-hugs-process-buffer nil
|
||
"*Buffer used for communication with Hugs subprocess for current buffer.")
|
||
|
||
(defcustom haskell-hugs-program-name "hugs"
|
||
"*The name of the command to start the Hugs interpreter."
|
||
:type 'string
|
||
:group 'haskell-hugs)
|
||
|
||
(defcustom haskell-hugs-program-args '("+.")
|
||
"*A list of string args to send to the hugs process."
|
||
:type '(repeat string)
|
||
:group 'haskell-hugs)
|
||
|
||
(defvar haskell-hugs-load-end nil
|
||
"Position of the end of the last load command.")
|
||
|
||
(defvar haskell-hugs-send-end nil
|
||
"Position of the end of the last send command.")
|
||
|
||
(defalias 'run-hugs 'haskell-hugs-start-process)
|
||
|
||
(defun haskell-hugs-start-process (arg)
|
||
"Start a Hugs process and invokes `haskell-hugs-hook' if not nil.
|
||
Prompts for a list of args if called with an argument."
|
||
(interactive "P")
|
||
(message "Starting `hugs-process' %s" haskell-hugs-program-name)
|
||
(if arg
|
||
(setq haskell-hugs-program-args
|
||
(read-minibuffer "List of args for Hugs:"
|
||
(prin1-to-string haskell-hugs-program-args))))
|
||
(setq haskell-hugs-process-buffer
|
||
(apply 'make-comint
|
||
"hugs" haskell-hugs-program-name nil
|
||
haskell-hugs-program-args))
|
||
(setq haskell-hugs-process
|
||
(get-buffer-process haskell-hugs-process-buffer))
|
||
;; Select Hugs buffer temporarily
|
||
(set-buffer haskell-hugs-process-buffer)
|
||
(haskell-hugs-mode)
|
||
(make-local-variable 'shell-cd-regexp)
|
||
(make-local-variable 'shell-dirtrackp)
|
||
(setq shell-cd-regexp ":cd")
|
||
(setq shell-dirtrackp t)
|
||
(add-hook 'comint-input-filter-functions 'shell-directory-tracker nil 'local)
|
||
; ? or module name in Hugs 1.4
|
||
(setq comint-prompt-regexp "^\? \\|^[[:upper:]][_[:alnum:]\.]*> ")
|
||
;; comint's history syntax conflicts with Hugs syntax, eg. !!
|
||
(setq comint-input-autoexpand nil)
|
||
(run-hooks 'haskell-hugs-hook)
|
||
(message "")
|
||
)
|
||
|
||
(defun haskell-hugs-wait-for-output ()
|
||
"Wait until output arrives and go to the last input."
|
||
(while (progn
|
||
(goto-char comint-last-input-end)
|
||
(and
|
||
(not (re-search-forward comint-prompt-regexp nil t))
|
||
(accept-process-output haskell-hugs-process)))))
|
||
|
||
(defun haskell-hugs-send (&rest string)
|
||
"Send `haskell-hugs-process' the arguments (one or more strings).
|
||
A newline is sent after the strings and they are inserted into the
|
||
current buffer after the last output."
|
||
;; Wait until output arrives and go to the last input.
|
||
(haskell-hugs-wait-for-output)
|
||
;; Position for this input.
|
||
(goto-char (point-max))
|
||
(apply 'insert string)
|
||
(comint-send-input)
|
||
(setq haskell-hugs-send-end (marker-position comint-last-input-end)))
|
||
|
||
(defun haskell-hugs-go (load-command cd)
|
||
"Save the current buffer and load its file into the Hugs process.
|
||
The first argument LOAD-COMMAND specifies how the file should be
|
||
loaded: as a new file (\":load \") or as a reload (\":reload \").
|
||
|
||
If the second argument CD is non-nil, change the Haskell-Hugs process to the
|
||
current buffer's directory before loading the file.
|
||
|
||
If the variable `haskell-hugs-command' is set then its value will be sent to
|
||
the Hugs process after the load command. This can be used for a
|
||
top-level expression to evaluate."
|
||
(hack-local-variables) ;; In case they've changed
|
||
(save-buffer)
|
||
(let ((file (if (string-equal load-command ":load ")
|
||
(concat "\"" buffer-file-name "\"")
|
||
""))
|
||
(dir (expand-file-name default-directory))
|
||
(cmd (and (boundp 'haskell-hugs-command)
|
||
haskell-hugs-command
|
||
(if (stringp haskell-hugs-command)
|
||
haskell-hugs-command
|
||
(symbol-name haskell-hugs-command)))))
|
||
(if (and haskell-hugs-process-buffer
|
||
(eq (process-status haskell-hugs-process) 'run))
|
||
;; Ensure the Hugs buffer is selected.
|
||
(set-buffer haskell-hugs-process-buffer)
|
||
;; Start Haskell-Hugs process.
|
||
(haskell-hugs-start-process nil))
|
||
|
||
(if cd (haskell-hugs-send (concat ":cd " dir)))
|
||
;; Wait until output arrives and go to the last input.
|
||
(haskell-hugs-wait-for-output)
|
||
(haskell-hugs-send load-command file)
|
||
;; Error message search starts from last load command.
|
||
(setq haskell-hugs-load-end (marker-position comint-last-input-end))
|
||
(if cmd (haskell-hugs-send cmd))
|
||
;; Wait until output arrives and go to the last input.
|
||
(haskell-hugs-wait-for-output)))
|
||
|
||
(defun haskell-hugs-load-file (cd)
|
||
"Save a hugs buffer file and load its file.
|
||
If CD (prefix argument if interactive) is non-nil, change the Hugs
|
||
process to the current buffer's directory before loading the file.
|
||
If there is an error, set the cursor at the error line otherwise show
|
||
the Hugs buffer."
|
||
(interactive "P")
|
||
(haskell-hugs-gen-load-file ":load " cd)
|
||
)
|
||
|
||
(defun haskell-hugs-reload-file (cd)
|
||
"Save a hugs buffer file and load its file.
|
||
If CD (prefix argument if interactive) is non-nil, change the Hugs
|
||
process to the current buffer's directory before loading the file.
|
||
If there is an error, set the cursor at the error line otherwise show
|
||
the Hugs buffer."
|
||
(interactive "P")
|
||
(haskell-hugs-gen-load-file ":reload " cd)
|
||
)
|
||
|
||
(defun haskell-hugs-gen-load-file (cmd cd)
|
||
"Save a hugs buffer file and load its file or reload depending on CMD.
|
||
If CD is non-nil, change the process to the current buffer's directory
|
||
before loading the file. If there is an error, set the cursor at the
|
||
error line otherwise show the Hugs buffer."
|
||
(save-excursion (haskell-hugs-go cmd cd))
|
||
;; Ensure the Hugs buffer is selected.
|
||
(set-buffer haskell-hugs-process-buffer)
|
||
;; Error message search starts from last load command.
|
||
(goto-char haskell-hugs-load-end)
|
||
(if (re-search-forward
|
||
"^ERROR \"\\([^ ]*\\)\"\\( (line \\([0-9]*\\))\\|\\)" nil t)
|
||
(let ((efile (buffer-substring (match-beginning 1)
|
||
(match-end 1)))
|
||
(eline (if (match-beginning 3)
|
||
(string-to-int (buffer-substring (match-beginning 3)
|
||
(match-end 3)))))
|
||
(emesg (buffer-substring (1+ (point))
|
||
(save-excursion (end-of-line) (point)))))
|
||
(pop-to-buffer haskell-hugs-process-buffer) ; show *hugs* buffer
|
||
(goto-char (point-max))
|
||
(recenter)
|
||
(message "Hugs error %s %s"
|
||
(file-name-nondirectory efile) emesg)
|
||
(if (file-exists-p efile)
|
||
(progn (find-file-other-window efile)
|
||
(if eline (goto-line eline))
|
||
(recenter)))
|
||
)
|
||
(pop-to-buffer haskell-hugs-process-buffer) ; show *hugs* buffer
|
||
(goto-char (point-max))
|
||
(message "There were no errors.")
|
||
(recenter 2) ; show only the end...
|
||
)
|
||
)
|
||
|
||
(defun haskell-hugs-show-hugs-buffer ()
|
||
"Goes to the Hugs buffer."
|
||
(interactive)
|
||
(if (or (not haskell-hugs-process-buffer)
|
||
(not (buffer-live-p haskell-hugs-process-buffer)))
|
||
(haskell-hugs-start-process nil))
|
||
(pop-to-buffer haskell-hugs-process-buffer)
|
||
)
|
||
|
||
(provide 'haskell-hugs)
|
||
|
||
;; arch-tag: c2a621e9-d743-4361-a459-983fbf1d4589
|
||
;;; haskell-hugs.el ends here
|