[nongnu] externals/caml 6f9f060 096/197: caml-types:

[Stefan Monnier]

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

    caml-types:
     - largest typed region is now dynamically recomputed.
     - changed binding to C-down-mouse-1 (allow other bindings).
     - allow scrolling when mouse is moved to bottom or top of window.
     - ignore key events, out of frame-motion, and wait for mouse release.
    
    
    git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5875 
f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 caml-emacs.el  |  19 ++++++-
 caml-types.el  | 174 ++++++++++++++++++++++++++++++++++++++-------------------
 caml-xemacs.el |  25 ++++++++-
 caml.el        |   5 +-
 4 files changed, 159 insertions(+), 64 deletions(-)

diff --git a/caml-emacs.el b/caml-emacs.el
index b212db6..5f35c24 100644
--- a/caml-emacs.el
+++ b/caml-emacs.el
@@ -5,10 +5,25 @@
 
 (defalias 'caml-line-beginning-position 'line-beginning-position)
 
+(defalias 'caml-read-event 'read-event)
+(defalias 'caml-window-edges 'window-edges)
+(defun caml-mouse-vertical-position ()
+  (cddr (mouse-position)))
+(defalias 'caml-ignore-event-p 'integer-or-marker-p)
+(defalias 'caml-mouse-movement-p 'mouse-movement-p)
+(defalias 'caml-sit-for 'sit-for)
+
+(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body))
+
 (defun caml-event-window (e) (posn-window (event-start e)))
 (defun caml-event-point-start (e) (posn-point (event-start e)))
 (defun caml-event-point-end (e) (posn-point (event-end e)))
