[nongnu] externals/caml 2f6c6ce 042/197: Changement du mode inf-caml

[Stefan Monnier]

branch: externals/caml
commit 2f6c6cede6795959974af53cd51a4e1e637f8854
Author: Didier Rémy <Didier.Remy@inria.fr>
Commit: Didier Rémy <Didier.Remy@inria.fr>

    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
---
 caml-help.el |  59 +++++++-----
 caml.el      |  64 ++++++++++--
 inf-caml.el  | 310 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 3 files changed, 374 insertions(+), 59 deletions(-)

diff --git a/caml-help.el b/caml-help.el
index 79e2116..e7df774 100644
--- a/caml-help.el
+++ b/caml-help.el
@@ -3,7 +3,7 @@
 ;; Didier Remy, November 2001.
 
 ;; This provides two functions completion and help
-;; look for ocaml-complete and ocaml-help
+;; look for caml-complete and caml-help
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -157,7 +157,7 @@ command. An entry may be an info module or a complete file 
name."
       (setq file (concat dir (ocaml-uncapitalize module) ".mli"))
       (message file)
       (save-window-excursion
-        (set-buffer (get-buffer-create "*ocaml-help*"))
+        (set-buffer (get-buffer-create "*caml-help*"))
         (if (and file (file-exists-p file))
             (progn
               (message "Scanning module %s" file)
@@ -194,7 +194,7 @@ command. An entry may be an info module or a complete file 
name."
         )))
   ocaml-visible-modules)
 
-;; Look for identifiers aroun poin
+;; Look for identifiers around point
 
 (defun ocaml-current-position ()
   "Return a pair (MODULE . ENTRY) such that point is above ENTRY and 
@@ -202,20 +202,21 @@ MODULE is the module preceeding ENTRY.
 
 Both are a pair of position (BEG . END) in the buffer and can be nil if
 undefined."
-  (let ((module) (entry))
-    (save-excursion
-      (backward-word 1)
-      (if (looking-at "\\([A-Z][A-Za-z0-9_]*\\)[.]")
-          (setq module (cons (match-beginning 1) (match-end 1)))
-        (if (looking-at "[a-z_][A-Za-z0-9_]*")
-            (progn
-              (setq entry (cons (match-beginning 0) (match-end 0)))
-              (backward-word 1)
-              (if (looking-at
-                   (concat "\\([A-Z][A-Za-z0-_]*\\)[.]"
-                           (regexp-quote (match-string 0))))
-                  (setq module (cons (match-beginning 1) (match-end 1)))))))
-      (cons module entry))))
+  (save-excursion
+    (let ((module) (entry))
+      (if (re-search-backward
+           "\\(\\<[A-Z][A-Za-z0-9_]*\\>\\.\\|[^.]\\)\\<[A-Za-z0-9_]*\\="
+           (- (point) 100) t)
+          (progn
+            (if (looking-at "\\<\\([A-Za-z_'][A-Za-z0-9_']*\\)\\>[.]")
+                (progn
+                  (setq module (cons (match-beginning 1) (match-end 1)))
+                  (goto-char (match-end 0))))
+            (if (looking-at "\\<\\([a-z_'][A-Za-z0-9_']*\\)\\>")
+                (progn (message "TROIS")
+                (setq entry (cons (match-beginning 1) (match-end 1)))))))
+      (cons module entry))
+    ))
 
 ;; completion around point
 
@@ -241,7 +242,7 @@ undefined."
         res)
       )))
 
