emacs/external/ml/inf-caml.el

   1 ;(***********************************************************************)
   2 ;(*                                                                     *)
   3 ;(*                           Objective Caml                            *)
   4 ;(*                                                                     *)
   5 ;(*                   Xavier Leroy and Jacques Garrigue                 *)
   6 ;(*                                                                     *)
   7 ;(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
   8 ;(*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 ;(*  under the terms of the GNU General Public License.                 *)
  10 ;(*                                                                     *)
  11 ;(***********************************************************************)
  12
  13 ;(* $Id: inf-caml.el,v 1.10.8.1 2004/08/09 16:09:33 doligez Exp $ *)
  14
  15 ;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer
  16
  17 ;; Xavier Leroy, july 1993.
  18
  19 ;; modified by Jacques Garrigue, july 1997.
  20
  21 (require 'comint)
  22 (require 'caml)
  23
  24 ;; User modifiable variables
  25
  26 ;; Whether you want the output buffer to be diplayed when you send a phrase
  27
  28 (defvar caml-display-when-eval t
  29   "*If true, display the inferior caml buffer when evaluating expressions.")
  30
  31
  32 ;; End of User modifiable variables
  33
  34
  35 (defvar inferior-caml-mode-map nil)
  36 (if inferior-caml-mode-map nil
  37   (setq inferior-caml-mode-map
  38         (copy-keymap comint-mode-map)))
  39
  40 ;; Augment Caml mode, so you can process Caml code in the source files.
  41
  42 (defvar inferior-caml-program "ocaml"
  43   "*Program name for invoking an inferior Caml from Emacs.")
  44
  45 (defun inferior-caml-mode ()
  46   "Major mode for interacting with an inferior Caml process.
  47 Runs a Caml toplevel as a subprocess of Emacs, with I/O through an
  48 Emacs buffer. A history of input phrases is maintained. Phrases can
  49 be sent from another buffer in Caml mode.
  50
  51 \\{inferior-caml-mode-map}"
  52   (interactive)
  53   (comint-mode)
  54   (setq comint-prompt-regexp "^# ?")
  55   (setq major-mode 'inferior-caml-mode)
  56   (setq mode-name "Inferior Caml")
  57   (make-local-variable 'paragraph-start)
  58   (setq paragraph-start (concat "^$\\|" page-delimiter))
  59   (make-local-variable 'paragraph-separate)
  60   (setq paragraph-separate paragraph-start)
  61   (make-local-variable 'paragraph-ignore-fill-prefix)
  62   (setq paragraph-ignore-fill-prefix t)
  63   (make-local-variable 'require-final-newline)
  64   (setq require-final-newline t)
  65   (make-local-variable 'comment-start)
  66   (setq comment-start "(*")
  67   (make-local-variable 'comment-end)
  68   (setq comment-end "*)")
  69   (make-local-variable 'comment-column)
  70   (setq comment-column 40)
  71   (make-local-variable 'comment-start-skip)
  72   (setq comment-start-skip "(\\*+ *")
  73   (make-local-variable 'parse-sexp-ignore-comments)
  74   (setq parse-sexp-ignore-comments nil)
  75   (use-local-map inferior-caml-mode-map)
  76   (run-hooks 'inferior-caml-mode-hooks))
  77
  78
  79 (defconst inferior-caml-buffer-subname "inferior-caml")
  80 (defconst inferior-caml-buffer-name
  81   (concat "*" inferior-caml-buffer-subname "*"))
  82
  83 ;; for compatibility with xemacs
  84
  85 (defun caml-sit-for (second &optional mili redisplay)
  86    (if (and (boundp 'running-xemacs) running-xemacs)
  87        (sit-for (if mili (+ second (* mili 0.001)) second) redisplay)
  88      (sit-for second mili redisplay)))
  89
  90 ;; To show result of evaluation at toplevel
  91
  92 (defvar inferior-caml-output nil)
  93 (defun inferior-caml-signal-output (s)
  94   (if (string-match "[^ ]" s) (setq inferior-caml-output t)))
  95
  96 (defun inferior-caml-mode-output-hook ()
  97   (setq comint-output-filter-functions
  98         (list (function inferior-caml-signal-output))))
  99 (add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook)
 100
 101 ;; To launch ocaml whenever needed
 102
 103 (defun caml-run-process-if-needed (&optional cmd)
 104   (if (comint-check-proc inferior-caml-buffer-name) nil
 105     (if (not cmd)
 106         (if (comint-check-proc inferior-caml-buffer-name)
 107             (setq cmd inferior-caml-program)
 108           (setq cmd (read-from-minibuffer "Caml toplevel to run: "
 109                                           inferior-caml-program))))
 110     (setq inferior-caml-program cmd)
 111     (let ((cmdlist (inferior-caml-args-to-list cmd))
 112           (process-connection-type nil))
 113       (set-buffer (apply (function make-comint)
 114                          inferior-caml-buffer-subname
 115                          (car cmdlist) nil (cdr cmdlist)))
 116       (inferior-caml-mode)
 117       (display-buffer inferior-caml-buffer-name)
 118       t)
 119     (setq caml-shell-active t)
 120     ))
 121
 122 ;; patched to from original run-caml sharing code with
 123 ;;  caml-run-process-when-needed
 124
 125 (defun run-caml (&optional cmd)
 126   "Run an inferior Caml process.
 127 Input and output via buffer `*inferior-caml*'."
 128   (interactive
 129    (list (if (not (comint-check-proc inferior-caml-buffer-name))
 130              (read-from-minibuffer "Caml toplevel to run: "
 131                                    inferior-caml-program))))
 132   (caml-run-process-if-needed cmd)
 133   (switch-to-buffer-other-window inferior-caml-buffer-name))
 134
 135
 136 (defun inferior-caml-args-to-list (string)
 137   (let ((where (string-match "[ \t]" string)))
 138     (cond ((null where) (list string))
 139           ((not (= where 0))
 140            (cons (substring string 0 where)
 141                  (inferior-caml-args-to-list (substring string (+ 1 where)
 142                                                         (length string)))))
 143           (t (let ((pos (string-match "[^ \t]" string)))
 144                (if (null pos)
 145                    nil
 146                  (inferior-caml-args-to-list (substring string pos
 147                                                         (length string)))))))))
 148
 149 (defun inferior-caml-show-subshell ()
 150   (interactive)
 151   (caml-run-process-if-needed)
 152   (display-buffer inferior-caml-buffer-name)
 153   ; Added by Didier to move the point of inferior-caml to end of buffer
 154   (let ((buf (current-buffer))
 155         (caml-buf  (get-buffer inferior-caml-buffer-name))
 156         (count 0))
 157     (while
 158         (and (< count 10)
 159              (not (equal (buffer-name (current-buffer))
 160                          inferior-caml-buffer-name)))
 161       (next-multiframe-window)
 162       (setq count (+ count 1)))
 163     (if  (equal (buffer-name (current-buffer))
 164                 inferior-caml-buffer-name)
 165         (end-of-buffer))
 166     (while
 167         (> count 0)
 168       (previous-multiframe-window)
 169       (setq count (- count 1)))
 170     )
 171 )
 172
 173 ;; patched by Didier to move cursor after evaluation
 174
 175 (defun inferior-caml-eval-region (start end)
 176   "Send the current region to the inferior Caml process."
 177   (interactive "r")
 178   (save-excursion (caml-run-process-if-needed))
 179   (save-excursion
 180     (goto-char end)
 181     (caml-skip-comments-backward)
 182     (comint-send-region inferior-caml-buffer-name start (point))
 183     ;; normally, ";;" are part of the region
 184     (if (and (>= (point) 2)
 185              (prog2 (backward-char 2) (looking-at ";;")))
 186         (comint-send-string inferior-caml-buffer-name "\n")
 187       (comint-send-string inferior-caml-buffer-name ";;\n"))
 188     ;; the user may not want to see the output buffer
 189     (if caml-display-when-eval
 190         (display-buffer inferior-caml-buffer-name t))))
 191
 192 ;; jump to errors produced by ocaml compiler
 193
 194 (defun inferior-caml-goto-error (start end)
 195   "Jump to the location of the last error as indicated by inferior toplevel."
 196   (interactive "r")
 197   (let ((loc (+ start
 198                 (save-excursion
 199                   (set-buffer (get-buffer inferior-caml-buffer-name))
 200                   (re-search-backward
 201                    (concat comint-prompt-regexp
 202                            "[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$"))
 203                   (string-to-int (match-string 1))))))
 204     (goto-char loc)))
 205
 206
 207 ;;; orgininal inf-caml.el ended here
 208
 209 ;; as eval-phrase, but ignores errors.
 210
 211 (defun inferior-caml-just-eval-phrase (arg &optional min max)
 212   "Send the phrase containing the point to the CAML process.
 213 With prefix-arg send as many phrases as its numeric value,
 214 ignoring possible errors during evaluation.
 215
 216 Optional arguments min max defines a region within which the phrase
 217 should lies."
 218   (interactive "p")
 219   (let ((beg))
 220     (while (> arg 0)
 221       (setq arg (- arg 1))
 222       (setq beg  (caml-find-phrase min max))
 223       (caml-eval-region beg (point)))
 224     beg))
 225
 226 (defvar caml-previous-output nil
 227   "tells the beginning of output in the shell-output buffer, so that the
 228 output can be retreived later, asynchronously.")
 229
 230 ;; enriched version of eval-phrase, to repport errors.
 231
 232 (defun inferior-caml-eval-phrase (arg &optional min max)
 233   "Send the phrase containing the point to the CAML process.
 234 With prefix-arg send as many phrases as its numeric value,
 235 If an error occurs during evalutaion, stop at this phrase and
 236 repport the error.
 237
 238 Return nil if noerror and position of error if any.
 239
 240 If arg's numeric value is zero or negative, evaluate the current phrase
 241 or as many as prefix arg, ignoring evaluation errors.
 242 This allows to jump other erroneous phrases.
 243
 244 Optional arguments min max defines a region within which the phrase
 245 should lies."
 246   (interactive "p")
 247   (if (save-excursion (caml-run-process-if-needed))
 248       (progn
 249         (setq inferior-caml-output nil)
 250         (caml-wait-output 10 1)))
 251   (if (< arg 1) (inferior-caml-just-eval-phrase (max 1 (- 0 arg)) min max)
 252     (let ((proc (get-buffer-process inferior-caml-buffer-name))
 253           (buf (current-buffer))
 254           previous-output orig beg end err)
 255       (save-window-excursion
 256         (while (and (> arg 0) (not err))
 257           (setq previous-output (marker-position (process-mark proc)))
 258           (setq caml-previous-output previous-output)
 259           (setq inferior-caml-output nil)
 260           (setq orig (inferior-caml-just-eval-phrase 1 min max))
 261           (caml-wait-output)
 262           (switch-to-buffer inferior-caml-buffer-name  nil)
 263           (goto-char previous-output)
 264           (cond ((re-search-forward
 265                   " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]"
 266                   (point-max) t)
 267                  (setq beg (string-to-int (caml-match-string 1)))
 268                  (setq end (string-to-int (caml-match-string 2)))
 269                  (switch-to-buffer buf)
 270                  (goto-char orig)
 271                  (forward-byte end)
 272                  (setq end (point))
 273                  (goto-char orig)
 274                  (forward-byte beg)
 275                  (setq beg (point))
 276                  (setq err beg)
 277                  )
 278                 ((looking-at
 279                   "Toplevel input:\n[>]\\([^\n]*\\)\n[>]\\(\\( *\\)^*\\)\n")
 280                  (let ((expr (caml-match-string 1))
 281                        (column (-   (match-end 3) (match-beginning 3)))
 282                        (width (-   (match-end 2) (match-end 3))))
 283                    (if (string-match  "^\\(.*\\)[<]EOF[>]$" expr)
 284                        (setq expr (substring expr (match-beginning 1) (match-end 1))))
 285                    (switch-to-buffer buf)
 286                    (re-search-backward
 287                     (concat "^" (regexp-quote expr) "$")
 288                     (- orig 10))
 289                    (goto-char (+ (match-beginning 0) column))
 290                    (setq end (+ (point) width)))
 291                  (setq err beg))
 292                 ((looking-at
 293                   "Toplevel input:\n>[.]*\\([^.].*\n\\)\\([>].*\n\\)*[>]\\(.*[^.]\\)[.]*\n")
 294                  (let* ((e1 (caml-match-string 1))
 295                         (e2 (caml-match-string 3))
 296                         (expr
 297                          (concat
 298                           (regexp-quote e1) "\\(.*\n\\)*" (regexp-quote e2))))
 299                    (switch-to-buffer buf)
 300                    (re-search-backward expr orig 'move)
 301                    (setq end (match-end 0)))
 302                  (setq err beg))
 303                 (t
 304                  (switch-to-buffer buf)))
 305           (setq arg (- arg 1))
 306           )
 307         (pop-to-buffer inferior-caml-buffer-name)
 308         (if err
 309             (goto-char (point-max))
 310           (goto-char previous-output)
 311           (goto-char (point-max)))
 312         (pop-to-buffer buf))
 313       (if err (progn (beep) (caml-overlay-region (point) end))
 314         (if inferior-caml-output
 315             (message "No error")
 316           (message "No output yet...")
 317           ))
 318       err)))
 319
 320 (defun caml-overlay-region (beg end &optional wait)
 321   (interactive "%r")
 322   (cond ((fboundp 'make-overlay)
 323          (if caml-error-overlay ()
 324            (setq caml-error-overlay (make-overlay 1 1))
 325            (overlay-put caml-error-overlay 'face 'region))
 326          (unwind-protect
 327              (progn
 328                (move-overlay caml-error-overlay beg end (current-buffer))
 329                (beep) (if wait (read-event) (caml-sit-for 60)))
 330            (delete-overlay caml-error-overlay)))))
 331
 332 ;; wait some amount for ouput, that is, until inferior-caml-output is set
 333 ;; to true. Hence, interleaves sitting for shorts delays and checking the
 334 ;; flag. Give up after some time. Typing into the source buffer will cancel
 335 ;; waiting, i.e. may report 'No result yet'
 336
 337 (defun caml-wait-output (&optional before after)
 338   (let ((c 1))
 339     (caml-sit-for 0 (or before 1))
 340     (let ((c 1))
 341       (while (and (not inferior-caml-output) (< c 99) (caml-sit-for 0 c t))
 342         (setq c (+ c 1))))
 343     (caml-sit-for (or after 0) 1)))
 344
 345 ;; To insert the last output from caml at point
 346 (defun caml-insert-last-output ()
 347   "Insert the result of the evaluation of previous phrase"
 348   (interactive)
 349   (let ((pos (process-mark (get-buffer-process inferior-caml-buffer-name))))
 350   (insert-buffer-substring inferior-caml-buffer-name
 351                            caml-previous-output (- pos 2))))
 352
 353 ;; additional bindings
 354
 355 ;(let ((map (lookup-key caml-mode-map [menu-bar caml])))
 356 ;  (define-key map [indent-buffer] '("Indent buffer" . caml-indent-buffer))
 357 ;  (define-key map [eval-buffer] '("Eval buffer" . caml-eval-buffer))
 358 ;)
 359 ;(define-key caml-mode-map "\C-c\C-b" 'caml-eval-buffer)
 360
 361
 362 (provide 'inf-caml)