diff options
| -rw-r--r-- | emacs/caml-emacs.el | 2 | ||||
| -rw-r--r-- | emacs/caml-help.el | 2 | ||||
| -rw-r--r-- | emacs/caml-types.el | 116 |
3 files changed, 78 insertions, 42 deletions
diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el index 01a575ebfb..571dd784cf 100644 --- a/emacs/caml-emacs.el +++ b/emacs/caml-emacs.el @@ -6,7 +6,7 @@ (defalias 'caml-line-beginning-position 'line-beginning-position) (defun caml-event-window (e) (posn-window (event-start e))) -(defun caml-event-point-start (e) (posn-point (event-stact 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-track-mouse 'track-mouse) (defalias 'caml-read-event 'read-event) diff --git a/emacs/caml-help.el b/emacs/caml-help.el index 69e5b1c9f4..d2a448b427 100644 --- a/emacs/caml-help.el +++ b/emacs/caml-help.el @@ -720,7 +720,7 @@ buffer positions." (defun ocaml-link-goto (click) (interactive "e") (let* ((pos (caml-event-point-start click)) - (buf (caml-event-window click)) + (buf (window-buffer (caml-event-window click))) (window (selected-window)) (link)) (setq link diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 01167b5896..77612eb770 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -71,6 +71,12 @@ For the moment, the only possible keyword is \"type\"." (if (not (face-differs-from-default-p 'caml-types-face)) (set-face-background 'caml-types-face "#88FF44")) +(make-face 'caml-typed-face) +(set-face-doc-string 'caml-typed-face + "face for hilighting typed expressions") +(if (not (face-differs-from-default-p 'caml-typed-face)) + (set-face-background 'caml-typed-face "#FF8844")) + (overlay-put caml-types-expr-ovl 'face 'caml-types-face) @@ -374,51 +380,81 @@ and its type is displayed in the minibuffer, until the move is released." target-pos Left Right limits cnum node mes type (tree caml-types-annotation-tree) + (unlocked font-lock-mode) + region ) (caml-types-preprocess type-file) (unless caml-types-buffer (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))) - ; (message "Drag the mouse to explore types") + ; (message "Drag the mouse to explore types") (unwind-protect (caml-track-mouse - (while (and event - (integer-or-marker-p - (setq cnum (caml-event-point-end event)))) - (if (and limits (>= cnum (car limits)) (< cnum (cdr limits))) - (message mes) - (setq target-bol - (save-excursion (goto-char cnum) - (caml-line-beginning-position))) - (setq target-line - (1+ (count-lines (point-min) target-bol))) - (setq target-pos (vector target-file target-line target-bol cnum)) - (save-excursion - (setq node (caml-types-find-location target-pos () tree)) - (set-buffer caml-types-buffer) - (erase-buffer) - (cond - (node - (setq Left (caml-types-get-pos target-buf (elt node 0))) - (setq 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)) - (setq 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 - tree)) - )) - (message (setq mes (format "type: %s" type))) - (insert type) - )) - (setq event (caml-read-event)) - (unless (mouse-movement-p event) (setq event nil)) - ) - ) - (delete-overlay caml-types-expr-ovl)) - )) + (setq region (caml-types-typed-region + target-buf + (caml-event-point-start event))) + (while (and event + (integer-or-marker-p + (setq cnum (caml-event-point-end event)))) + (if (and limits (>= cnum (car limits)) (< cnum (cdr limits))) + (message mes) + (setq target-bol + (save-excursion (goto-char cnum) + (caml-line-beginning-position))) + (setq target-line + (1+ (count-lines (point-min) target-bol))) + (setq target-pos (vector target-file target-line target-bol cnum)) + (save-excursion + (setq node (caml-types-find-location target-pos () tree)) + (set-buffer caml-types-buffer) + (erase-buffer) + (cond + (node + (setq Left (caml-types-get-pos target-buf (elt node 0))) + (setq 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)) + (setq 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 + tree)) + )) + (message (setq mes (format "type: %s" type))) + (insert type) + )) + (setq event (caml-read-event)) + (unless (mouse-movement-p event) (setq event nil)) + ) + ) + (delete-overlay caml-types-expr-ovl) + (if unlocked (font-lock-mode 1) + (remove-text-properties (car region) (cdr region) '(face))) + ))) + +(defun caml-types-typed-region (target-buf pos) + (interactive "p") + (if (functionp 'caml-find-phrase) + (save-excursion + (goto-char pos) + (setq start (caml-find-phrase)) + (setq end (point))) + (setq start (point-min)) + (setq end (point-max))) + (message "%S %S" start end) + (let (len node) + (setq len (length caml-types-annotation-tree)) + (if font-lock-mode (font-lock-mode 0)) + (while (> len 3) + (setq len (- len 1)) + (setq node (aref caml-types-annotation-tree len)) + (if (caml-types-pos-contains start end node) + (put-text-property + (caml-types-get-pos target-buf (elt node 0)) + (caml-types-get-pos target-buf (elt node 1)) + 'face 'caml-typed-face)))) + (cons start end)) (provide 'caml-types) |