cgit.sxemacs.org Git - packages/blob - xemacs-packages/haskell-mode/haskell-hugs.el

   1 ;;; haskell-hugs.el --- simplistic interaction mode with a
   2
   3 ;; Copyright 2004, 2005  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 2, 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 \f
  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 can be obtained 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
  81 another Emacs buffer named *hugs*.
  82 Maps 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   (interactive)
  91   (local-set-key "\C-c\C-s" 'haskell-hugs-start-process)
  92   (local-set-key "\C-c\C-l" 'haskell-hugs-load-file)
  93   (local-set-key "\C-c\C-r" 'haskell-hugs-reload-file)
  94   (local-set-key "\C-c\C-b" 'haskell-hugs-show-hugs-buffer)
  95   )
  96
  97 (defun turn-off-haskell-hugs ()
  98   "Turn off Haskell interaction mode with a Hugs interpreter within a buffer."
  99   (interactive)
 100   (local-unset-key  "\C-c\C-s")
 101   (local-unset-key  "\C-c\C-l")
 102   (local-unset-key  "\C-c\C-r")
 103   (local-unset-key  "\C-c\C-b")
 104   )
 105
 106 (define-derived-mode haskell-hugs-mode comint-mode "Haskell Hugs"
 107 ;; called by haskell-hugs-start-process,
 108 ;; itself called by haskell-hugs-load-file
 109 ;; only when the file is loaded the first time
 110   "Major mode for interacting with an inferior Hugs session.
 111
 112 The commands available from within a Haskell script are:
 113      \\<haskell-mode-map>\\[haskell-hugs-load-file]
 114        to save the current buffer and load it by sending the :load command
 115        to Hugs.
 116      \\[haskell-hugs-reload-file]
 117        to send the :reload command to Hugs without saving the buffer.
 118      \\[haskell-hugs-show-hugs-buffer]
 119        to show the Hugs buffer and go to it.
 120
 121 \\<haskell-hugs-mode-map>
 122 Commands:
 123 Return at end of buffer sends line as input.
 124 Return not at end copies rest of line to end and sends it.
 125 \\[comint-kill-input] and \\[backward-kill-word] are kill commands,
 126 imitating normal Unix input editing.
 127 \\[comint-interrupt-subjob] interrupts the comint or its current
 128 subjob if any.
 129 \\[comint-stop-subjob] stops, likewise.
 130  \\[comint-quit-subjob] sends quit signal."
 131   )
 132
 133 ;; Hugs-interface
 134
 135 (require 'comint)
 136 (require 'shell)
 137
 138 (defvar haskell-hugs-process nil
 139   "The active Hugs subprocess corresponding to current buffer.")
 140
 141 (defvar haskell-hugs-process-buffer nil
 142   "*Buffer used for communication with Hugs subprocess for current buffer.")
 143
 144 (defcustom haskell-hugs-program-name "hugs"
 145   "*The name of the command to start the Hugs interpreter."
 146   :type 'string
 147   :group 'haskell-hugs)
 148
 149 (defcustom haskell-hugs-program-args '("+.")
 150   "*A list of string args to send to the hugs process."
 151   :type '(repeat string)
 152   :group 'haskell-hugs)
 153
 154 (defvar haskell-hugs-load-end nil
 155   "Position of the end of the last load command.")
 156
 157 (defvar haskell-hugs-send-end nil
 158   "Position of the end of the last send command.")
 159
 160 (defalias 'run-hugs 'haskell-hugs-start-process)
 161
 162 (defun haskell-hugs-start-process (arg)
 163   "Start a Hugs process and invokes `haskell-hugs-hook' if not nil.
 164 Prompts for a list of args if called with an argument."
 165   (interactive "P")
 166   (message "Starting `hugs-process' %s" haskell-hugs-program-name)
 167   (if arg
 168       (setq haskell-hugs-program-args
 169             (read-minibuffer "List of args for Hugs:"
 170                              (prin1-to-string haskell-hugs-program-args))))
 171   (setq haskell-hugs-process-buffer
 172         (apply 'make-comint
 173                "hugs" haskell-hugs-program-name nil
 174                haskell-hugs-program-args))
 175   (setq haskell-hugs-process
 176         (get-buffer-process haskell-hugs-process-buffer))
 177   ;; Select Hugs buffer temporarily
 178   (set-buffer haskell-hugs-process-buffer)
 179   (haskell-hugs-mode)
 180   (make-local-variable 'shell-cd-regexp)
 181   (make-local-variable 'shell-dirtrackp)
 182   (setq shell-cd-regexp         ":cd")
 183   (setq shell-dirtrackp         t)
 184   (add-hook 'comint-input-filter-functions 'shell-directory-tracker)
 185                                 ; ? or  module name in Hugs 1.4
 186   (setq comint-prompt-regexp  "^\? \\|^[A-Z][_a-zA-Z0-9\.]*> ")
 187     ;; comint's history syntax conflicts with Hugs syntax, eg. !!
 188   (setq comint-input-autoexpand nil)
 189   (run-hooks 'haskell-hugs-hook)
 190   (message "")
 191   )
 192
 193 (defun haskell-hugs-wait-for-output ()
 194   "Wait until output arrives and go to the last input."
 195   (while (progn
 196            (goto-char comint-last-input-end)
 197            (and
 198             (not (re-search-forward comint-prompt-regexp nil t))
 199             (accept-process-output haskell-hugs-process)))))
 200
 201 (defun haskell-hugs-send (&rest string)
 202   "Send `haskell-hugs-process' the arguments (one or more strings).
 203 A newline is sent after the strings and they are inserted into the
 204 current buffer after the last output."
 205   ;; Wait until output arrives and go to the last input.
 206   (haskell-hugs-wait-for-output)
 207   ;; Position for this input.
 208   (goto-char (point-max))
 209   (apply 'insert string)
 210   (comint-send-input)
 211   (setq haskell-hugs-send-end (marker-position comint-last-input-end)))
 212
 213 (defun haskell-hugs-go (load-command cd)
 214   "Save the current buffer and load its file into the Hugs process.
 215 The first argument LOAD-COMMAND specifies how the file should be
 216 loaded: as a new file (\":load \") or as a reload (\":reload \").
 217
 218 If the second argument CD is non-nil, change the Haskell-Hugs process to the
 219 current buffer's directory before loading the file.
 220
 221 If the variable `haskell-hugs-command' is set then its value will be sent to
 222 the Hugs process after the load command.  This can be used for a
 223 top-level expression to evaluate."
 224   (hack-local-variables) ;; In case they've changed
 225   (save-buffer)
 226   (let ((file (if (string-equal load-command ":load ")
 227                   (concat "\"" buffer-file-name "\"")
 228                 ""))
 229         (dir (expand-file-name default-directory))
 230         (cmd (and (boundp 'haskell-hugs-command)
 231                   haskell-hugs-command
 232                   (if (stringp haskell-hugs-command)
 233                       haskell-hugs-command
 234                     (symbol-name haskell-hugs-command)))))
 235     (if (and haskell-hugs-process-buffer
 236              (eq (process-status haskell-hugs-process) 'run))
 237         ;; Ensure the Hugs buffer is selected.
 238         (set-buffer haskell-hugs-process-buffer)
 239       ;; Start Haskell-Hugs process.
 240       (haskell-hugs-start-process nil))
 241
 242     (if cd (haskell-hugs-send (concat ":cd " dir)))
 243     ;; Wait until output arrives and go to the last input.
 244     (haskell-hugs-wait-for-output)
 245     (haskell-hugs-send load-command file)
 246     ;; Error message search starts from last load command.
 247     (setq haskell-hugs-load-end (marker-position comint-last-input-end))
 248     (if cmd (haskell-hugs-send cmd))
 249     ;; Wait until output arrives and go to the last input.
 250     (haskell-hugs-wait-for-output)))
 251
 252 (defun haskell-hugs-load-file (cd)
 253   "Save a hugs buffer file and load its file.
 254 If CD (prefix argument if interactive) is non-nil, change the Hugs
 255 process to the current buffer's directory before loading the file.
 256 If there is an error, set the cursor at the error line otherwise show
 257 the Hugs buffer."
 258   (interactive "P")
 259   (haskell-hugs-gen-load-file ":load " cd)
 260   )
 261
 262 (defun haskell-hugs-reload-file (cd)
 263   "Save a hugs buffer file and load its file.
 264 If CD (prefix argument if interactive) is non-nil, change the Hugs
 265 process to the current buffer's directory before loading the file.
 266 If there is an error, set the cursor at the error line otherwise show
 267 the Hugs buffer."
 268   (interactive "P")
 269   (haskell-hugs-gen-load-file ":reload " cd)
 270   )
 271
 272 (defun haskell-hugs-gen-load-file (cmd cd)
 273   "Save a hugs buffer file and load its file or reload depending on CMD.
 274 If CD is non-nil, change the process to the current buffer's directory
 275 before loading the file. If there is an error, set the cursor at the
 276 error line otherwise show the Hugs buffer."
 277   (save-excursion (haskell-hugs-go cmd cd))
 278   ;; Ensure the Hugs buffer is selected.
 279   (set-buffer haskell-hugs-process-buffer)
 280   ;; Error message search starts from last load command.
 281   (goto-char haskell-hugs-load-end)
 282   (if (re-search-forward
 283        "^ERROR \"\\([^ ]*\\)\"\\( (line \\([0-9]*\\))\\|\\)" nil t)
 284       (let ((efile (buffer-substring (match-beginning 1)
 285                                      (match-end 1)))
 286             (eline (if (match-beginning 3)
 287                        (string-to-int (buffer-substring (match-beginning 3)
 288                                                         (match-end 3)))))
 289             (emesg (buffer-substring (1+ (point))
 290                                      (save-excursion (end-of-line) (point)))))
 291         (pop-to-buffer  haskell-hugs-process-buffer) ; show *hugs* buffer