org-mouse.el --- Better mouse support for org-mode (version 0.05)

[Piotr Zielinski]

;;; org-mouse.el --- Better mouse support for org-mode

;; Copyright (c) 2006 Piotr Zielinski
;;
;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com>
;; Version: 0.05
;; $Id: org-mouse.el 31 2006-02-06 14:44:01Z pz215 $
;;
;; The latest version of this file is available from
;;
;; http://www.cl.cam.ac.uk/~pz215/files/org-mouse.el
;;
;; This file is *NOT* part of GNU Emacs.
;; This file is distributed under the same terms as GNU Emacs.

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.  See the GNU General Public License for more details.

;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
;; MA 02111-1307 USA

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Org-mouse provides better mouse support for org-mode.  Org-mode is
;; a mode for keeping notes, maintaining ToDo lists, and doing project
;; planning with a fast and effective plain-text system.  It is
;; available from
;;
;; http://staff.science.uva.nl/~dominik/Tools/org/
;;
;; Org-mouse implements the following features:
;; + following links with the left mouse button (in Emacs 22)
;; + subtree expansion/collapse (org-cycle) with the left mouse button
;; + several context menus
;; + date/time extraction from selected text (requires a python script)
;;   (eg. select text from your email and click "Add Appointment")
;;
;; The python script that automatically extracts date/time information
;; from a piece of English text is available from:
;;
;; http://www.cl.cam.ac.uk/~pz215/files/timeparser.py
;;
;; Use
;; ------------
;;
;; To use this package, put the following line in your .emacs:
;;
;;    (require 'org-mouse)
;;
;; Tested with Emacs 22.0.50, org-mode 4.03

;; Fixme:
;; + inserting text to a folded part

;; To do:

;; + The "New Appointment" menu entry seems out of place.  Remove it
;;   and enhance the time/data selection function so that if the text
;;   in the clipboard contains a date/time, then set that date as the
;;   default (instead of "today")

;; + org-store-link, insert link
;; + org tables
;; + occur with the current word/tag (same menu item)
;; + ctrl-c ctrl-c, for example, renumber the current list
;; + internal links
;; + copy/cut external link
;; + move headlines with a mouse


(defun org-mouse-re-search-line (regexp)
  (beginning-of-line)
  (re-search-forward regexp (point-at-eol) t))

(defun org-mouse-end-headline ()
  "Go to the end of current headline (ignoring tags)."
  (interactive)
  (end-of-line)
  (skip-chars-backward "\t ")
  (when (looking-back ":[A-Za-z]+:")
    (skip-chars-backward ":A-Za-z")
    (skip-chars-backward "\t ")))


(defun org-mouse-show-context-menu (event prefix)
  (interactive "@e \nP")
  (if (and (= (event-click-count event) 1)
           (or (not mark-active)
               (sit-for (/ double-click-time 1000.0))))
      (progn
        (select-window (posn-window (event-start event)))
        (goto-char (posn-point (event-start event)))
        (let ((redisplay-dont-pause t))
          (sit-for 0))
        (if (functionp org-mouse-context-menu-function)
            (funcall org-mouse-context-menu-function)
          (mouse-major-mode-menu event prefix))
        )
    (setq this-command 'mouse-save-then-kill)
    (mouse-save-then-kill event)))


(defun org-mouse-insert-heading ()
  "Insert a new headline before the current line."
  (interactive)
  (beginning-of-line)
  (org-insert-heading))

(defun org-mouse-new-appointment ()
  (interactive)
  (org-mouse-insert-heading)
  (save-excursion
    (call-process "timeparser.py" nil t nil
                  (format "%s" (current-kill 0)))
    (backward-delete-char 1)))

(defun org-mouse-activate-headlines (limit)
  "Run through the buffer and add overlays to *** in headlines."
  (if (re-search-forward outline-regexp limit t)
      (progn
        (add-text-properties (match-beginning 0) (match-end 0)
                             (list 'mouse-face 'highlight
                                   'keymap org-mouse-map))
        t)))

(defun org-mouse-at-headline-head ()
  (save-excursion
    (let ((point (point)))
      (beginning-of-line)
      (and (looking-at outline-regexp)
           (< point (match-end 0))))))

(defun org-mouse-at-headline ()         ;todo: replace with org-on-heading-p??
  (save-excursion
    (beginning-of-line)
    (looking-at outline-regexp)))

(defun org-mouse-at-headline-tail ()
  (save-excursion
             (let ((point (point)))
               (beginning-of-line)
               (and (looking-at outline-regexp)
                    (>= point (match-end 0))))))

(defun org-mouse-timestamp-today (&optional shift units)
  (interactive)
  (flet ((org-read-date (x &optional y) (current-time)))
     (org-time-stamp nil))
  (when shift
    (org-timestamp-change shift units)))

(defun org-mouse-realign-tags ()
  )

;; (defun org-mouse-priority-set (priority)
;;   (replace-match priority t t nil 1))


(defun org-mouse-keyword-menu (keywords function selected &optional
itemformat)
  (mapcar
   (lambda (keyword)
     (vector (if itemformat (format itemformat keyword) keyword)
             `(funcall ,function ,keyword)
             :style (if (functionp selected) 'toggle 'radio)
             :selected `(if (functionp ,selected)
                            (funcall ,selected ,keyword)
                          (equal ,selected ,keyword))))
    keywords))

(defun org-mouse-keyword-replace-menu (keywords &optional group
itemformat)
  (setq group (or group 0))
  (append
   (org-mouse-keyword-menu
    keywords
    `(lambda (keyword) (replace-match keyword t t nil ,group))
    `(match-string ,group)
    itemformat)
   '(["None"
      (progn
        (replace-match "")
        (when (equal (char-after) ?\ ) (delete-char 1)))])))

(defvar org-mouse-context-menu-function nil)
(make-variable-buffer-local 'org-mouse-context-menu-function)

(defun org-mouse-show-headlines ()
  (interactive)
  (let ((this-command 'org-cycle)
        (last-command 'org-cycle)
        (org-cycle-global-status nil))
    (org-cycle '(4))
    (org-cycle '(4))))

(defun org-mouse-show-overview ()
  (interactive)
  (let ((org-cycle-global-status nil))
    (org-cycle '(4))))

(defun org-mouse-set-priority (priority)
  (flet ((read-char-exclusive () priority))
    (org-priority)))

(defvar org-mouse-priority-regexp "\\[#\\([A-Z]\\)\\]"
  "Regular expression matching the priority indicator.  Differs from
`org-priority-regexp' in that it doesn't contain the leading '.*?'.")


(defun org-mouse-get-priority (&optional default)
  (save-excursion
    (if (org-mouse-re-search-line org-mouse-priority-regexp)
        (match-string 1)
      (when default (char-to-string org-default-priority)))))


(setq org-mouse-global-menu
  '(nil
       ["Show Overview" org-mouse-show-overview t]
       ["Show Headlines" org-mouse-show-headlines t]
       ["Show All" show-all t]
       "--"
       ["Check TODOs" org-show-todo-tree t]
       ["Check Deadlines" org-check-deadlines t]
       ["Check Tags ..." org-tags-sparse-tree t]
       ["Check Phrase ..." org-occur]
       "--"
       ["Display Agenda" org-agenda-list t]
       ["Display Timeline" org-timeline t]
       ["Display TODO List" org-todo-list t]
       ["Display Calendar" org-goto-calendar t]
       "--"
       ["Jump" org-goto]))

(defun org-mouse-at-link ()
  (save-excursion
    (let ((pos (point)))
      (skip-chars-backward
       (concat (if org-allow-space-in-links "^" "^ ")
               org-non-link-chars))
      (or (looking-at org-link-regexp)
          (and (re-search-forward org-link-regexp (point-at-eol) t)
               (<= (match-beginning 0) pos)
               (>= (match-end 0) pos))))))

(defun org-mouse-delete-timestamp ()
  "Deletes the current timestamp as well as the preceding
SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
  (when (or (org-at-date-range-p) (org-at-timestamp-p))
    (replace-match "")                  ; delete the timestamp
    (skip-chars-backward " :A-Z")
    (when (looking-at " *[A-Z][A-Z]+:")
      (replace-match ""))))

(defun org-mouse-looking-at (regexp skipchars &optional movechars)
  (save-excursion
    (let ((point (point)))
      (if (looking-at regexp) t
        (skip-chars-backward skipchars)
        (forward-char (or movechars 0))
        (when (looking-at regexp)
          (> (match-end 0) point))))))


(defun org-mouse-priority-list ()
  (let ((ret) (current org-lowest-priority))
    (while (>= current ?A)
      (push (char-to-string current) ret)
      (decf current))
    ret))

(defun org-mouse-tag-menu ()            ;todo
  (append
   (let ((tags (split-string (org-get-tags) ":" t)))
     (org-mouse-keyword-menu
      (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
      `(lambda (tag)
         (org-mouse-set-tags
          (sort (if (member tag (quote ,tags))
                    (delete tag (quote ,tags))
                  (cons tag (quote ,tags)))
                'string-lessp)))
      `(lambda (tag) (member tag (quote ,tags)))
      ))
   '("--"
     ["Align Tags Here" (org-set-tags nil t) t]
     ["Align Tags in Buffer" (org-set-tags t t) t]
     ["Set Tags ..." (org-set-tags) t])))



(defun org-mouse-set-tags (tags)
  (save-excursion
    ;; remove existing tags first
    (beginning-of-line)
    (when (org-mouse-re-search-line ":\\(\\([A-Za-z_]+:\\)+\\)")
      (replace-match ""))

    ;; set new tags if any
    (when tags
      (end-of-line)
      (insert " :" (mapconcat 'identity tags ":") ":")
      (org-set-tags nil t))))


(defun org-mouse-context-menu ()
  (let ((stamp-prefixes (list org-deadline-string
org-scheduled-string)))
  (cond
   ((eolp)
    (popup-menu org-mouse-global-menu))
   ((and (org-mouse-looking-at "\\b\\w+" "a-zA-Z0-9_")
         (member (match-string 0) org-todo-keywords))
    (popup-menu
     `(nil
       ,@(org-mouse-keyword-replace-menu org-todo-keywords)
       "--"
       ["Check TODOs" org-show-todo-tree t]
       ["Display TODO List" org-todo-list t]
       )))
   ((and (org-mouse-looking-at "\\b[A-Z]+:" "A-Z")
         (member (match-string 0) stamp-prefixes))
    (popup-menu
     `(nil
       ,@(org-mouse-keyword-replace-menu stamp-prefixes)
       "--"
       ["Check Deadlines" org-check-deadlines t]
       )))
   ((org-mouse-looking-at org-mouse-priority-regexp "[]A-Z#") ;
priority
    (popup-menu `(nil ,@(org-mouse-keyword-replace-menu
                         (org-mouse-priority-list) 1 "Priority %s"))))
   ((org-mouse-at-link)
    (popup-menu
     '(nil
       ["Open" org-open-at-point t]
       ["Open in Emacs" (org-open-at-point t) t]
       ;;       ["Copy link" todo]
       )))
   ((org-mouse-looking-at ":\\([A-Za-z0-9_]+\\):" "A-Za-z0-9_" -1)
;tags
    (popup-menu
     `(nil
       [,(format "Display '%s'" (match-string 1))
        (org-tags-view nil ,(match-string 1))]
       [,(format "Narrow to '%s'" (match-string 1))
        (org-tags-sparse-tree nil ,(match-string 1))]
       "--"
       ,@(org-mouse-tag-menu))))
   ((org-at-timestamp-p)
    (popup-menu
     '(nil
       ["Show Day" org-open-at-point t]
       ["Change Timestamp" org-time-stamp t]
       ["Delete Timestamp" (org-mouse-delete-timestamp) t]
       ["Compute Time Range" org-evaluate-time-range
(org-at-date-range-p)]
       "--"
       ["Set for Today" org-mouse-timestamp-today]
       ["Set for Tomorrow" (org-mouse-timestamp-today 1 'day)]
       ["Set in 1 Week" (org-mouse-timestamp-today 7 'day)]
       ["Set in 2 Weeks" (org-mouse-timestamp-today 14 'day)]
       ["Set in a Month" (org-mouse-timestamp-today 1 'month)])))
   ((and (org-mouse-at-headline) (not (eolp)))
    (let ((priority (org-mouse-get-priority t)))
      (message "%S" priority)
      (popup-menu
       `(nil
         ("Tags and Priorities"
          ,@(org-mouse-keyword-menu
             (org-mouse-priority-list)
             '(lambda (keyword)
                (org-mouse-set-priority (string-to-char keyword)))
             priority "Priority %s")
          "--"
          ,@(org-mouse-tag-menu))
         "--"
         ["New Heading" org-mouse-insert-heading t]
         ["New Appointment" org-mouse-new-appointment t]
         "--"
         ["Cycle TODO" org-todo]
         ["Set Deadline"
          (progn (org-mouse-end-headline) (insert " ") (org-deadline))
          :active (not (org-mouse-re-search-line org-deadline-regexp))]
         ["Schedule Task"
          (progn (org-mouse-end-headline) (insert " ") (org-schedule))
          :active (not (org-mouse-re-search-line org-scheduled-regexp))]
         ["Insert Timestamp"
          (progn (org-mouse-end-headline) (insert " ") (org-time-stamp)) t]
;        ["Timestamp (inactive)" org-time-stamp-inactive t]
         "--"
         ["Archive Subtree" org-archive-subtree]
         ["Cut Subtree"  org-cut-special]
         ["Copy Subtree"  org-copy-special]
         ["Paste Subtree"  org-paste-special]
         "--"
         ["Promote Heading" org-metaleft]
         ["Promote Subtree" org-shiftmetaleft]
         ["Demote Heading"  org-metaright]
         ["Demote Subtree"  org-shiftmetaright]
         ))))
   (t
    (popup-menu org-mouse-global-menu)))))


;; (defun org-mouse-at-regexp (regexp)
;;   (save-excursion
;;     (let ((point (point))
;;        (bol (progn (beginning-of-line) (point)))
;;        (eol (progn (end-of-line) (point))))
;;       (goto-char point)
;;       (re-search-backward regexp bol 1)
;;       (and (not (eolp))
;;         (progn (forward-char)
;;                (re-search-forward regexp eol t))
;;         (<= (match-beginning 0) point)))))

(defun org-mouse-in-region-p (pos)
  (and mark-active (>= pos (region-beginning)) (<  pos (region-end))))

(defun org-mouse-down-mouse (event)
  (interactive "e")
  (setq this-command last-command)
  (unless (and transient-mark-mode
               (= 1 (event-click-count event))
               (org-mouse-in-region-p (posn-point (event-start event))))
    (mouse-drag-region event)))

(add-hook 'org-mode-hook
  '(lambda ()
     (setq org-mouse-context-menu-function 'org-mouse-context-menu)

     (define-key org-mouse-map [follow-link] 'mouse-face)
     (define-key org-mouse-map (if org-xemacs-p [button3] [mouse-3])
nil)
     (define-key org-mode-map [mouse-3] 'org-mouse-show-context-menu)
     (define-key org-mode-map [down-mouse-1] 'org-mouse-down-mouse)

     (font-lock-add-keywords nil
        '((org-mouse-activate-headlines  (0 'org-link 'prepend))) t)

     (defadvice org-open-at-point (around org-mouse-open-at-point
activate)
       (if (org-mouse-at-headline-head)
           (org-cycle)
         ad-do-it))))

(add-hook 'org-agenda-mode-hook
   '(lambda ()
      (define-key org-agenda-keymap [follow-link] 'mouse-face)
      (define-key org-agenda-keymap
        (if org-xemacs-p [button3] [mouse-3]) 'org-mouse-show-context-menu)))

(provide 'org-mouse)