-(defun ocaml-complete (arg)
+(defun caml-complete (arg)
   "Complete symbol define in libraries"
   (interactive "p")
   (let* ((module-entry (ocaml-current-position))
@@ -328,7 +329,7 @@ undefined."
             (string-match files "^ *$"))
         (message "No info file found: %s." (mapconcat 'identity files " "))
       (message "Scanning info files %s." files)
-      (set-buffer (get-buffer-create "*ocaml-help*"))
+      (set-buffer (get-buffer-create "*caml-help*"))
       (setq command
             (concat "gunzip -c -f " files
                 " | grep -e '" ocaml-info-section-regexp "'"))
@@ -395,14 +396,18 @@ current buffer using \\[ocaml-current-position]."
   (let ((info-section (assoc module (ocaml-info-alist))))
     (if info-section (info (cdr info-section))
       (ocaml-visible-modules)
-      (let* ((module-info (assoc module (ocaml-module-alist)))
+      (let* ((module-info
+              (or (assoc module (ocaml-module-alist))
+                  (and (file-exists-p
+                        (concat (ocaml-uncapitalize module) ".mli"))
+                       (ocaml-get-or-make-module module))))                  
              (location (cdadr module-info)))
         (cond
          (location
           (view-file (concat location (ocaml-uncapitalize module) ".mli"))
           (bury-buffer (current-buffer)))
          (info-section (error "Aborted"))
-         (t (error "No help for module %s" (car module)))))
+         (t (error "No help for module %s" module))))
       ))
   (if (stringp entry)
       (let ((here (point)))
@@ -417,13 +422,15 @@ current buffer using \\[ocaml-current-position]."
               (goto-char here)))))
   )
 
-(defun ocaml-help (arg)
+(defun caml-help (arg)
   (interactive "p")
   (let ((module) (entry))
     (cond
-     ((= arg 4)
-      (or (setq module
+     ((or (= arg 4))
+      (or (and
+           (setq module
                 (completing-read "Module: " ocaml-module-alist nil t))
+           (not (string-equal module "")))
           (error "Quit")))
      (t
       (if (= arg 0) (setq ocaml-visible-modules 'lazy))
@@ -455,8 +462,8 @@ current buffer using \\[ocaml-current-position]."
 
 (if (boundp 'caml-mode-map)
     (progn 
-      (define-key caml-mode-map [?\C-c?\C-h] 'ocaml-help)
-      (define-key caml-mode-map [?\C-c?\t] 'ocaml-complete)
+      (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
+      (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
       ))
 
 (provide 'caml-help)
diff --git a/caml.el b/caml.el
index 7be02ea..d97e625 100644
--- a/caml.el
+++ b/caml.el
@@ -476,17 +476,49 @@ have caml-electric-indent on, which see.")
   (interactive"r")
   (inferior-caml-eval-region start end))
 
-(defun caml-eval-phrase ()
-  "Send the current Caml phrase to the inferior Caml process."
-  (interactive)
-  (save-excursion
-    (let ((bounds (caml-mark-phrase)))
-    (inferior-caml-eval-region (car bounds) (cdr bounds)))))
+;; old version ---to be deleted later
+; 
+; (defun caml-eval-phrase ()
+;   "Send the current Caml phrase to the inferior Caml process."
+;   (interactive)
+;   (save-excursion
+;     (let ((bounds (caml-mark-phrase)))
+;     (inferior-caml-eval-region (car bounds) (cdr bounds)))))
+
+(defun 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")
+  (inferior-caml-eval-phrase arg min max))
+
+(defun caml-eval-buffer (arg)
+  "Evaluate the buffer from the beginning to the phrase under the point.
+With prefix arg, evaluate past the whole buffer, no stopping at
+the current point."
+  (interactive "p")
+  (let ((here (point)) ((error))
+    (goto-char (point-min))
+    (setq error
+          (caml-eval-phrase 500 (point-min) (if arg (point-max) here))))
+    (if error (set-mark (error)))
+    (goto-char here)))
 
 (defun caml-show-subshell ()
   (interactive)
   (inferior-caml-show-subshell))
 
+
 ;;; Imenu support
 (defun caml-show-imenu ()
   (interactive)
@@ -1580,10 +1612,22 @@ by |, insert one."
                              0)
                             abbrev-correct)))))))
 
-(defun caml-indent-phrase ()
-  (interactive "*")
-  (let ((bounds (caml-mark-phrase)))
-    (indent-region (car bounds) (cdr bounds) nil)))
+; (defun caml-indent-phrase ()
+;   (interactive "*")
+;   (let ((bounds (caml-mark-phrase)))
+;     (indent-region (car bounds) (cdr bounds) nil)))
+
+(defun caml-indent-phrase (arg)
+  (interactive "p")
+  (save-excursion
+    (let ((beg (caml-find-phrase)))
+    (while (progn (setq arg (- arg 1)) (> arg 0))
+      (caml-find-region))
+    (indent-region beg (point) nil))))
+
+(defun caml-indent-buffer ()
+  (interactive)
+  (indent-region (point-min) (point-max) nil))
 
 (defun caml-backward-to-less-indent (&optional n)
   "Move cursor back  N lines with less or same indentation."
diff --git a/inf-caml.el b/inf-caml.el
index 0eba00e..bbe084c 100644
--- a/inf-caml.el
+++ b/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)