-(defalias 'caml-read-event 'read-event)
-(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body))
+
+(defun caml-release-event-p (original event)
+  (and (equal (event-basic-type original) (event-basic-type event))
+       (let ((modifiers  (event-modifiers event)))
+         (or (member 'drag modifiers)
+             (member 'click modifiers)))))
+
 
 (provide 'caml-emacs)
diff --git a/caml-types.el b/caml-types.el
index 5955320..6a14d46 100644
--- a/caml-types.el
+++ b/caml-types.el
@@ -153,7 +153,7 @@ See `caml-types-location-re' for annotation file format.
              (not (window-live-p (get-buffer-window caml-types-buffer))))
         (display-buffer caml-types-buffer))
     (unwind-protect
-        (sit-for 60)
+        (caml-sit-for 60)
       (delete-overlay caml-types-expr-ovl)
       )))
 
@@ -388,11 +388,23 @@ See `caml-types-location-re' for annotation file format.
   (interactive "e")
   nil)
 
+(defun caml-types-time ()
+  (let ((time (current-time)))
+     (+ (* (mod (cadr time) 1000) 1000)
+                  (/ (cadr (cdr time)) 1000))))
+
 (defun caml-types-explore (event)
   "Explore type annotations by mouse dragging.
 
-The expression under the mouse is highlighted
-and its type is displayed in the minibuffer, until the move is released."
+The expression under the mouse is highlighted and its type is displayed 
+in the minibuffer, until the move is released, much as `caml-types-show-type'.
+The function uses two overlays. 
+
+ . One overlay delimits the largest region whose all subnodes 
+   are well-typed. 
+ . Another overlay delimits the current node under the mouse (whose type
+   annotation is beeing displayed).
+"
   (interactive "e")
   (set-buffer (window-buffer (caml-event-window event)))
   (let* ((target-buf (current-buffer))
@@ -403,8 +415,13 @@ and its type is displayed in the minibuffer, until the 
move is released."
          target-pos
          Left Right limits cnum node mes type
          region
+         (window (caml-event-window event))
          target-tree
+         (speed 100)
+         (last-time (caml-types-time))
+         (original-event event)
          )
+    (select-window window)
     (unwind-protect
         (progn
           (caml-types-preprocess type-file)
@@ -415,66 +432,111 @@ and its type is displayed in the minibuffer, until the 
move is released."
           ;; (message "Drag the mouse to explore types")
           (unwind-protect
               (caml-track-mouse
-               (setq region
-                     (caml-types-typed-make-overlay
-                      target-buf (caml-event-point-start event)))
-               (while (and event
-                           (integer-or-marker-p
-                            (setq cnum (caml-event-point-end event))))
-                 (if (and region (<= (car region) cnum) (< cnum (cdr region)))
-                     (if (and limits
-                              (>= cnum (car limits)) (< cnum (cdr limits)))
-                         (message mes)
-                       (setq target-bol
-                             (save-excursion
-                               (goto-char cnum) (caml-line-beginning-position))
-                             target-line (1+ (count-lines (point-min)
-                                                          target-bol))
-                             target-pos
-                             (vector target-file target-line target-bol cnum))
-                       (save-excursion
-                         (setq node (caml-types-find-location
-                                     target-pos () target-tree))
-                         (set-buffer caml-types-buffer)
-                         (erase-buffer)
-                         (cond
-                          (node
-                           (setq Left
-                                 (caml-types-get-pos target-buf (elt node 0))
-                                 Right
-                                 (caml-types-get-pos target-buf (elt node 1)))
-                           (move-overlay
-                            caml-types-expr-ovl Left Right target-buf)
-                           (setq limits
-                                 (caml-types-find-interval target-buf
-                                                           target-pos node)
-                                 type (elt node 2))
-                           )
-                          (t
-                           (delete-overlay caml-types-expr-ovl)
-                           (setq type "*no type information*")
-                           (setq limits
-                                 (caml-types-find-interval
-                                  target-buf target-pos target-tree))
-                           ))
-                         (message (setq mes (format "type: %s" type)))
-                         (insert type)
-                         )))
-                 (setq event (caml-read-event))
-                 (unless (mouse-movement-p event) (setq event nil))
+               (while event
+                 (message nil)
+                 (message "%S" event)
+                 (cond
+                  ;; In emacs eliminate 
+                  ((caml-ignore-event-p event))
+                  ((caml-release-event-p original-event event)
+                   (setq event nil))
+                  ((and (caml-mouse-movement-p event)
+                        (not (and (equal window (caml-event-window event))
+                                  (integer-or-marker-p
+                                   (caml-event-point-end event)))))
+                   (let* ((win (caml-window-edges window))
+                          (top (nth 1 win))
+                          (bottom (- (nth 3 win) 1))
+                          mouse
+                          time
+                          )
+                     (while (and
+                             (caml-sit-for 0 (/ 500 speed))
+                             (setq time (caml-types-time)) 
+                             (> (- time last-time) (/ 500 speed))
+                             (setq mouse (caml-mouse-vertical-position))
+                             (or (< mouse top) (>= mouse bottom))
+                             )
+                       (setq last-time time)
+                       (cond
+                        ((< mouse top)
+                         (setq speed (- top mouse))
+                         (condition-case nil
+                             (scroll-down 1)
+                           (error (message "Beginning of buffer!"))))
+                        ((>= mouse bottom)
+                         (setq speed (+ 1 (- mouse bottom)))
+                         (condition-case nil
+                             (scroll-up 1)
+                           (error (message "End of buffer!"))))
+                        )                         
+                       (setq speed (* speed speed))
+                       )))
+                  ((or (caml-mouse-movement-p event)
+                       (equal original-event event))
+                   (setq cnum (caml-event-point-end event))
+                   (if (and region
+                            (<= (car region) cnum) (< cnum (cdr region)))
+                       nil
+                     (setq region
+                           (caml-types-typed-make-overlay
+                            target-buf (caml-event-point-start event))))
+                   (if (and limits
+                            (>= cnum (car limits)) (< cnum (cdr limits)))
+                       (message mes)
+                     (setq target-bol
+                           (save-excursion
+                             (goto-char cnum) (caml-line-beginning-position))
+                           target-line (1+ (count-lines (point-min)
+                                                        target-bol))
+                           target-pos
+                           (vector target-file target-line target-bol cnum))
+                     (save-excursion
+                       (setq node (caml-types-find-location
+                                   target-pos () target-tree))
+                       (set-buffer caml-types-buffer)
+                       (erase-buffer)
+                       (cond
+                        (node
+                         (setq Left
+                               (caml-types-get-pos target-buf (elt node 0))
+                               Right
+                               (caml-types-get-pos target-buf (elt node 1)))
+                         (move-overlay
+                          caml-types-expr-ovl Left Right target-buf)
+                         (setq limits
+                               (caml-types-find-interval target-buf
+                                                         target-pos node)
+                               type (elt node 2))
+                         )
+                        (t
+                         (delete-overlay caml-types-expr-ovl)
+                         (setq type "*no type information*")
+                         (setq limits
+                               (caml-types-find-interval
+                                target-buf target-pos target-tree))
+                         ))
+                       ;; (message (setq mes (format "type: %s" type)))
+                       (insert type)
+                       ))
+                   )
+                  )
+                 (if event (setq event (caml-read-event)))
                  )
                )
             (delete-overlay caml-types-expr-ovl)
             (delete-overlay caml-types-typed-ovl)
             ))
-      ;; the mouse is down. One should prevent against mouse release,
-      ;; which could do something undesirable.
-      ;; In most common cases, next event will be mouse release.
+      ;; When an error occurs, the mouse release event has not been read.
+      ;; We could wait for mouse release to prevent execution of
+      ;; a binding of mouse release, such as cut or paste.
+      ;; In most common cases, next event will be the mouse release.
       ;; However, it could also be a key stroke before mouse release.
-      ;; Will then execute the action for mouse release (if bound).
       ;; Emacs does not allow to test whether mouse is up or down.
-      ;; Same problem may happen above while exploring
-      (if (and event (caml-read-event)))
+      ;; Not sure it is robust to loop for mouse release after an error
+      ;; occured, as is done for exploration. 
+      ;; So far, we just ignore next event. (Next line also be uncommenting.)
+      (if event (caml-read-event))
       )))
 
 (defun caml-types-typed-make-overlay (target-buf pos)
diff --git a/caml-xemacs.el b/caml-xemacs.el
index b1b01bd..ff49391 100644
--- a/caml-xemacs.el
+++ b/caml-xemacs.el
@@ -9,12 +9,31 @@
 (defun caml-line-beginning-position ()
   (save-excursion (beginning-of-line) (point)))
 
-(defun caml-event-window (e) (event-window e))
+(defalias 'caml-read-event 'next-event)
+(defalias 'caml-window-edges 'window-pixel-edges)
+(defun caml-mouse-vertical-position ()
+  (let ((e  (mouse-position-as-motion-event)))
+    (and e (event-y-pixel e))))
+(defalias 'caml-mouse-movement-p 'motion-event-p)
+(defun caml-event-window (e)
+  (and (mouse-event-p e) (event-window e)))
 (defun caml-event-point-start (e) (event-closest-point e))
 (defun caml-event-point-end (e) (event-closest-point e))
-(defalias 'caml-read-event 'next-event)
+(defun caml-ignore-event-p (e)
+  (if (and (key-press-event-p e) (equal (key-binding e) 'keyboard-quit))
+      (keyboard-quit))
+  (not (mouse-event-p e)))
+
+
+(defun caml-sit-for (sec &optional mili)
+  (sit-for (+ sec (if mili (* 0.001 mili)))))
+                  
+
+
 (defmacro caml-track-mouse (&rest body) (cons 'progn body))
 
-(defun mouse-movement-p (e) (equal (event-type e) 'motion))
+(defun caml-release-event-p (original event)
+  (and (button-release-event-p event)
+       (equal (event-button original) (event-button event))))
 
 (provide 'caml-xemacs)
diff --git a/caml.el b/caml.el
index 74ad373..8e6da6a 100644
--- a/caml.el
+++ b/caml.el
@@ -283,9 +283,8 @@ have caml-electric-indent on, which see.")
 
   ;; caml-types
   (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
-  ;; to prevent misbehavior in case of error during exploration.
-  (define-key caml-mode-map [mouse-2] 'caml-types-mouse-ignore)
-  (define-key caml-mode-map [down-mouse-2] 'caml-types-explore)
+  ;; must be a mouse-down event. Can be any button and any prefix
+  (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore)
   ;; caml-help
   (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
   (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)