ghc/CONTRIB/haskell-modes/yale/original/haskell.el

   1 ;;; ==================================================================
   2 ;;; File:               haskell.el                                 ;;;
   3 ;;;                                                                ;;;
   4 ;;;                     Author:         A. Satish Pai              ;;;
   5 ;;;                                     Maria M. Gutierrez         ;;;
   6 ;;;                                     Dan Rabin (Jul-1991)       ;;;
   7 ;;; ==================================================================
   8
   9 ;;; Description: Haskell mode for GNU Emacs.
  10
  11 ;;; Related files:  comint.el
  12
  13 ;;; Contents:
  14
  15 ;;;  Update Log
  16
  17 ;;;  Known bugs / problems
  18 ;;;  - the haskell editing mode (indentation, etc) is still missing.
  19 ;;;  - the handling for errors from haskell needs to be rethought.
  20 ;;;  - general cleanup of code.
  21
  22
  23 ;;;  Errors generated
  24
  25 ;;; ==================================================================
  26 ;;; Haskell mode for editing files, and an Inferior Haskell mode to
  27 ;;; run a Haskell process. This file contains stuff snarfed and
  28 ;;; modified from tea.el, scheme.el, etc. This file may be freely
  29 ;;; modified; however, if you have any bug-corrections or useful
  30 ;;; improvements, I'd appreciate it if you sent me the mods so that
  31 ;;; I can merge them into the version I maintain.
  32 ;;;
  33 ;;; The inferior Haskell mode requires comint.el.
  34 ;;;
  35 ;;; You might want to add this to your .emacs to go automagically
  36 ;;; into Haskell mode while finding .hs files.
  37 ;;;
  38 ;;;   (setq auto-mode-alist
  39 ;;;         (cons '("\\.hs$" . haskell-mode)
  40 ;;;                auto-mode-alist)_)
  41 ;;;
  42 ;;; To use this file, set up your .emacs to autoload this file for
  43 ;;; haskell-mode. For example:
  44 ;;;
  45 ;;;    (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc"
  46 ;;;       "Load Haskell mode" t)
  47 ;;;
  48 ;;;    (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc"
  49 ;;;       "Load Haskell mode" t)
  50 ;;;
  51 ;;; [Note: The path name given above is Yale specific!! Modify as
  52 ;;; required.]
  53 ;;; ================================================================
  54
  55 ;;; Announce your existence to the world at large.
  56
  57 (provide 'haskell)
  58
  59
  60 ;;; Load these other files.
  61
  62 (require 'comint)        ; Olin Shivers' comint mode is the substratum
  63
  64
  65
  66 \f
  67 ;;; ================================================================
  68 ;;; Declare a bunch of variables.
  69 ;;; ================================================================
  70
  71
  72 ;;; User settable (via M-x set-variable and M-x edit-options)
  73
  74 (defvar haskell-program-name (getenv "HASKELLPROG")
  75   "*Program invoked by the haskell command.")
  76
  77 (defvar haskell-auto-create-process t
  78   "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.")
  79
  80 (defvar haskell-auto-switch-input t
  81   "*If not nil, jump to *haskell* buffer automatically on input request.")
  82
  83 (defvar haskell-ask-before-saving t
  84   "*If not nil, ask before saving random haskell-mode buffers.")
  85
  86 (defvar haskell-initial-printers '("interactive")
  87   "*Printers to set when starting a new Haskell process.")
  88
  89
  90 ;;; Pad/buffer Initialization variables
  91
  92 (defvar *haskell-buffer* "*haskell*"
  93   "Name of the haskell process buffer")
  94
  95 (defvar haskell-main-pad "\*Main-pad\*"
  96   "Scratch pad associated with module Main")
  97
  98 (defvar haskell-main-module "Main")
  99
 100
 101 (defvar *last-loaded* nil)
 102 (defvar *last-module* haskell-main-module)
 103 (defvar *last-pad* haskell-main-pad)
 104
 105
 106 ;;; These are used for haskell-tutorial mode.
 107
 108 (defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs")
 109 (defvar *ht-temp-buffer* nil)
 110 (defvar *ht-file-buffer* "Haskell-Tutorial-Master")
 111
 112
 113 \f
 114 ;;; ================================================================
 115 ;;; Haskell editing mode stuff
 116 ;;; ================================================================
 117
 118 ;;; Leave this place alone...
 119 ;;; The definitions below have been pared down to the bare
 120 ;;; minimum; they will be restored later.
 121 ;;;
 122 ;;; -Satish 2/5.
 123
 124 ;;; Keymap for Haskell mode
 125 (defvar haskell-mode-map (make-sparse-keymap)
 126   "Keymap used for haskell-mode")
 127
 128 (defun haskell-establish-key-bindings (keymap)
 129   (define-key keymap "\C-ce"    'haskell-eval)
 130   (define-key keymap "\C-cr"    'haskell-run)
 131   (define-key keymap "\C-ct"    'haskell-report-type)
 132   (define-key keymap "\C-cm"    'haskell-run-main)
 133   (define-key keymap "\C-c\C-r" 'haskell-run-file)
 134   (define-key keymap "\C-cp"    'haskell-get-pad)
 135   (define-key keymap "\C-c\C-o" 'haskell-optimizers)
 136   (define-key keymap "\C-c\C-p" 'haskell-printers)
 137   (define-key keymap "\C-cc"    'haskell-compile)
 138   (define-key keymap "\C-cl"    'haskell-load)
 139   (define-key keymap "\C-ch"    'haskell-switch)
 140   (define-key keymap "\C-c\C-k" 'haskell-kill)
 141   (define-key keymap "\C-c:"    'haskell-command)
 142   (define-key keymap "\C-cq"    'haskell-exit)
 143   (define-key keymap "\C-ci"    'haskell-interrupt)
 144   (define-key keymap "\C-cu"    'haskell-edit-unit))
 145
 146
 147 (haskell-establish-key-bindings haskell-mode-map)
 148
 149
 150 (defvar haskell-mode-syntax-table nil
 151   "Syntax table used for haskell-mode")
 152
 153 (if haskell-mode-syntax-table
 154     nil
 155     (setq haskell-mode-syntax-table (standard-syntax-table)))
 156
 157 ;;; Command for invoking the Haskell mode
 158 (defun haskell-mode nil
 159   "Major mode for editing Haskell code to run in Emacs
 160 The following commands are available:
 161 \\{haskell-mode-map}
 162
 163 A Haskell process can be fired up with \"M-x haskell\".
 164
 165 Customization: Entry to this mode runs the hooks that are the value of variable
 166 haskell-mode-hook.
 167
 168 Windows:
 169
 170 There are 3 types of windows associated with Haskell mode.  They are:
 171    *haskell*:  which is the process window.
 172    Pad:        which are buffers available for each module.  It is here
 173                where you want to test things before preserving them in a
 174                file.  Pads are always associated with a module.
 175                When issuing a command:
 176                  The pad and its associated module are sent to the Haskell
 177                  process prior to the execution of the command.
 178    .hs:        These are the files where Haskell programs live.  They
 179                have .hs as extension.
 180                When issuing a command:
 181                  The file is sent to the Haskell process prior to the
 182                  execution of the command.
 183
 184 Commands:
 185
 186 Each command behaves differently according to the type of the window in which
 187 the cursor is positioned when the command is issued .
 188
 189 haskell-eval:   \\[haskell-eval]
 190   Always promts user for a Haskell expression to be evaluated.  If in a
 191   .hs file buffer, then the cursor tells which module is the current
 192   module and the pad for that module (if any) gets loaded as well.
 193
 194 haskell-run:    \\[haskell-run]
 195   Always queries for a variable of type Dialogue to be evaluated.
 196
 197 haskell-run-main:    \\[haskell-run-main]
 198   Run Dialogue named main in the current module.
 199
 200 haskell-report-type:   \\[haskell-report-type]
 201   Like haskell-eval, but prints the type of the expression without
 202   evaluating it.
 203
 204 haskell-mode:   \\[haskell-mode]
 205   Puts the current buffer in haskell mode.
 206
 207 haskell-compile:   \\[haskell-compile]
 208   Compiles file in current buffer.
 209
 210 haskell-load:   \\[haskell-load]
 211   Loads file in current buffer.
 212
 213 haskell-run-file:   \\[haskell-run-file]
 214   Runs file in the current buffer.
 215
 216 haskell-pad:   \\[haskell-pad]
 217   Creates a scratch pad for the current module.
 218
 219 haskell-optimizers:  \\[haskell-optimizers]
 220   Shows the list of available optimizers.  Commands for turning them on/off.
 221
 222 haskell-printers:  \\[haskell-printers]
 223   Shows the list of available printers.  Commands for turning them on/off.
 224
 225 haskell-command:   \\[haskell-command]
 226   Prompts for a command to be sent to the command interface.  You don't
 227   need to put the : before the command.
 228
 229 haskell-quit:   \\[haskell-quit]
 230   Terminates the haskell process.
 231
 232 haskell-switch:   \\[haskell-switch]
 233   Switches to the inferior Haskell buffer (*haskell*) and positions the
 234   cursor at the end of the buffer.
 235
 236 haskell-kill:  \\[haskell-kill]
 237   Kill the current contents of the *haskell* buffer.
 238
 239 haskell-interrupt:   \\[haskell-interrupt]
 240   Interrupts haskell process and resets it.
 241
 242 haskell-edit-unit:   \\[haskell-edit-unit]
 243   Edit the .hu file for the unit containing this file.
 244 "
 245   (interactive)
 246   (kill-all-local-variables)
 247   (use-local-map haskell-mode-map)
 248   (setq major-mode 'haskell-mode)
 249   (setq mode-name "Haskell")
 250   (make-local-variable 'indent-line-function)
 251   (setq indent-line-function 'indent-relative-maybe)
 252   ;(setq local-abbrev-table haskell-mode-abbrev-table)
 253   (set-syntax-table haskell-mode-syntax-table)
 254   ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list??
 255   (run-hooks 'haskell-mode-hook))
 256
 257
 258 \f
 259 ;;;================================================================
 260 ;;; Inferior Haskell stuff
 261 ;;;================================================================
 262
 263
 264 (defvar inferior-haskell-mode-map (full-copy-sparse-keymap comint-mode-map))
 265
 266 (haskell-establish-key-bindings inferior-haskell-mode-map)
 267 (define-key inferior-haskell-mode-map "\C-m"     'haskell-send-input)
 268
 269 (defvar haskell-source-modes '(haskell-mode)
 270   "*Used to determine if a buffer contains Haskell source code.
 271 If it's loaded into a buffer that is in one of these major modes,
 272 it's considered a Haskell source file.")
 273
 274 (defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*"
 275   "Regular expression capturing the Haskell system prompt.")
 276
 277 (defvar haskell-prompt-ring ()
 278   "Keeps track of input to haskell process from the minibuffer")
 279
 280 (defun inferior-haskell-mode-variables ()
 281   nil)
 282
 283
 284 ;;; INFERIOR-HASKELL-MODE (adapted from comint.el)
 285
 286 (defun inferior-haskell-mode ()
 287   "Major mode for interacting with an inferior Haskell process.
 288
 289 The following commands are available:
 290 \\{inferior-haskell-mode-map}
 291
 292 A Haskell process can be fired up with \"M-x haskell\".
 293
 294 Customization: Entry to this mode runs the hooks on comint-mode-hook and
 295 inferior-haskell-mode-hook (in that order).
 296
 297 You can send text to the inferior Haskell process from other buffers containing
 298 Haskell source.
 299
 300
 301 Windows:
 302
 303 There are 3 types of windows in the inferior-haskell-mode.  They are:
 304    *haskell*:  which is the process window.
 305    Pad:        which are buffers available for each module.  It is here
 306                where you want to test things before preserving them in a
 307                file.  Pads are always associated with a module.
 308                When issuing a command:
 309                  The pad and its associated module are sent to the Haskell
 310                  process prior to the execution of the command.
 311    .hs:        These are the files where Haskell programs live.  They
 312                have .hs as extension.
 313                When issuing a command:
 314                  The file is sent to the Haskell process prior to the
 315                  execution of the command.
 316
 317 Commands:
 318
 319 Each command behaves differently according to the type of the window in which
 320 the cursor is positioned when the command is issued.
 321
 322 haskell-eval:   \\[haskell-eval]
 323   Always promts user for a Haskell expression to be evaluated.  If in a
 324   .hs file, then the cursor tells which module is the current module and
 325   the pad for that module (if any) gets loaded as well.
 326
 327 haskell-run:    \\[haskell-run]
 328   Always queries for a variable of type Dialogue to be evaluated.
 329
 330 haskell-run-main:    \\[haskell-run-main]
 331   Run Dialogue named main.
 332
 333 haskell-report-type:   \\[haskell-report-type]
 334   Like haskell-eval, but prints the type of the expression without
 335   evaluating it.
 336
 337 haskell-mode:   \\[haskell-mode]
 338   Puts the current buffer in haskell mode.
 339
 340 haskell-compile:   \\[haskell-compile]
 341   Compiles file in current buffer.
 342
 343 haskell-load:   \\[haskell-load]
 344   Loads file in current buffer.
 345
 346 haskell-run-file:   \\[haskell-run-file]
 347   Runs file in the current buffer.
 348
 349 haskell-pad:   \\[haskell-pad]
 350   Creates a scratch pad for the current module.
 351
 352 haskell-optimizers:  \\[haskell-optimizers]
 353   Shows the list of available optimizers.  Commands for turning them on/off.
 354
 355 haskell-printers:  \\[haskell-printers]
 356   Shows the list of available printers.  Commands for turning them on/off.
 357
 358 haskell-command:   \\[haskell-command]
 359   Prompts for a command to be sent to the command interface.  You don't
 360   need to put the : before the command.
 361
 362 haskell-quit:   \\[haskell-quit]
 363   Terminates the haskell process.
 364
 365 haskell-switch:   \\[haskell-switch]
 366   Switches to the inferior Haskell buffer (*haskell*) and positions the
 367   cursor at the end of the buffer.
 368
 369 haskell-kill:  \\[haskell-kill]
 370   Kill the current contents of the *haskell* buffer.
 371
 372 haskell-interrupt:   \\[haskell-interrupt]
 373   Interrupts haskell process and resets it.
 374
 375 haskell-edit-unit:   \\[haskell-edit-unit]
 376   Edit the .hu file for the unit containing this file.
 377
 378 The usual comint functions are also available. In particular, the
 379 following are all available:
 380
 381 comint-bol: Beginning of line, but skip prompt. Bound to C-a by default.
 382 comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in
 383             which case send EOF to process. Bound to C-d by default.
 384
 385 Note however, that the default keymap bindings provided shadow some of
 386 the default comint mode bindings, so that you may want to bind them
 387 to your choice of keys.
 388
 389 Comint mode's dynamic completion of filenames in the buffer is available.
 390 (Q.v. comint-dynamic-complete, comint-dynamic-list-completions.)
 391
 392 If you accidentally suspend your process, use \\[comint-continue-subjob]
 393 to continue it."
 394
 395   (interactive)
 396   (comint-mode)
 397   (setq comint-prompt-regexp haskell-prompt-pattern)
 398   ;; Customise in inferior-haskell-mode-hook
 399   (inferior-haskell-mode-variables)
 400   (setq major-mode 'inferior-haskell-mode)
 401   (setq mode-name "Inferior Haskell")
 402   (setq mode-line-process '(": %s : busy"))
 403   (use-local-map inferior-haskell-mode-map)
 404   (setq comint-input-filter 'haskell-input-filter)
 405   (setq comint-input-sentinel 'ignore)
 406   (setq comint-get-old-input 'haskell-get-old-input)
 407   (run-hooks 'inferior-haskell-mode-hook)
 408     ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
 409     ;The test is so we don't lose history if we run comint-mode twice in
 410     ;a buffer.
 411   (setq haskell-prompt-ring (make-ring input-ring-size)))
 412
 413
 414 (defun haskell-input-filter (str)
 415   "Don't save whitespace."
 416   (not (string-match "\\s *" str)))
 417
 418
 419 \f
 420 ;;; ==================================================================
 421 ;;; Random utilities
 422 ;;; ==================================================================
 423
 424
 425 ;;; This keeps track of the status of the haskell process.
 426 ;;; Values are:
 427 ;;; busy -- The process is busy.
 428 ;;; ready -- The process is ready for a command.
 429 ;;; input -- The process is waiting for input.
 430 ;;; debug -- The process is in the debugger.
 431
 432 (defvar *haskell-status* 'busy
 433   "Status of the haskell process")
 434
 435 (defun set-haskell-status (value)
 436   (setq *haskell-status* value)
 437   (haskell-update-mode-line))
 438
 439 (defun get-haskell-status ()
 440   *haskell-status*)
 441
 442 (defun haskell-update-mode-line ()
 443   (save-excursion
 444     (set-buffer *haskell-buffer*)
 445     (cond ((eq *haskell-status* 'ready)
 446            (setq mode-line-process '(": %s: ready")))
 447           ((eq *haskell-status* 'input)
 448            (setq mode-line-process '(": %s: input")))
 449           ((eq *haskell-status* 'busy)
 450            (setq mode-line-process '(": %s: busy")))
 451           ((eq *haskell-status* 'debug)
 452            (setq mode-line-process '(": %s: debug")))
 453           (t
 454            (haskell-mode-error "Confused about status of haskell process!")))
 455     ;; Yes, this is the officially sanctioned technique for forcing
 456     ;; a redisplay of the mode line.
 457     (set-buffer-modified-p (buffer-modified-p))))
 458
 459
 460 (defun haskell-send-to-process (string)
 461   (process-send-string "haskell" string)
 462   (process-send-string "haskell" "\n"))
 463
 464
 465 \f
 466 ;;; ==================================================================
 467 ;;; Handle input in haskell process buffer; history commands.
 468 ;;; ==================================================================
 469
 470 (defun haskell-get-old-input ()
 471   "Get old input text from Haskell process buffer."
 472   (save-excursion
 473     (if (re-search-forward haskell-prompt-pattern (point-max) 'move)
 474         (goto-char (match-beginning 0)))
 475     (cond ((re-search-backward haskell-prompt-pattern (point-min) t)
 476            (comint-skip-prompt)
 477            (let ((temp  (point)))
 478              (end-of-line)
 479              (buffer-substring temp (point)))))))
 480
 481
 482 (defun haskell-send-input ()
 483   "Send input to Haskell while in the process buffer"
 484   (interactive)
 485   (if (eq (get-haskell-status) 'debug)
 486       (comint-send-input)
 487       (haskell-send-input-aux)))
 488
 489 (defun haskell-send-input-aux ()
 490   ;; Note that the input string does not include its terminal newline.
 491   (let ((proc (get-buffer-process (current-buffer))))
 492     (if (not proc)
 493         (haskell-mode-error "Current buffer has no process!")
 494         (let* ((pmark (process-mark proc))
 495                (pmark-val (marker-position pmark))
 496                (input (if (>= (point) pmark-val)
 497                           (buffer-substring pmark (point))
 498                           (let ((copy (funcall comint-get-old-input)))
 499                             (goto-char pmark)
 500                             (insert copy)
 501                             copy))))
 502           (insert ?\n)
 503           (if (funcall comint-input-filter input)
 504               (ring-insert input-ring input))
 505           (funcall comint-input-sentinel input)
 506           (set-marker (process-mark proc) (point))
 507           (set-marker comint-last-input-end (point))
 508           (haskell-send-to-process input)))))
 509
 510
 511 \f
 512 ;;; ==================================================================
 513 ;;; Minibuffer input stuff
 514 ;;; ==================================================================
 515
 516 ;;; Haskell input history retrieval commands   (taken from comint.el)
 517 ;;; M-p -- previous input    M-n -- next input
 518
 519 (defvar haskell-minibuffer-local-map nil
 520   "Local map for minibuffer when in Haskell")
 521
 522 (if haskell-minibuffer-local-map
 523     nil
 524     (progn
 525       (setq haskell-minibuffer-local-map
 526             (full-copy-sparse-keymap minibuffer-local-map))
 527       ;; Haskell commands
 528       (define-key haskell-minibuffer-local-map "\ep"   'haskell-previous-input)
 529       (define-key haskell-minibuffer-local-map "\en"   'haskell-next-input)
 530       ))
 531
 532 (defun haskell-previous-input (arg)
 533   "Cycle backwards through input history."
 534   (interactive "*p")
 535   (let ((len (ring-length haskell-prompt-ring)))
 536     (cond ((<= len 0)
 537            (message "Empty input ring.")
 538            (ding))
 539           (t
 540            (cond ((eq last-command 'haskell-previous-input)
 541                   (delete-region (mark) (point))
 542                   (set-mark (point)))
 543                  (t
 544                   (setq input-ring-index
 545                         (if (> arg 0) -1
 546                             (if (< arg 0) 1 0)))
 547                   (push-mark (point))))
 548            (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
 549            (insert (ring-ref haskell-prompt-ring input-ring-index))
 550            (setq this-command 'haskell-previous-input))
 551           )))
 552
 553 (defun haskell-next-input (arg)
 554   "Cycle forwards through input history."
 555   (interactive "*p")
 556   (haskell-previous-input (- arg)))
 557
 558 (defvar haskell-last-input-match ""
 559   "Last string searched for by Haskell input history search, for defaulting.
 560 Buffer local variable.")
 561
 562 (defun haskell-previous-input-matching (str)
 563   "Searches backwards through input history for substring match"
 564   (interactive (let ((s (read-from-minibuffer
 565                          (format "Command substring (default %s): "
 566                                  haskell-last-input-match))))
 567                  (list (if (string= s "") haskell-last-input-match s))))
 568   (setq haskell-last-input-match str) ; update default
 569   (let ((str (regexp-quote str))
 570         (len (ring-length haskell-prompt-ring))
 571         (n 0))
 572     (while (and (<= n len)
 573                 (not (string-match str (ring-ref haskell-prompt-ring n))))
 574       (setq n (+ n 1)))
 575     (cond ((<= n len) (haskell-previous-input (+ n 1)))
 576           (t (haskell-mode-error "Not found.")))))
 577
 578
 579 ;;; Actually read an expression from the minibuffer using the new keymap.
 580
 581 (defun haskell-get-expression (prompt)
 582   (let ((exp  (read-from-minibuffer prompt nil haskell-minibuffer-local-map)))
 583     (ring-insert haskell-prompt-ring exp)
 584     exp))
 585
 586
 587 \f
 588 ;;; ==================================================================
 589 ;;; Handle output from Haskell process
 590 ;;; ==================================================================
 591
 592 ;;; The haskell process produces output with embedded control codes.
 593 ;;; These control codes are used to keep track of what kind of input
 594 ;;; the haskell process is expecting.  Ordinary output is just displayed.
 595 ;;;
 596 ;;; This is kind of complicated because control sequences can be broken
 597 ;;; across multiple batches of text received from the haskell process.
 598 ;;; If the string ends in the middle of a control sequence, save it up
 599 ;;; for the next call.
 600
 601 (defvar *haskell-saved-output* nil)
 602
 603 ;;; On the Next, there is some kind of race condition that causes stuff
 604 ;;; sent to the Haskell subprocess before it has really started to be lost.
 605 ;;; The point of this variable is to force the Emacs side to wait until
 606 ;;; Haskell has started and printed out its banner before sending it
 607 ;;; anything.  See start-haskell below.
 608
 609 (defvar *haskell-process-alive* nil)
 610
 611 (defun haskell-output-filter (process str)
 612   "Filter for output from Yale Haskell command interface"
 613   ;; *** debug
 614   ;;(let ((buffer  (get-buffer-create "haskell-output")))
 615   ;;  (save-excursion
 616   ;;    (set-buffer buffer)
 617   ;;    (insert str)))
 618   (setq *haskell-process-alive* t)
 619   (let ((next    0)
 620         (start   0)
 621         (data    (match-data)))
 622     (unwind-protect
 623         (progn
 624           ;; If there was saved output from last time, glue it in front of the
 625           ;; newly received input.
 626           (if *haskell-saved-output*
 627               (progn
 628                 (setq str (concat *haskell-saved-output* str))
 629                 (setq *haskell-saved-output* nil)))
 630           ;; Loop, looking for complete command sequences.
 631           ;; Set next to point to the first one.
 632           ;; start points to first character to be processed.
 633           (while (setq next
 634                        (string-match *haskell-message-match-regexp*
 635                                      str start))
 636             ;; Display any intervening ordinary text.
 637             (if (not (eq next start))
 638                 (haskell-display-output (substring str start next)))
 639             ;; Now dispatch on the particular command sequence found.
 640             ;; Handler functions are called with the string and start index
 641             ;; as arguments, and should return the index of the "next"
 642             ;; character.
 643             (let ((end  (match-end 0)))
 644               (haskell-handle-message str next)
 645               (setq start end)))
 646           ;; Look to see whether the string ends with an incomplete
 647           ;; command sequence.
 648           ;; If so, save the tail of the string for next time.
 649           (if (and (setq next
 650                      (string-match *haskell-message-prefix-regexp* str start))
 651                    (eq (match-end 0) (length str)))
 652               (setq *haskell-saved-output* (substring str next))
 653               (setq next (length str)))
 654           ;; Display any leftover ordinary text.
 655           (if (not (eq next start))
 656               (haskell-display-output (substring str start next))))
 657       (store-match-data data))))
 658
 659 (defvar *haskell-message-match-regexp*
 660   "EMACS:.*\n")
 661
 662 (defvar *haskell-message-prefix-regexp*
 663   "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?")
 664
 665 (defvar *haskell-message-dispatch*
 666   '(("EMACS:debug\n"         . haskell-got-debug)
 667     ("EMACS:busy\n"          . haskell-got-busy)
 668     ("EMACS:input\n"         . haskell-got-input)
 669     ("EMACS:ready\n"         . haskell-got-ready)
 670     ("EMACS:printers .*\n"   . haskell-got-printers)
 671     ("EMACS:optimizers .*\n" . haskell-got-optimizers)
 672     ("EMACS:message .*\n"    . haskell-got-message)
 673     ("EMACS:error\n"         . haskell-got-error)
 674     ))
 675
 676 (defun haskell-handle-message (str idx)
 677   (let ((list  *haskell-message-dispatch*)
 678         (fn    nil))
 679     (while (and list (null fn))
 680       (if (eq (string-match (car (car list)) str idx) idx)
 681           (setq fn (cdr (car list)))
 682           (setq list (cdr list))))
 683     (if (null fn)
 684         (haskell-mode-error "Garbled message from Haskell!")
 685         (let ((end  (match-end 0)))
 686           (funcall fn str idx end)
 687           end))))
 688
 689
 690 (defun haskell-message-data (string start end)
 691   (let ((real-start  (+ (string-match " " string start) 1))
 692         (real-end    (- end 1)))
 693     (substring string real-start real-end)))
 694
 695 (defun haskell-got-debug (string start end)
 696   (beep)
 697   (message "In the debugger!")
 698   (set-haskell-status 'debug))
 699
 700 (defun haskell-got-busy (string start end)
 701   (set-haskell-status 'busy))
 702
 703 (defun haskell-got-input (string start end)
 704   (if haskell-auto-switch-input
 705       (progn
 706         (haskell-switch)
 707         (beep)))
 708   (set-haskell-status 'input)
 709   (message "Waiting for input..."))
 710
 711 (defun haskell-got-ready (string start end)
 712   (set-haskell-status 'ready))
 713
 714 (defun haskell-got-printers (string start end)
 715   (haskell-printers-update (haskell-message-data string start end)))
 716
 717 (defun haskell-got-optimizers (string start end)
 718   (haskell-optimizers-update (haskell-message-data string start end)))
 719
 720 (defun haskell-got-message (string start end)
 721   (message "%s" (haskell-message-data string start end)))
 722
 723 (defun haskell-got-error (string start end)
 724   (beep)
 725   (message "Haskell error."))
 726
 727
 728 ;;; Displays output at end of given buffer.
 729 ;;; This function only ensures that the output is visible, without
 730 ;;; selecting the buffer in which it is displayed.
 731 ;;; Note that just using display-buffer instead of all this rigamarole
 732 ;;; won't work; you need to temporarily select the window containing
 733 ;;; the *haskell-buffer*, or else the display won't be scrolled to show
 734 ;;; the new output.
 735 ;;; *** This should really position the window in the buffer so that
 736 ;;; *** the point is on the last line of the window.
 737
 738 (defun haskell-display-output (str)
 739   (let ((window  (selected-window)))
 740     (unwind-protect
 741         (progn
 742           (pop-to-buffer *haskell-buffer*)
 743           (haskell-display-output-aux str))
 744       (select-window window))))
 745
 746 (defun haskell-display-output-aux (str)
 747   (haskell-move-marker)
 748   (insert str)
 749   (haskell-move-marker))
 750
 751
 752 \f
 753 ;;; ==================================================================
 754 ;;; Interactive commands
 755 ;;; ==================================================================
 756
 757
 758 ;;; HASKELL
 759 ;;; -------
 760 ;;;
 761 ;;; This is the function that fires up the inferior haskell process.
 762
 763 (defun haskell ()
 764   "Run an inferior Haskell process with input and output via buffer *haskell*.
 765 Takes the program name from the variable haskell-program-name.
 766 Runs the hooks from inferior-haskell-mode-hook
 767 (after the comint-mode-hook is run).
 768 \(Type \\[describe-mode] in the process buffer for a list of commands.)"
 769   (interactive)
 770   (if (not (haskell-process-exists-p))
 771     (start-haskell)))
 772
 773 (defun start-haskell ()
 774   (message "Starting haskell subprocess...")
 775   ;; Kill old haskell process.  Normally this routine is only called
 776   ;; after checking haskell-process-exists-p, but things can get
 777   ;; screwed up if you rename the *haskell* buffer while leaving the
 778   ;; old process running.  This forces it to get rid of the old process
 779   ;; and start a new one.
 780   (if (get-process "haskell")
 781       (delete-process "haskell"))
 782   (let ((haskell-buffer
 783          (apply 'make-comint
 784                 "haskell"
 785                 (or haskell-program-name
 786                     (haskell-mode-error "Haskell-program-name undefined!"))
 787                 nil
 788                 nil)))
 789     (save-excursion
 790       (set-buffer haskell-buffer)
 791       (inferior-haskell-mode))
 792     (haskell-session-init)
 793     ;; Wait for process to get started before sending it anything
 794     ;; to avoid race condition on NeXT.
 795     (setq *haskell-process-alive* nil)
 796     (while (not *haskell-process-alive*)
 797       (sleep-for 1))
 798     (haskell-send-to-process ":(use-emacs-interface)")
 799     (haskell-printers-set haskell-initial-printers nil)
 800     (display-buffer haskell-buffer))
 801   (message "Starting haskell subprocess...  Done."))
 802
 803
 804 (defun haskell-process-exists-p ()
 805   (let ((haskell-buffer  (get-buffer *haskell-buffer*)))
 806     (and haskell-buffer (comint-check-proc haskell-buffer))))
 807
 808
 809
 810 ;;; Initialize things on the emacs side, and tell haskell that it's
 811 ;;; talking to emacs.
 812
 813 (defun haskell-session-init ()
 814   (set-haskell-status 'busy)
 815   (setq *last-loaded* nil)
 816   (setq *last-module* haskell-main-module)
 817   (setq *last-pad* haskell-main-pad)
 818   (setq *haskell-saved-output* nil)
 819   (haskell-create-main-pad)
 820   (set-process-filter (get-process "haskell") 'haskell-output-filter)
 821   )
 822
 823
 824 (defun haskell-create-main-pad ()
 825   (let ((buffer (get-buffer-create haskell-main-pad)))
 826     (save-excursion
 827       (set-buffer buffer)
 828       (haskell-mode))
 829     (haskell-record-pad-mapping
 830       haskell-main-pad haskell-main-module nil)
 831     buffer))
 832
 833
 834 ;;; Called from evaluation and compilation commands to start up a Haskell
 835 ;;; process if none is already in progress.
 836
 837 (defun haskell-maybe-create-process ()
 838   (cond ((haskell-process-exists-p)
 839          t)
 840         (haskell-auto-create-process
 841          (start-haskell))
 842         (t
 843          (haskell-mode-error "No Haskell process!"))))
 844
 845
 846
 847 ;;; HASKELL-GET-PAD
 848 ;;; ------------------------------------------------------------------
 849
 850 ;;; This always puts the pad buffer in the "other" window.
 851 ;;; Having it wipe out the .hs file window is clearly the wrong
 852 ;;; behavior.
 853
 854 (defun haskell-get-pad ()
 855   "Creates a new scratch pad for the current module.
 856 Signals an error if the current buffer is not a .hs file."
 857   (interactive)
 858   (let ((fname (buffer-file-name)))
 859     (if fname
 860         (do-get-pad fname (current-buffer))
 861         (haskell-mode-error "Not in a .hs buffer!"))))
 862
 863
 864 (defun do-get-pad (fname buff)
 865   (let* ((mname (or (haskell-get-modname buff)
 866                     (read-no-blanks-input "Scratch pad for module? " nil)))
 867          (pname (haskell-lookup-pad mname fname))
 868          (pbuff nil))
 869     ;; Generate the base name of the pad buffer, then create the
 870     ;; buffer.  The actual name of the pad buffer may be something
 871     ;; else because of name collisions.
 872     (if (not pname)
 873         (progn
 874           (setq pname (format "*%s-pad*" mname))
 875           (setq pbuff (generate-new-buffer pname))
 876           (setq pname (buffer-name pbuff))
 877           (haskell-record-pad-mapping pname mname fname)
 878           )
 879         (setq pbuff (get-buffer pname)))
 880     ;; Make sure the pad buffer is in haskell mode.
 881     (pop-to-buffer pbuff)
 882     (haskell-mode)))
 883
 884
 885
 886 ;;; HASKELL-SWITCH
 887 ;;; ------------------------------------------------------------------
 888
 889 (defun haskell-switch ()
 890   "Switches to \*haskell\* buffer."
 891   (interactive)
 892   (haskell-maybe-create-process)
 893   (pop-to-buffer *haskell-buffer*)
 894   (push-mark)
 895   (goto-char (point-max)))
 896
 897
 898
 899 ;;; HASKELL-KILL
 900 ;;; ------------------------------------------------------------------
 901
 902 (defun haskell-kill ()
 903   "Kill contents of *haskell* buffer.  \\[haskell-kill]"
 904   (interactive)
 905   (save-excursion
 906     (set-buffer *haskell-buffer*)
 907     (beginning-of-buffer)
 908     (let ((mark  (point)))
 909       (end-of-buffer)
 910       (kill-region mark (point)))))
 911
 912
 913
 914 ;;; HASKELL-COMMAND
 915 ;;; ------------------------------------------------------------------
 916
 917 (defun haskell-command (str)
 918   "Format STRING as a haskell command and send it to haskell process.  \\[haskell-command]"
 919   (interactive "sHaskell command: ")
 920   (haskell-send-to-process (format ":%s" str)))
 921
 922
 923 ;;; HASKELL-EVAL and HASKELL-RUN
 924 ;;; ------------------------------------------------------------------
 925
 926 (defun haskell-eval ()
 927   "Evaluate expression in current module. \\[haskell-eval]"
 928   (interactive)
 929   (haskell-maybe-create-process)
 930   (haskell-eval-aux (haskell-get-expression "Haskell expression: ")
 931                     "emacs-eval"))
 932
 933 (defun haskell-run ()
 934   "Run Haskell Dialogue in current module"
 935   (interactive)
 936   (haskell-maybe-create-process)
 937   (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ")
 938                     "emacs-run"))
 939
 940 (defun haskell-run-main ()
 941   "Run Dialogue named main in current module"
 942   (interactive)
 943   (haskell-maybe-create-process)
 944   (haskell-eval-aux "main" "emacs-run"))
 945
 946 (defun haskell-report-type ()
 947   "Print the type of the expression."
 948   (interactive)
 949   (haskell-maybe-create-process)
 950   (haskell-eval-aux (haskell-get-expression "Haskell expression: ")
 951                     "emacs-report-type"))
 952
 953 (defun haskell-eval-aux (exp fn)
 954   (cond ((equal *haskell-buffer* (buffer-name))
 955          ;; In the *haskell* buffer.
 956          (let* ((pname  *last-pad*)
 957                 (mname  *last-module*)
 958                 (fname  *last-loaded*))
 959            (haskell-eval-aux-aux exp pname mname fname fn)))
 960         ((buffer-file-name)
 961          ;; In a .hs file.
 962          (let* ((fname  (buffer-file-name))
 963                 (mname  (haskell-get-modname (current-buffer)))
 964                 (pname  (haskell-lookup-pad mname fname)))
 965            (haskell-eval-aux-aux exp pname mname fname fn)))
 966         (t
 967          ;; In a pad.
 968          (let* ((pname  (buffer-name (current-buffer)))
 969                 (mname  (haskell-get-module-from-pad pname))
 970                 (fname  (haskell-get-file-from-pad pname)))
 971            (haskell-eval-aux-aux exp pname mname fname fn)))
 972         ))
 973
 974 (defun haskell-eval-aux-aux (exp pname mname fname fn)
 975   (haskell-save-modified-source-files fname)
 976   (haskell-send-to-process (format ":(%s" fn))
 977   (haskell-send-to-process
 978     (prin1-to-string exp))
 979   (haskell-send-to-process
 980     (prin1-to-string (or pname fname "interactive")))
 981   (haskell-send-to-process
 982     (prin1-to-string
 983       (if (and pname (get-buffer pname))
 984           (save-excursion
 985             (set-buffer pname)
 986             (buffer-string))
 987           "")))
 988   (haskell-send-to-process
 989     (format "'|%s|" mname))
 990   (haskell-send-to-process
 991     (if fname
 992         (prin1-to-string (haskell-maybe-get-unit-file-name fname))
 993         "'#f"))
 994   (haskell-send-to-process ")")
 995   (setq *last-pad* pname)
 996   (setq *last-module* mname)
 997   (setq *last-loaded* fname))
 998
 999
1000
1001 ;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE
1002 ;;; ------------------------------------------------------------------
1003
1004 (defun haskell-run-file ()
1005   "Runs Dialogue named main in current file."
1006   (interactive)
1007   (haskell-maybe-create-process)
1008   (let ((fname  (haskell-get-file-to-operate-on)))
1009     (haskell-save-modified-source-files fname)
1010     (haskell-send-to-process ":(emacs-run-file")
1011     (haskell-send-to-process (prin1-to-string fname))
1012     (haskell-send-to-process ")")))
1013
1014 (defun haskell-load ()
1015   "Load current file."
1016   (interactive)
1017   (haskell-maybe-create-process)
1018   (let ((fname  (haskell-get-file-to-operate-on)))
1019     (haskell-save-modified-source-files fname)
1020     (haskell-send-to-process ":(emacs-load-file")
1021     (haskell-send-to-process (prin1-to-string fname))
1022     (haskell-send-to-process ")")))
1023
1024 (defun haskell-compile ()
1025   "Compile current file."
1026   (interactive)
1027   (haskell-maybe-create-process)
1028   (let ((fname  (haskell-get-file-to-operate-on)))
1029     (haskell-save-modified-source-files fname)
1030     (haskell-send-to-process ":(emacs-compile-file")
1031     (haskell-send-to-process (prin1-to-string fname))
1032     (haskell-send-to-process ")")))
1033
1034
1035 (defun haskell-get-file-to-operate-on ()
1036   (cond ((equal *haskell-buffer* (buffer-name))
1037          ;; When called from the haskell process buffer, prompt for a file.
1038          (call-interactively 'haskell-get-file/prompt))
1039         ((buffer-file-name)
1040          ;; When called from a .hs file buffer, use the unit file
1041          ;; associated with it, if there is one.
1042          (haskell-maybe-get-unit-file-name (buffer-file-name)))
1043         (t
1044          ;; When called from a pad, use the file that the module the
1045          ;; pad belongs to lives in.
1046          (haskell-maybe-get-unit-file-name
1047            (haskell-get-file-from-pad (buffer-name (current-buffer)))))))
1048
1049 (defun haskell-get-file/prompt (filename)
1050   (interactive "fHaskell file:  ")
1051   (haskell-run-file-aux filename))
1052
1053
1054
1055 ;;; HASKELL-EXIT
1056 ;;; ------------------------------------------------------------------
1057
1058 (defun haskell-exit ()
1059   "Quit the haskell process."
1060   (interactive)
1061   (cond ((not (haskell-process-exists-p))
1062          (message "No process currently running."))
1063         ((y-or-n-p "Do you really want to quit Haskell? ")
1064          (haskell-send-to-process ":quit")
1065          ;; If we were running the tutorial, mark the temp buffer as unmodified
1066          ;; so we don't get asked about saving it later.
1067          (if (and *ht-temp-buffer*
1068                   (get-buffer *ht-temp-buffer*))
1069              (save-excursion
1070                (set-buffer *ht-temp-buffer*)
1071                (set-buffer-modified-p nil)))
1072          ;; Try to remove the haskell output buffer from the screen.
1073          (bury-buffer *haskell-buffer*)
1074          (replace-buffer-in-windows *haskell-buffer*))
1075         (t
1076          nil)))
1077
1078
1079 ;;; HASKELL-INTERRUPT
1080 ;;; ------------------------------------------------------------------
1081
1082 (defun haskell-interrupt ()
1083   "Interrupt the haskell process."
1084   (interactive)
1085   (if (haskell-process-exists-p)
1086       (haskell-send-to-process "\C-c")))
1087
1088
1089
1090 ;;; HASKELL-EDIT-UNIT
1091 ;;; ------------------------------------------------------------------
1092
1093 (defun haskell-edit-unit ()
1094   "Edit the .hu file."
1095   (interactive)
1096   (let ((fname       (buffer-file-name)))
1097     (if fname
1098         (let ((find-file-not-found-hooks  (list 'haskell-new-unit))
1099               (file-not-found             nil)
1100               (units-fname                (haskell-get-unit-file-name fname)))
1101           (find-file-other-window units-fname)
1102           ;; If creating a new file, initialize it to contain the name
1103           ;; of the haskell source file.
1104           (if file-not-found
1105               (save-excursion
1106                 (insert
1107                   (if (string= (file-name-directory fname)
1108                                (file-name-directory units-fname))
1109                       (file-name-nondirectory fname)
1110                       fname)
1111                   "\n"))))
1112         (haskell-mode-error "Not in a .hs buffer!"))))
1113
1114 (defun haskell-new-unit ()
1115   (setq file-not-found t))
1116
1117
1118 ;;; Look for a comment like "-- unit:" at top of file.
1119 ;;; If not found, assume unit file has same name as the buffer but
1120 ;;; a .hu extension.
1121
1122 (defun haskell-get-unit-file-name (fname)
1123   (or (haskell-get-unit-file-name-from-file fname)
1124       (concat (haskell-strip-file-extension fname) ".hu")))
1125
1126 (defun haskell-maybe-get-unit-file-name (fname)
1127   (or (haskell-get-unit-file-name-from-file fname)
1128       (haskell-strip-file-extension fname)))
1129
1130 (defun haskell-get-unit-file-name-from-file (fname)
1131   (let ((buffer  (get-file-buffer fname)))
1132     (if buffer
1133         (save-excursion
1134           (beginning-of-buffer)
1135           (if (re-search-forward "-- unit:[ \t]*" (point-max) t)
1136               (let ((beg  (match-end 0)))
1137                 (end-of-line)
1138                 (buffer-substring beg (point)))
1139               nil))
1140         nil)))
1141
1142
1143
1144 \f
1145 ;;; ==================================================================
1146 ;;; Support for printers/optimizers menus
1147 ;;; ==================================================================
1148
1149 ;;; This code was adapted from the standard buff-menu.el code.
1150
1151 (defvar haskell-menu-mode-map nil "")
1152
1153 (if (not haskell-menu-mode-map)
1154     (progn
1155       (setq haskell-menu-mode-map (make-keymap))
1156       (suppress-keymap haskell-menu-mode-map t)
1157       (define-key haskell-menu-mode-map "m" 'hm-mark)
1158       (define-key haskell-menu-mode-map "u" 'hm-unmark)
1159       (define-key haskell-menu-mode-map "x" 'hm-exit)
1160       (define-key haskell-menu-mode-map "q" 'hm-exit)
1161       (define-key haskell-menu-mode-map " " 'next-line)
1162       (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark)
1163       (define-key haskell-menu-mode-map "?" 'describe-mode)))
1164
1165 ;; Printers Menu mode is suitable only for specially formatted data.
1166
1167 (put 'haskell-menu-mode 'mode-class 'special)
1168
1169 (defun haskell-menu-mode ()
1170   "Major mode for editing Haskell flags.
1171 Each line describes a flag.
1172 Letters do not insert themselves; instead, they are commands.
1173 m -- mark flag (turn it on)
1174 u -- unmark flag (turn it off)
1175 x -- exit; tell the Haskell process to update the flags, then leave menu.
1176 q -- exit; same as x.
1177 Precisely,\\{haskell-menu-mode-map}"
1178   (kill-all-local-variables)
1179   (use-local-map haskell-menu-mode-map)
1180   (setq truncate-lines t)
1181   (setq buffer-read-only t)
1182   (setq major-mode 'haskell-menu-mode)
1183   (setq mode-name "Haskell Flags Menu")
1184   ;; These are all initialized elsewhere
1185   (make-local-variable 'hm-current-flags)
1186   (make-local-variable 'hm-request-fn)
1187   (make-local-variable 'hm-update-fn)
1188   (run-hooks 'haskell-menu-mode-hook))
1189
1190
1191 (defun haskell-menu (help-file buffer request-fn update-fn)
1192   (haskell-maybe-create-process)
1193   (if (get-buffer buffer)
1194       (progn
1195         (pop-to-buffer buffer)
1196         (goto-char (point-min)))
1197       (progn
1198         (pop-to-buffer buffer)
1199         (insert-file-contents help-file)
1200         (haskell-menu-mode)
1201         (setq hm-request-fn request-fn)
1202         (setq hm-update-fn update-fn)
1203         ))
1204   (hm-mark-current)
1205   (message "m = mark; u = unmark; x = execute; q = quit; ? = more help."))
1206
1207
1208
1209 ;;; A line that starts with *hm-marked* is a menu item turned on.
1210 ;;; A line that starts with *hm-unmarked* is turned off.
1211 ;;; A line that starts with anything else is just random text and is
1212 ;;; ignored by commands that deal with menu items.
1213
1214 (defvar *hm-marked*   " on")
1215 (defvar *hm-unmarked* "   ")
1216 (defvar *hm-marked-regexp*   " on   \\w")
1217 (defvar *hm-unmarked-regexp* "      \\w")
1218
1219 (defun hm-mark ()
1220   "Mark flag to be turned on."
1221   (interactive)
1222   (beginning-of-line)
1223   (cond ((looking-at *hm-marked-regexp*)
1224          (forward-line 1))
1225         ((looking-at *hm-unmarked-regexp*)
1226          (let ((buffer-read-only  nil))
1227            (delete-char (length *hm-unmarked*))
1228            (insert *hm-marked*)
1229            (forward-line 1)))
1230         (t
1231          (forward-line 1))))
1232
1233 (defun hm-unmark ()
1234   "Unmark flag."
1235   (interactive)
1236   (beginning-of-line)
1237   (cond ((looking-at *hm-unmarked-regexp*)
1238          (forward-line 1))
1239         ((looking-at *hm-marked-regexp*)
1240          (let ((buffer-read-only  nil))
1241            (delete-char (length *hm-marked*))
1242            (insert *hm-unmarked*)
1243            (forward-line 1)))
1244         (t
1245          (forward-line 1))))
1246
1247 (defun hm-backup-unmark ()
1248   "Move up and unmark."
1249   (interactive)
1250   (forward-line -1)
1251   (hm-unmark)
1252   (forward-line -1))
1253
1254
1255 ;;; Actually make the changes.
1256
1257 (defun hm-exit ()
1258   "Update flags, then leave menu."
1259   (interactive)
1260   (hm-execute)
1261   (hm-quit))
1262
1263 (defun hm-execute ()
1264   "Tell haskell process to tweak flags."
1265   (interactive)
1266   (save-excursion
1267     (goto-char (point-min))
1268     (let ((flags-on   nil)
1269           (flags-off  nil))
1270       (while (not (eq (point) (point-max)))
1271         (cond ((looking-at *hm-unmarked-regexp*)
1272                (setq flags-off (cons (hm-flag) flags-off)))
1273               ((looking-at *hm-marked-regexp*)
1274                (setq flags-on (cons (hm-flag) flags-on)))
1275               (t
1276                nil))
1277         (forward-line 1))
1278       (funcall hm-update-fn flags-on flags-off))))
1279
1280
1281 (defun hm-quit ()
1282   (interactive)
1283   "Make the menu go away."
1284   (bury-buffer (current-buffer))
1285   (replace-buffer-in-windows (current-buffer)))
1286
1287 (defun hm-flag ()
1288   (save-excursion
1289     (beginning-of-line)
1290     (forward-char 6)
1291     (let ((beg  (point)))
1292       ;; End of flag name marked by tab or two spaces.
1293       (re-search-forward "\t\\|  ")
1294       (buffer-substring beg (match-beginning 0)))))
1295
1296
1297 ;;; Update the menu to mark only those items currently turned on.
1298
1299 (defun hm-mark-current ()
1300   (funcall hm-request-fn)
1301   (save-excursion
1302     (goto-char (point-min))
1303     (while (not (eq (point) (point-max)))
1304       (cond ((and (looking-at *hm-unmarked-regexp*)
1305                   (hm-item-currently-on-p (hm-flag)))
1306              (hm-mark))
1307             ((and (looking-at *hm-marked-regexp*)
1308                   (not (hm-item-currently-on-p (hm-flag))))
1309              (hm-unmark))
1310             (t
1311              (forward-line 1))))))
1312
1313
1314 ;;; See if a menu item is turned on.
1315
1316 (defun hm-item-currently-on-p (item)
1317   (member-string= item hm-current-flags))
1318
1319 (defun member-string= (item list)
1320   (cond ((null list)
1321          nil)
1322         ((string= item (car list))
1323          list)
1324         (t
1325          (member-string= item (cdr list)))))
1326
1327
1328
1329 ;;; Make the menu for printers.
1330
1331 (defvar *haskell-printers-help*
1332   (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt")
1333   "Help file for printers.")
1334
1335 (defvar *haskell-printers-buffer* "*Haskell printers*")
1336
1337 (defun haskell-printers ()
1338   "Set printers interactively."
1339   (interactive)
1340   (haskell-menu
1341     *haskell-printers-help*
1342     *haskell-printers-buffer*
1343     'haskell-printers-inquire
1344     'haskell-printers-set))
1345
1346 (defun haskell-printers-inquire ()
1347   (setq hm-current-flags t)
1348   (haskell-send-to-process ":(emacs-send-printers)")
1349   (while (eq hm-current-flags t)
1350     (sleep-for 1)))
1351
1352 (defun haskell-printers-update (data)
1353   (setq hm-current-flags (read data)))
1354
1355 (defun haskell-printers-set (flags-on flags-off)
1356   (haskell-send-to-process ":(emacs-set-printers '")
1357   (haskell-send-to-process (prin1-to-string flags-on))
1358   (haskell-send-to-process ")"))
1359
1360
1361 ;;; Equivalent stuff for the optimizers menu
1362
1363 (defvar *haskell-optimizers-help*
1364   (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt")
1365   "Help file for optimizers.")
1366
1367 (defvar *haskell-optimizers-buffer* "*Haskell optimizers*")
1368
1369 (defun haskell-optimizers ()
1370   "Set optimizers interactively."
1371   (interactive)
1372   (haskell-menu
1373     *haskell-optimizers-help*
1374     *haskell-optimizers-buffer*
1375     'haskell-optimizers-inquire
1376     'haskell-optimizers-set))
1377
1378 (defun haskell-optimizers-inquire ()
1379   (setq hm-current-flags t)
1380   (haskell-send-to-process ":(emacs-send-optimizers)")
1381   (while (eq hm-current-flags t)
1382     (sleep-for 1)))
1383
1384 (defun haskell-optimizers-update (data)
1385   (setq hm-current-flags (read data)))
1386
1387 (defun haskell-optimizers-set (flags-on flags-off)
1388   (haskell-send-to-process ":(emacs-set-optimizers '")
1389   (haskell-send-to-process (prin1-to-string flags-on))
1390   (haskell-send-to-process ")"))
1391
1392
1393 \f
1394 ;;; ==================================================================
1395 ;;; Random utilities
1396 ;;; ==================================================================
1397
1398
1399 ;;; Keep track of the association between pads, modules, and files.
1400 ;;; The global variable is a list of (pad-buffer-name module-name file-name)
1401 ;;; lists.
1402
1403 (defvar *haskell-pad-mappings* ()
1404   "Associates pads with their corresponding module and file.")
1405
1406 (defun haskell-record-pad-mapping (pname mname fname)
1407   (setq *haskell-pad-mappings*
1408         (cons (list pname mname fname) *haskell-pad-mappings*)))
1409
1410 (defun haskell-get-module-from-pad (pname)
1411   (car (cdr (assoc pname *haskell-pad-mappings*))))
1412
1413 (defun haskell-get-file-from-pad (pname)
1414   (car (cdr (cdr (assoc pname *haskell-pad-mappings*)))))
1415
1416 (defun haskell-lookup-pad (mname fname)
1417   (let ((pname  (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*)))
1418     (if (and pname (get-buffer pname))
1419         pname
1420         nil)))
1421
1422 (defun haskell-lookup-pad-aux (mname fname list)
1423   (cond ((null list)
1424          nil)
1425         ((and (equal mname (car (cdr (car list))))
1426               (equal fname (car (cdr (cdr (car list))))))
1427          (car (car list)))
1428         (t
1429          (haskell-lookup-pad-aux mname fname (cdr list)))))
1430
1431
1432
1433 ;;; Save any modified .hs and .hu files.
1434 ;;; Yes, the two set-buffer calls really seem to be necessary.  It seems
1435 ;;; that y-or-n-p makes emacs forget we had temporarily selected some
1436 ;;; other buffer, and if you just do save-buffer directly it will end
1437 ;;; up trying to save the current buffer instead.  The built-in
1438 ;;; save-some-buffers function has this problem....
1439
1440 (defun haskell-save-modified-source-files (filename)
1441   (let ((buffers   (buffer-list))
1442         (found-any nil))
1443     (while buffers
1444       (let ((buffer  (car buffers)))
1445         (if (and (buffer-modified-p buffer)
1446                  (save-excursion
1447                    (set-buffer buffer)
1448                    (and buffer-file-name
1449                         (haskell-source-file-p buffer-file-name)
1450                         (setq found-any t)
1451                         (or (null haskell-ask-before-saving)
1452                             (and filename (string= buffer-file-name filename))
1453                             (y-or-n-p
1454                                 (format "Save file %s? " buffer-file-name))))))
1455             (save-excursion
1456               (set-buffer buffer)
1457               (save-buffer))))
1458       (setq buffers (cdr buffers)))
1459     (if found-any
1460         (message "")
1461         (message "(No files need saving)"))))
1462
1463 (defun haskell-source-file-p (filename)
1464   (or (string-match "\\.hs$" filename)
1465       (string-match "\\.lhs$" filename)
1466       (string-match "\\.hi$" filename)
1467       (string-match "\\.hu$" filename)))
1468
1469
1470
1471 ;;; Buffer utilities
1472
1473 (defun haskell-move-marker ()
1474   "Moves the marker and point to the end of buffer"
1475   (set-marker comint-last-input-end (point-max))
1476   (set-marker (process-mark (get-process "haskell")) (point-max))
1477   (goto-char (point-max)))
1478
1479
1480
1481 ;;; Extract the name of the module the point is in, from the given buffer.
1482
1483 (defvar *haskell-re-module-hs*  "^module\\s *")
1484 (defvar *haskell-re-module-lhs* "^>\\s *module\\s *")
1485 (defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*")
1486
1487 (defun haskell-get-modname (buff)
1488   "Get module name in BUFFER that point is in."
1489   (save-excursion
1490     (set-buffer buff)
1491     (let ((regexp  (if (haskell-lhs-filename-p (buffer-file-name))
1492                        *haskell-re-module-lhs*
1493                        *haskell-re-module-hs*)))
1494       (if (or (looking-at regexp)
1495               (re-search-backward regexp (point-min) t)
1496               (re-search-forward regexp (point-max) t))
1497           (progn
1498             (goto-char (match-end 0))
1499             (if (looking-at *haskell-re-modname*)
1500                 (buffer-substring (match-beginning 0) (match-end 0))
1501                 (haskell-mode-error "Module name not found!!")))
1502           "Main"))))
1503
1504
1505 ;;; Strip file extensions.
1506 ;;; Only strip off extensions we know about; e.g.
1507 ;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar".
1508
1509 (defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$")
1510
1511 (defun haskell-strip-file-extension (filename)
1512   "Strip off the extension from a filename."
1513   (if (string-match *haskell-filename-regexp* filename)
1514       (substring filename (match-beginning 1) (match-end 1))
1515       filename))
1516
1517
1518 ;;; Is this a .lhs filename?
1519
1520 (defun haskell-lhs-filename-p (filename)
1521   (string-match ".*\\.lhs$" filename))
1522
1523
1524 ;;; Haskell mode error
1525
1526 (defun haskell-mode-error (msg)
1527   "Show MSG in message line as an error from the haskell mode."
1528   (error (concat "Haskell mode:  " msg)))
1529
1530
1531 \f
1532 ;;; ==================================================================
1533 ;;; User customization
1534 ;;; ==================================================================
1535
1536 (defvar haskell-load-hook nil
1537   "This hook is run when haskell is loaded in.
1538 This is a good place to put key bindings."
1539   )
1540
1541 (run-hooks 'haskell-load-hook)
1542
1543
1544
1545 \f
1546 ;;;======================================================================
1547 ;;; Tutorial mode setup
1548 ;;;======================================================================
1549
1550 ;;; Set up additional key bindings for tutorial mode.
1551
1552 (defvar ht-mode-map (make-sparse-keymap))
1553
1554 (haskell-establish-key-bindings ht-mode-map)
1555 (define-key ht-mode-map "\C-c\C-f" 'ht-next-page)
1556 (define-key ht-mode-map "\C-c\C-b" 'ht-prev-page)
1557 (define-key ht-mode-map "\C-c\C-l" 'ht-restore-page)
1558 (define-key ht-mode-map "\C-c?"    'describe-mode)
1559
1560 (defun haskell-tutorial-mode ()
1561   "Major mode for running the Haskell tutorial.
1562 You can use these commands:
1563 \\{ht-mode-map}"
1564   (interactive)
1565   (kill-all-local-variables)
1566   (use-local-map ht-mode-map)
1567   (setq major-mode 'haskell-tutorial-mode)
1568   (setq mode-name "Haskell Tutorial")
1569   (set-syntax-table haskell-mode-syntax-table)
1570   (run-hooks 'haskell-mode-hook))
1571
1572
1573 (defun haskell-tutorial ()
1574   "Run the haskell tutorial."
1575   (interactive)
1576   (ht-load-tutorial)
1577   (ht-make-buffer)
1578   (ht-display-page)
1579   (haskell-maybe-create-process)
1580   (haskell-send-to-process ":(emacs-set-printers '(interactive))")
1581   )
1582
1583
1584 ;;; Load the tutorial file into a read-only buffer.  Do not display this
1585 ;;; buffer.
1586
1587 (defun ht-load-tutorial ()
1588   (let ((buffer  (get-buffer *ht-file-buffer*)))
1589     (if buffer
1590         (save-excursion
1591           (set-buffer buffer)
1592           (beginning-of-buffer))
1593         (save-excursion
1594           (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*)))
1595           (let ((fname (substitute-in-file-name *ht-source-file*)))
1596             (if (file-readable-p fname)
1597                 (ht-load-tutorial-aux fname)
1598                 (call-interactively 'ht-load-tutorial-aux)))))))
1599
1600 (defun ht-load-tutorial-aux (filename)
1601   (interactive "fTutorial file: ")
1602   (insert-file filename)
1603   (set-buffer-modified-p nil)
1604   (setq buffer-read-only t)
1605   (beginning-of-buffer))
1606
1607
1608 ;;; Create a buffer to use for messing about with each page of the tutorial.
1609 ;;; Put the buffer into haskell-tutorial-mode.
1610
1611 (defun ht-make-buffer ()
1612   (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs"))
1613   (setq *ht-temp-buffer* (buffer-name))
1614   (haskell-tutorial-mode))
1615
1616
1617 ;;; Commands for loading text into the tutorial pad buffer
1618
1619 (defun ht-next-page ()
1620   "Go to the next tutorial page."
1621   (interactive)
1622   (if (ht-goto-next-page)
1623       (ht-display-page)
1624       (beep)))
1625
1626 (defun ht-goto-next-page ()
1627   (let ((buff  (current-buffer)))
1628     (unwind-protect
1629         (progn
1630           (set-buffer *ht-file-buffer*)
1631           (search-forward "\C-l" nil t))
1632       (set-buffer buff))))
1633
1634 (defun ht-prev-page ()
1635   "Go to the previous tutorial page."
1636   (interactive)
1637   (if (ht-goto-prev-page)
1638       (ht-display-page)
1639       (beep)))
1640
1641 (defun ht-goto-prev-page ()
1642   (let ((buff  (current-buffer)))
1643     (unwind-protect
1644         (progn
1645           (set-buffer *ht-file-buffer*)
1646           (search-backward "\C-l" nil t))
1647       (set-buffer buff))))
1648
1649 (defun ht-goto-page (arg)
1650   "Go to the tutorial page specified as the argument."
1651   (interactive "sGo to page: ")
1652   (if (ht-searchfor-page (format "Page: %s " arg))
1653       (ht-display-page)
1654       (beep)))
1655
1656 (defun ht-goto-section (arg)
1657   "Go to the tutorial section specified as the argument."
1658   (interactive "sGo to section: ")
1659   (if (ht-searchfor-page (format "Section: %s " arg))
1660       (ht-display-page)
1661       (beep)))
1662
1663 (defun ht-searchfor-page (search-string)
1664   (let ((buff           (current-buffer)))
1665     (unwind-protect
1666         (progn
1667           (set-buffer *ht-file-buffer*)
1668           (let ((point  (point)))
1669             (beginning-of-buffer)
1670             (if (search-forward search-string nil t)
1671                 t
1672                 (progn
1673                   (goto-char point)
1674                   nil))))
1675       (set-buffer buff))))
1676
1677 (defun ht-restore-page ()
1678   (interactive)
1679   (let ((old-point  (point)))
1680     (ht-display-page)
1681     (goto-char old-point)))
1682
1683 (defun ht-display-page ()
1684   (set-buffer *ht-file-buffer*)
1685   (let* ((beg   (progn
1686                  (if (search-backward "\C-l" nil t)
1687                      (forward-line 1)
1688                      (beginning-of-buffer))
1689                  (point)))
1690          (end   (progn
1691                   (if (search-forward "\C-l" nil t)
1692                       (beginning-of-line)
1693                       (end-of-buffer))
1694                   (point)))
1695          (text  (buffer-substring beg end)))
1696     (set-buffer *ht-temp-buffer*)
1697     (erase-buffer)
1698     (insert text)
1699     (beginning-of-buffer)))
1700
1701
1702 \f
1703 ;;;======================================================================
1704 ;;; Menu bar stuff
1705 ;;;======================================================================
1706
1707 ;;; This only works in Emacs version 19, so it's in a separate file for now.
1708
1709 (if (featurep 'menu-bar)
1710     (load-library "haskell-menu"))