/vendor/haskell-mode/haskell-hugs.el

  1;;; haskell-hugs.el --- simplistic interaction mode with a
  2
  3;; Copyright 2004, 2005, 2006, 2007  Free Software Foundation, Inc.
  4;; Copyright 1998, 1999  Guy Lapalme
  5
  6;; Hugs interpreter for Haskell developped by 
  7;;    The University of Nottingham and Yale University, 1994-1997.
  8;;    Web: http://www.haskell.org/hugs.
  9;; In standard Emacs terminology, this would be called
 10;;    inferior-hugs-mode
 11
 12;; Keywords: Hugs inferior mode, Hugs interaction mode
 13;; URL: http://cvs.haskell.org/cgi-bin/cvsweb.cgi/fptools/CONTRIB/haskell-modes/emacs/haskell-hugs.el?rev=HEAD
 14
 15;; This file is not part of GNU Emacs.
 16
 17;; This file is free software; you can redistribute it and/or modify
 18;; it under the terms of the GNU General Public License as published by
 19;; the Free Software Foundation; either version 3, or (at your option)
 20;; any later version.
 21
 22;; This file is distributed in the hope that it will be useful,
 23;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 24;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 25;; GNU General Public License for more details.
 26
 27;; You should have received a copy of the GNU General Public License
 28;; along with GNU Emacs; see the file COPYING.  If not, write to the
 29;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 30;; Boston, MA 02111-1307, USA.
 31
 32
 33;;; Commentary:
 34
 35;; Purpose:
 36;;
 37;; To send a Haskell buffer to another buffer running a Hugs interpreter
 38;; The functions are adapted from  the Hugs Mode developed by
 39;;         Chris Van Humbeeck <chris.vanhumbeeck@cs.kuleuven.ac.be>
 40;; which used to be available at:
 41;; http://www-i2.informatik.rwth-aachen.de/Forschung/FP/Haskell/hugs-mode.el
 42;;
 43;; Installation:
 44;; 
 45;; To use with the Haskell mode of 
 46;;        Moss&Thorn <http://www.haskell.org/haskell-mode>
 47;; add this to .emacs:
 48;;
 49;;    (add-hook 'haskell-mode-hook 'turn-on-haskell-hugs)
 50;;
 51;; Customisation:
 52;;       The name of the hugs interpreter is in variable
 53;;          haskell-hugs-program-name
 54;;       Arguments can be sent to the Hugs interpreter when it is called
 55;;       by setting the value of the variable
 56;;          haskell-hugs-program-args
 57;;       which by default contains '("+.") so that the progress of the
 58;;       interpreter is visible without any "^H" in the *hugs* Emacs buffer.
 59;;
 60;;       This value can be interactively by calling C-cC-s with an
 61;;       argument. 
 62;;
 63;;       If the command does not seem to respond, see the
 64;;          content of the `comint-prompt-regexp' variable
 65;;          to check that it waits for the appropriate Hugs prompt
 66;;          the current value is appropriate for Hugs 1.3 and 1.4
 67;;
 68;;
 69;;    `haskell-hugs-hook' is invoked in the *hugs* once it is started.
 70;;    
 71;;; All functions/variables start with
 72;;; `(turn-(on/off)-)haskell-hugs' or `haskell-hugs-'.
 73
 74(defgroup haskell-hugs nil
 75  "Major mode for interacting with an inferior Hugs session."
 76  :group 'haskell
 77  :prefix "haskell-hugs-")
 78
 79(defun turn-on-haskell-hugs ()
 80  "Turn on Haskell interaction mode with a Hugs interpreter running in an
 81another Emacs buffer named *hugs*.
 82Maps the followind commands in the haskell keymap.
 83     \\[haskell-hugs-load-file]
 84       to save the current buffer and load it by sending the :load command
 85       to Hugs.
 86     \\[haskell-hugs-reload-file]
 87       to send the :reload command to Hugs without saving the buffer.
 88     \\[haskell-hugs-show-hugs-buffer]
 89       to show the Hugs buffer and go to it."
 90  (local-set-key "\C-c\C-s" 'haskell-hugs-start-process)
 91  (local-set-key "\C-c\C-l" 'haskell-hugs-load-file)
 92  (local-set-key "\C-c\C-r" 'haskell-hugs-reload-file)
 93  (local-set-key "\C-c\C-b" 'haskell-hugs-show-hugs-buffer))
 94
 95(defun turn-off-haskell-hugs ()
 96  "Turn off Haskell interaction mode with a Hugs interpreter within a buffer."
 97  (local-unset-key  "\C-c\C-s")
 98  (local-unset-key  "\C-c\C-l")
 99  (local-unset-key  "\C-c\C-r")
100  (local-unset-key  "\C-c\C-b"))
101
102(define-derived-mode haskell-hugs-mode comint-mode "Haskell Hugs"
103;; called by haskell-hugs-start-process,
104;; itself called by haskell-hugs-load-file
105;; only when the file is loaded the first time
106  "Major mode for interacting with an inferior Hugs session.
107
108The commands available from within a Haskell script are:
109     \\<haskell-mode-map>\\[haskell-hugs-load-file]
110       to save the current buffer and load it by sending the :load command
111       to Hugs.
112     \\[haskell-hugs-reload-file]
113       to send the :reload command to Hugs without saving the buffer.
114     \\[haskell-hugs-show-hugs-buffer]
115       to show the Hugs buffer and go to it.
116
117\\<haskell-hugs-mode-map>
118Commands:
119Return at end of buffer sends line as input.
120Return not at end copies rest of line to end and sends it.
121\\[comint-kill-input] and \\[backward-kill-word] are kill commands,
122imitating normal Unix input editing.
123\\[comint-interrupt-subjob] interrupts the comint or its current
124subjob if any.
125\\[comint-stop-subjob] stops, likewise.
126 \\[comint-quit-subjob] sends quit signal."
127  )
128
129;; Hugs-interface
130
131(require 'comint)
132(require 'shell)
133
134(defvar haskell-hugs-process nil
135  "The active Hugs subprocess corresponding to current buffer.")
136
137(defvar haskell-hugs-process-buffer nil
138  "*Buffer used for communication with Hugs subprocess for current buffer.")
139
140(defcustom haskell-hugs-program-name "hugs"
141  "*The name of the command to start the Hugs interpreter."
142  :type 'string
143  :group 'haskell-hugs)
144
145(defcustom haskell-hugs-program-args '("+.")
146  "*A list of string args to send to the hugs process."
147  :type '(repeat string)
148  :group 'haskell-hugs)
149
150(defvar haskell-hugs-load-end nil
151  "Position of the end of the last load command.")
152
153(defvar haskell-hugs-send-end nil
154  "Position of the end of the last send command.")
155
156(defalias 'run-hugs 'haskell-hugs-start-process)
157
158(defun haskell-hugs-start-process (arg)
159  "Start a Hugs process and invokes `haskell-hugs-hook' if not nil.
160Prompts for a list of args if called with an argument."
161  (interactive "P")
162  (message "Starting `hugs-process' %s" haskell-hugs-program-name)
163  (if arg
164      (setq haskell-hugs-program-args
165            (read-minibuffer "List of args for Hugs:"
166                             (prin1-to-string haskell-hugs-program-args))))
167  (setq haskell-hugs-process-buffer
168        (apply 'make-comint
169               "hugs" haskell-hugs-program-name nil
170               haskell-hugs-program-args))
171  (setq haskell-hugs-process
172        (get-buffer-process haskell-hugs-process-buffer))
173  ;; Select Hugs buffer temporarily
174  (set-buffer haskell-hugs-process-buffer)
175  (haskell-hugs-mode)
176  (make-local-variable 'shell-cd-regexp)
177  (make-local-variable 'shell-dirtrackp)
178  (setq shell-cd-regexp         ":cd")
179  (setq shell-dirtrackp         t)
180  (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil 'local)
181                                ; ? or  module name in Hugs 1.4
182  (setq comint-prompt-regexp "^\? \\|^[[:upper:]][_[:alnum:]\.]*> ")
183    ;; comint's history syntax conflicts with Hugs syntax, eg. !!
184  (setq comint-input-autoexpand nil)
185  (run-hooks 'haskell-hugs-hook)
186  (message "")
187  )
188
189(defun haskell-hugs-wait-for-output ()
190  "Wait until output arrives and go to the last input."
191  (while (progn
192	   (goto-char comint-last-input-end)
193	   (and
194	    (not (re-search-forward comint-prompt-regexp nil t))
195	    (accept-process-output haskell-hugs-process)))))
196
197(defun haskell-hugs-send (&rest string)
198  "Send `haskell-hugs-process' the arguments (one or more strings).
199A newline is sent after the strings and they are inserted into the
200current buffer after the last output."
201  ;; Wait until output arrives and go to the last input.
202  (haskell-hugs-wait-for-output)
203  ;; Position for this input.
204  (goto-char (point-max))		
205  (apply 'insert string)
206  (comint-send-input)
207  (setq haskell-hugs-send-end (marker-position comint-last-input-end)))
208
209(defun haskell-hugs-go (load-command cd)
210  "Save the current buffer and load its file into the Hugs process.
211The first argument LOAD-COMMAND specifies how the file should be
212loaded: as a new file (\":load \") or as a reload (\":reload \").
213
214If the second argument CD is non-nil, change the Haskell-Hugs process to the
215current buffer's directory before loading the file.
216
217If the variable `haskell-hugs-command' is set then its value will be sent to
218the Hugs process after the load command.  This can be used for a
219top-level expression to evaluate."
220  (hack-local-variables) ;; In case they've changed
221  (save-buffer)
222  (let ((file (if (string-equal load-command ":load ")
223		  (concat "\"" buffer-file-name "\"")
224		""))
225	(dir (expand-file-name default-directory))
226	(cmd (and (boundp 'haskell-hugs-command)
227		  haskell-hugs-command
228		  (if (stringp haskell-hugs-command)
229		      haskell-hugs-command
230		    (symbol-name haskell-hugs-command)))))
231    (if (and haskell-hugs-process-buffer
232	     (eq (process-status haskell-hugs-process) 'run))
233	;; Ensure the Hugs buffer is selected.
234	(set-buffer haskell-hugs-process-buffer)
235      ;; Start Haskell-Hugs process.
236      (haskell-hugs-start-process nil))
237 
238    (if cd (haskell-hugs-send (concat ":cd " dir)))
239    ;; Wait until output arrives and go to the last input.
240    (haskell-hugs-wait-for-output)
241    (haskell-hugs-send load-command file)
242    ;; Error message search starts from last load command.
243    (setq haskell-hugs-load-end (marker-position comint-last-input-end))
244    (if cmd (haskell-hugs-send cmd))
245    ;; Wait until output arrives and go to the last input.
246    (haskell-hugs-wait-for-output)))
247
248(defun haskell-hugs-load-file (cd)
249  "Save a hugs buffer file and load its file.
250If CD (prefix argument if interactive) is non-nil, change the Hugs
251process to the current buffer's directory before loading the file.
252If there is an error, set the cursor at the error line otherwise show
253the Hugs buffer."
254  (interactive "P")
255  (haskell-hugs-gen-load-file ":load " cd)
256  )
257 
258(defun haskell-hugs-reload-file (cd)
259  "Save a hugs buffer file and load its file.
260If CD (prefix argument if interactive) is non-nil, change the Hugs
261process to the current buffer's directory before loading the file.
262If there is an error, set the cursor at the error line otherwise show
263the Hugs buffer."
264  (interactive "P")
265  (haskell-hugs-gen-load-file ":reload " cd)
266  )
267
268(defun haskell-hugs-gen-load-file (cmd cd)
269  "Save a hugs buffer file and load its file or reload depending on CMD.
270If CD is non-nil, change the process to the current buffer's directory 
271before loading the file. If there is an error, set the cursor at the 
272error line otherwise show the Hugs buffer."
273  (save-excursion (haskell-hugs-go cmd cd))
274  ;; Ensure the Hugs buffer is selected.
275  (set-buffer haskell-hugs-process-buffer)
276  ;; Error message search starts from last load command.
277  (goto-char haskell-hugs-load-end)
278  (if (re-search-forward
279       "^ERROR \"\\([^ ]*\\)\"\\( (line \\([0-9]*\\))\\|\\)" nil t)
280      (let ((efile (buffer-substring (match-beginning 1)
281				     (match-end 1)))
282	    (eline (if (match-beginning 3)
283                       (string-to-int (buffer-substring (match-beginning 3)
284                                                        (match-end 3)))))
285	    (emesg (buffer-substring (1+ (point))
286				     (save-excursion (end-of-line) (point)))))
287        (pop-to-buffer  haskell-hugs-process-buffer) ; show *hugs* buffer
288        (goto-char (point-max))
289        (recenter)
290	(message "Hugs error %s %s"
291                 (file-name-nondirectory efile) emesg)
292        (if (file-exists-p efile)
293            (progn (find-file-other-window efile)
294                   (if eline (goto-line eline))
295                   (recenter)))
296        )
297    (pop-to-buffer  haskell-hugs-process-buffer) ; show *hugs* buffer
298    (goto-char (point-max))
299    (message "There were no errors.")
300    (recenter 2)                        ; show only the end...
301    )
302  )
303
304(defun haskell-hugs-show-hugs-buffer ()
305  "Goes to the Hugs buffer."
306  (interactive)
307  (if (or (not haskell-hugs-process-buffer)
308          (not (buffer-live-p haskell-hugs-process-buffer)))
309      (haskell-hugs-start-process nil))
310  (pop-to-buffer  haskell-hugs-process-buffer)
311  )
312
313(provide 'haskell-hugs)
314
315;; arch-tag: c2a621e9-d743-4361-a459-983fbf1d4589
316;;; haskell-hugs.el ends here