cgit.sxemacs.org Git - packages/blob - xemacs-packages/ocaml/inf-caml.el.upstream

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