Changement du mode inf-caml

 - principalement pour qu'il reporte les erreurs du toplevel comme il le fait
pour le mode compilé.

 - également pour pourvoir envoyé plusieurs phrases d'un coup avec préfix
arg, ou successivement (le curseur suit l'envoi des phrases).

Vous pouvez tester et me dire s'il y a des problèmes avec la sémantique
actuelle. En particulier caml-mark-phrase est remplace par caml-find-phrase
qui ne fonctionne pas pareille.

        Didier


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4066 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 287 insertions, 23 deletions

diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el
index 0eba00eebc..bbe084cc70 100644
--- a/emacs/inf-caml.el
+++ b/emacs/inf-caml.el
@@ -6,6 +6,17 @@
 
 (require 'comint)
 
+;; User modifiable variables
+
+;; Whether you want the output buffer to be diplayed when you send a phrase
+
+(defvar caml-display-when-eval nil
+  "*If true, display the inferior caml buffer when evaluating expressions.")
+
+
+;; End of User modifiable variables
+
+
 (defvar inferior-caml-mode-map nil)
 (if inferior-caml-mode-map nil
   (setq inferior-caml-mode-map
@@ -49,20 +60,62 @@ be sent from another buffer in Caml mode.
   (use-local-map inferior-caml-mode-map)
   (run-hooks 'inferior-caml-mode-hooks))
 
-(defun run-caml (cmd)
+
+(defconst inferior-caml-buffer-subname "inferior-caml")
+(defconst inferior-caml-buffer-name
+  (concat "*" inferior-caml-buffer-subname "*"))
+
+;; for compatibility with xemacs 
+
+(defun caml-sit-for (second &optional mili redisplay)
+   (if (and (boundp 'running-xemacs) running-xemacs)
+       (sit-for (if mili (+ second (* mili 0.001)) second) redisplay)
+     (sit-for second mili redisplay)))
+
+;; To show result of evaluation at toplevel
+
+(defvar inferior-caml-output nil)
+(defun inferior-caml-signal-output (s)
+  (if (string-match "[^ ]" s) (setq inferior-caml-output t)))
+
+(defun inferior-caml-mode-output-hook ()
+  (setq comint-output-filter-functions
+        (list (function inferior-caml-signal-output))))
+(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook)
+
+;; To launch ocaml whenever needed
+
+(defun caml-run-process-if-needed (&optional cmd)
+  (if (comint-check-proc inferior-caml-buffer-name) nil
+    (if (not cmd)
+        (if (comint-check-proc inferior-caml-buffer-name)
+            (setq cmd inferior-caml-program)
+          (setq cmd (read-from-minibuffer "Caml toplevel to run: "
+                                          inferior-caml-program))))
+    (setq inferior-caml-program cmd)
+    (let ((cmdlist (inferior-caml-args-to-list cmd))
+          (process-connection-type nil))
+      (set-buffer (apply (function make-comint)
+                         inferior-caml-buffer-subname
+                         (car cmdlist) nil (cdr cmdlist)))
+      (inferior-caml-mode)
+      (display-buffer inferior-caml-buffer-name)
+      t)
+    ))
+
+;; patched to from original run-caml sharing code with
+;;  caml-run-process-when-needed
+
+(defun run-caml (&optional cmd)
   "Run an inferior Caml process.
 Input and output via buffer `*inferior-caml*'."
-  (interactive (list (read-from-minibuffer "Caml command to run: "
-                                           inferior-caml-program)))
-  (setq inferior-caml-program cmd)
-  (if (not (comint-check-proc "*inferior-caml*"))
-      (let ((cmdlist (inferior-caml-args-to-list cmd))
-            (process-connection-type nil))
-        (set-buffer (apply (function make-comint)
-                           "inferior-caml" (car cmdlist) nil (cdr cmdlist)))
-        (inferior-caml-mode)))
-  (setq caml-shell-active t)
-  (inferior-caml-show-subshell))
+  (interactive
+   (list (if (not (comint-check-proc inferior-caml-buffer-name))
+	     (read-from-minibuffer "Caml toplevel to run: "
+				   inferior-caml-program))))
+  (caml-run-process-if-needed cmd)
+  (switch-to-buffer-other-window inferior-caml-buffer-name))
+
 
 (defun inferior-caml-args-to-list (string)
   (let ((where (string-match "[ \t]" string)))
@@ -79,25 +132,54 @@ Input and output via buffer `*inferior-caml*'."
 
 (defun inferior-caml-show-subshell ()
   (interactive)
-  (display-buffer "*inferior-caml*"))
+  (caml-run-process-if-needed)
+  (display-buffer inferior-caml-buffer-name)
+  ; Added by Didier to move the point of inferior-caml to end of buffer
+  (let ((buf (current-buffer))
+        (caml-buf  (get-buffer inferior-caml-buffer-name))
+        (count 0))
+    (while
+        (and (< count 4)
+             (not (equal (buffer-name (current-buffer))
+                         inferior-caml-buffer-name)))
+      (goto-next-window)
+      (setq count (+ count 1)))
+    (if  (equal (buffer-name (current-buffer))
+                inferior-caml-buffer-name)
+        (end-of-buffer))
+    (while
+        (> count 0)
+      (goto-previous-window)
+      (setq count (- count 1)))
+    )
+)
+
+;; patched by Didier to move cursor after evaluation 
 
 (defun inferior-caml-eval-region (start end)
   "Send the current region to the inferior Caml process."
-  (interactive"r")
-  (save-window-excursion
-    (if (not (bufferp (get-buffer "*inferior-caml*")))
-        (call-interactively 'run-caml)))
-  (comint-send-region "*inferior-caml*" start end)
-  (comint-send-string "*inferior-caml*" ";;\n")
-  (if (not (get-buffer-window "*inferior-caml*" t))
-      (display-buffer "*inferior-caml*")))
+  (interactive "r")
+  (save-excursion (caml-run-process-if-needed))
+  (save-excursion
+    (comint-send-region inferior-caml-buffer-name start end)
+    (goto-char end)
+    (skip-chars-backward " \t\n")
+    ;; normally, ";;" are part of the region
+    (if (not (and (>= (point) 2)
+		  (prog2 (backward-char 2) (looking-at ";;"))))
+	(comint-send-string inferior-caml-buffer-name ";;\n"))
+    ;; the user may not want to see the output buffer
+    (if caml-display-when-eval
+        (display-buffer inferior-caml-buffer-name t))))
+
+;; jump to errors produced by ocaml compiler
 
 (defun inferior-caml-goto-error (start end)
   "Jump to the location of the last error as indicated by inferior toplevel."
   (interactive "r")
   (let ((loc (+ start
                 (save-excursion
-                  (set-buffer (get-buffer "*inferior-caml*"))
+                  (set-buffer (get-buffer inferior-caml-buffer-name))
                   (re-search-backward
                    (concat comint-prompt-regexp
                            "[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$"))
@@ -105,6 +187,188 @@ Input and output via buffer `*inferior-caml*'."
     (goto-char loc)))
 
 
-;;; inf-caml.el ends here
+;;; orgininal inf-caml.el ended here
+
+;;; Additional commands by Didier to report errors in toplevel mode
+
+(defun caml-skip-blank-forward ()
+  (if (looking-at "[ \t\n]*\\((\\*\\([^*]\\|[^(]\\*[^)]\\)*\\*)[ \t\n]*\\)*")
+      (goto-char (match-end 0))))
+
+;; to mark phrases, so that repeated calls will take several of them
+;; knows little of Ocaml appar literals and comments, so it should work
+;; with other dialects as long as ;; marks the end of phrase. 
+
+(defun caml-find-phrase (&optional min-pos max-pos)
+  "Find the CAML phrase containing the point.
+Return the positin of the beginning of the phrase, and move point
+to the end.
+"
+  (interactive)
+  (while
+      (and (search-backward ";;" min-pos 'move)
+           (or (caml-in-literal-p)
+               (and caml-last-comment-start (caml-in-comment-p)))
+           ))
+  (if (looking-at ";;") (forward-char 2))
+  (caml-skip-blank-forward)
+  (let ((beg (point)))
+    (while
+        (and (search-forward ";;" max-pos 1)
+             (or (caml-in-literal-p)
+                 (and caml-last-comment-start (caml-in-comment-p)))
+             ))
+    (if (eobp) (newline))
+    beg))
+
+;; as eval-phrase, but ignores errors.
+
+(defun inferior-caml-just-eval-phrase (arg &optional min max)
+  "Send the phrase containing the point to the CAML process.
+With prefix-arg send as many phrases as its numeric value,
+ignoring possible errors during evaluation.
+
+Optional arguments min max defines a region within which the phrase
+should lies."
+  (interactive "p")
+  (let ((beg))
+    (while (> arg 0)
+      (setq arg (- arg 1))
+      (setq beg  (caml-find-phrase min max))
+      (caml-eval-region beg (point))
+      (comint-send-string inferior-caml-buffer-name "\n")
+      )
+    beg))
+
+(defvar caml-previous-output nil
+  "tells the beginning of output in the shell-output buffer, so that the
+output can be retreived later, asynchronously.")
+
+;; enriched version of eval-phrase, to repport errors.
+
+(defun inferior-caml-eval-phrase (arg &optional min max)
+  "Send the phrase containing the point to the CAML process.
+With prefix-arg send as many phrases as its numeric value, 
+If an error occurs during evalutaion, stop at this phrase and
+repport the error. 
+
+Return nil if noerror and position of error if any.
+
+If arg's numeric value is zero or negative, evaluate the current phrase
+or as many as prefix arg, ignoring evaluation errors. 
+This allows to jump other erroneous phrases. 
+
+Optional arguments min max defines a region within which the phrase
+should lies."
+  (interactive "p")
+  (if (save-excursion (caml-run-process-if-needed))
+      (progn
+        (setq inferior-caml-output nil)
+        (caml-wait-output 10 1)))
+  (if (< arg 1) (inferior-caml-just-eval-phrase (max 1 (- 0 arg)) min max)
+    (let ((proc (get-buffer-process inferior-caml-buffer-name))
+          (buf (current-buffer))
+          (previous-output) (orig) (beg) (end) (error))
+      (save-window-excursion
+        (while (and (> arg 0) (not error))
+          (setq previous-output (marker-position (process-mark proc)))
+          (setq caml-previous-output previous-output)
+          (setq inferior-caml-output nil)
+          (setq orig (inferior-caml-just-eval-phrase 1 min max))
+          (caml-wait-output)
+          (switch-to-buffer inferior-caml-buffer-name  nil)
+          (goto-char previous-output)
+          (cond ((re-search-forward
+                  " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]"
+                  (point-max) t)
+                 (setq beg (+ orig (string-to-int (caml-match-string 1))))
+                 (setq end (+ orig (string-to-int (caml-match-string 2))))
+                 (switch-to-buffer buf)
+                 (goto-char beg)
+                 (setq error beg)
+                 )
+                ((looking-at
+                  "Toplevel input:\n[>]\\([^\n]*\\)\n[>]\\(\\( *\\)^*\\)\n")
+                 (let ((expr (caml-match-string 1))
+                       (column (-   (match-end 3) (match-beginning 3)))
+                       (width (-   (match-end 2) (match-end 3))))
+                   (if (string-match  "^\\(.*\\)[<]EOF[>]$" expr)
+                       (setq expr (substring expr (match-beginning 1) (match-end 1))))
+                   (switch-to-buffer buf)
+                   (re-search-backward
+                    (concat "^" (regexp-quote expr) "$")
+                    (- orig 10))
+                   (goto-char (+ (match-beginning 0) column))
+                   (setq end (+ (point) width)))
+                 (setq error beg))
+                ((looking-at
+                  "Toplevel input:\n>[.]*\\([^.].*\n\\)\\([>].*\n\\)*[>]\\(.*[^.]\\)[.]*\n")
+                 (let* ((e1 (caml-match-string 1))
+                        (e2 (caml-match-string 3))
+                        (expr
+                         (concat
+                          (regexp-quote e1) "\\(.*\n\\)*" (regexp-quote e2))))
+                   (switch-to-buffer buf)
+                   (re-search-backward expr orig 'move)
+                   (setq end (match-end 0)))
+                 (setq error beg))
+                (t
+                 (switch-to-buffer buf)))
+          (setq arg (- arg 1))
+          )
+        (pop-to-buffer inferior-caml-buffer-name)
+        (if error
+            (goto-char (point-max))
+          (goto-char previous-output)
+          (goto-char (point-max)))
+        (pop-to-buffer buf))
+      (if error (progn (beep) (caml-overlay-region (point) end))
+        (if inferior-caml-output
+            (message "No error")
+          (message "No output yet...")
+          ))
+      error)))
+
+(defun caml-overlay-region (beg end &optional wait)
+  (interactive "%r")
+  (cond ((fboundp 'make-overlay)
+         (if caml-error-overlay ()
+           (setq caml-error-overlay (make-overlay 1 1))
+           (overlay-put caml-error-overlay 'face 'region))
+         (unwind-protect
+             (progn
+               (move-overlay caml-error-overlay beg end (current-buffer))
+               (beep) (if wait (read-event) (caml-sit-for 60)))
+           (delete-overlay caml-error-overlay)))))  
+
+;; wait some amount for ouput, that is, until inferior-caml-output is set
+;; to true. Hence, interleaves sitting for shorts delays and checking the
+;; flag. Give up after some time. Typing into the source buffer will cancel 
+;; waiting, i.e. may report 'No result yet' 
+
+(defun caml-wait-output (&optional before after)
+  (let ((c 1))
+    (caml-sit-for 0 (or before 1))
+    (let ((c 1))
+      (while (and (not inferior-caml-output) (< c 99) (caml-sit-for 0 c t))
+        (setq c (+ c 1))))
+    (caml-sit-for (or after 0) 1)))
+
+;; To insert the last output from caml at point
+(defun caml-insert-last-output ()
+  "Insert the result of the evaluation of previous phrase"
+  (interactive)
+  (let ((pos (process-mark (get-buffer-process inferior-caml-buffer-name))))
+  (insert-buffer-substring inferior-caml-buffer-name
+                           caml-previous-output (- pos 2))))
+
+;; additional bindings
+  
+(let ((map (lookup-key caml-mode-map [menu-bar caml])))
+  (define-key map [indent-buffer] '("Indent buffer" . caml-indent-buffer))
+  (define-key map [eval-buffer] '("Eval buffer" . caml-eval-buffer))
+) 
+(define-key caml-mode-map "\C-c\C-b" 'caml-eval-buffer)
+
 
 (provide 'inf-caml)