;;; ipa.el --- In-place annotations

;; Copyright (C) 2007  Tamas Patrovics

;; This file 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, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; With this package you can add annotations to your files without
;;; modifying them. Each file can have multiple annotations at various
;;; buffer positions. The annotation texts are not parts of the files,
;;; they are stored separately.
;;; All annotations are stored in a common file, so searching
;;; annotations is trivial.
;;; Installation:
;;;   (require 'ipa)
;;; The following commands can be used:
;;;   ipa-insert   - insert annotation at point
;;;   ipa-edit     - edit the first annotation after point
;;;                  (with universal argument: before point)
;;;   ipa-next     - goes to the next annotation in the buffer
;;;   ipa-previous - goes to the previous annotation in the buffer
;;;   ipa-move     - move the first annotation after point
;;;                  (with universal argument: before point)
;;;   ipa-toggle   - hide/show annotations
;;;   ipa-show     - show all saved annotations for the current file
;;;                  (in the storage buffer you can press Enter on any 
;;;                   annotation to go to its location)
;;;   ipa-jump     - jump to any annotation with id completion
;;;                  Annotations can optionally have ids in their
;;;                  text with the following format: [id]annotation-text
;;;                  The id itself doesn't appear in the annotated
;;;                  buffer. It only serves the purpose of giving a
;;;                  unique id to the annotation, so that you can jump
;;;                  to it quickly.
;;;                  If an annotation has an id, but no other text
;;;                  then it is effectively the same as a usual
;;;                  bookmark in emacs.
;;;                  Only annotations appearing in `ipa-file' can be
;;;                  jumped to, so unsaved annotations does not count.
;;;                  If there are more annotations defined with the
;;;                  same id then the first one found in `ipa-file' is
;;;                  used.
;;; Annotations are saved when the file itself is saved. If the file
;;; is not modified annotations are saved immediately when
;;; added/changed.

;; Tested on Emacs 22.

;;; Code:

;; User configuration

(defvar ipa-file "~/.ipa"
  "File where annotations are stored, but see also

(defvar ipa-file-function 'ipa-get-global-file
  "Function to get the name of the annotation storage file. By
  default it returns `ipa-file', but it can be used, for example,
  to use different storage files in each directory. See

(defvar ipa-context-size 16
  "Length of before and after context of annotation position in
  characters used to reposition the annotation if the annotated
  file is changed behind Emacs's back.")

(defvar ipa-annotation-face 'highlight
  "Face for annotations.")

(defvar ipa-file-face 'header-line
  "Face for header lines in the IpA buffer.")


(defvar ipa-annotations-in-buffer nil)

(make-variable-buffer-local 'ipa-annotations-in-buffer)

(defvar ipa-annotation-display t)

(defconst ipa-line-continuation "|")

(defconst ipa-file-marker "\f")

(defconst ipa-file-regexp (concat "^" ipa-file-marker "\\s-*"))

(defconst ipa-annotation-id-regexp "\\s-*\\[\\(.+\\)?\\]\\(.*\\)")

(defvar ipa-pos-info-face '(face nil invisible t))

(defvar ipa-font-lock-keywords `((,(concat ipa-file-regexp
                                           "\\(.*\\)\n") . ipa-file-face)
                                 ("^|" . (0 ipa-annotation-face t))
                                 (ipa-font-lock-pos-info .
                                  ((1 ipa-pos-info-face t)
                                   (2 ipa-annotation-face t)))))

(define-derived-mode ipa-mode fundamental-mode "IPA"
  (set (make-local-variable 'font-lock-defaults) '(ipa-font-lock-keywords)))

(define-key ipa-mode-map (kbd "<return>") 'ipa-go-to-annotation)

(defvar ipa-overriding-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "<left>") 'ipa-move-left)
    (define-key map (kbd "<right>") 'ipa-move-right)
    (define-key map (kbd "<up>") 'ipa-move-line-up)
    (define-key map (kbd "<down>") 'ipa-move-line-down)
    (define-key map (kbd "<prior>") 'ipa-move-page-up)
    (define-key map (kbd "<next>") 'ipa-move-page-down)
    (define-key map (kbd "<return>") 'ipa-move-finish)
    (define-key map (kbd "<escape>") 'ipa-move-cancel)
    (define-key map (kbd "h") 'ipa-move-help)

(defvar ipa-old-global-map nil)

(defvar ipa-overlay-being-moved nil)

(defvar ipa-original-position-of-overlay-being-moved nil)

(defun ipa-insert ()
 (unless ipa-annotation-display

 (let ((text (read-string "text: ")))
   (if (equal text  "")
       (message "Empty annotations are not inserted.")
     (ipa-create-overlay (point) text)

     (if (ipa-get-buffer-file-name)

       (message "Annotations in this buffer will be saved only if you save the buffer as a file.")))))

(defun ipa-edit (&optional arg)
 (interactive "P")
 (unless ipa-annotation-display

 (let ((annotation (if arg
   (if annotation
       (let* ((text (read-string "text (empty to remove): " (cdr  annotation))))
         (if (equal text "")
               (delete-overlay (car annotation))
               (setq ipa-annotations-in-buffer
                     (delq annotation ipa-annotations-in-buffer))
               (message "Deleted annotation."))

           (ipa-set-overlay-text (car annotation) text)
           (setcdr annotation text)
           (message "Updated annotation."))

         (ipa-save-annotations-if-necessary t)))))

(defun ipa-move (&optional arg)
 (interactive "P")
 (unless ipa-annotation-display

 (let ((annotation (if arg
   (when annotation
     (setq ipa-overlay-being-moved (car annotation))
     (setq ipa-original-position-of-overlay-being-moved
           (overlay-start ipa-overlay-being-moved))
     (setq ipa-old-global-map global-map)
     (use-global-map ipa-overriding-map)
     (setq overriding-terminal-local-map ipa-overriding-map)
     (add-hook 'post-command-hook 'ipa-show-help))))

(defun ipa-show-help ()
  (message (substitute-command-keys
            (concat "Press \\[ipa-move-help] for help, "
                    "\\[ipa-move-cancel] to cancel."))))

(defun ipa-move-cancel ()
  (goto-char ipa-original-position-of-overlay-being-moved)
  (move-overlay ipa-overlay-being-moved (point) (point))
  (message "Moving of annotation is canceled."))

(defun ipa-move-help ()
  (tooltip-show (substitute-command-keys "\\{ipa-overriding-map}")))

(defun ipa-move-finish ()

(defun ipa-cleanup ()
  (use-global-map ipa-old-global-map)
  (setq overriding-terminal-local-map nil)
  (remove-hook 'post-command-hook 'ipa-show-help))

(defun ipa-move-left ()
  (ipa-move-overlay 'backward-char))

(defun ipa-move-right ()
  (ipa-move-overlay 'forward-char))

(defun ipa-move-line-up ()
  (ipa-move-overlay 'previous-line))

(defun ipa-move-line-down ()
  (ipa-move-overlay 'next-line))

(defun ipa-move-page-up ()
  (ipa-move-overlay 'scroll-down))

(defun ipa-move-page-down ()
  (ipa-move-overlay 'scroll-up))

(defun ipa-move-overlay (movefunc)
  (condition-case nil
      (funcall movefunc)
    (beginning-of-buffer (goto-char (point-min)))
    (end-of-buffer (goto-char (point-max))))

  (move-overlay ipa-overlay-being-moved (point) (point)))

(defun ipa-next ()
  (unless ipa-annotation-display

  (let ((annotations ipa-annotations-in-buffer)
    (while (and annotations
                (not annotation))
      (if (> (overlay-start (car (car annotations))) (point))
          (setq annotation (car annotations))
        (pop annotations)))

    (if (not annotation)
        (message "No annotations found after point.")

      (goto-char (overlay-start (car annotation)))
      (ipa-warn-if-annotation-is-empty (car annotation)))


(defun ipa-previous ()
  (unless ipa-annotation-display

  (let ((annotations ipa-annotations-in-buffer)
        (continue t)
    (while (and annotations continue)
      (if (> (overlay-start (car (car annotations))) (point))
          (setq continue nil)
        (setq annotation (pop annotations))))

    (if (not annotation)
        (message "No annotations found before point.")

      (goto-char (1- (overlay-start (car annotation))))
      (ipa-warn-if-annotation-is-empty (car annotation)))


(defun ipa-warn-if-annotation-is-empty (overlay)
  (if (equal (overlay-get overlay 'before-string) "")
      (message "The text of this annotation is empty.")))

(defun ipa-toggle (&optional arg)
    (interactive "P")
    (setq ipa-annotation-display (if arg
                                     (> (prefix-numeric-value arg) 0)
                                   (not ipa-annotation-display)))    
    (if ipa-annotation-display
        (dolist (buffer (buffer-list))
          (with-current-buffer buffer
            (dolist (annotation ipa-annotations-in-buffer)
              (ipa-set-overlay-text (car annotation) (cdr annotation))
              (message "Annotations are shown."))))

      (dolist (buffer (buffer-list))
        (with-current-buffer buffer
          (dolist (annotation ipa-annotations-in-buffer)
            (ipa-set-overlay-text (car annotation) "")
            (message "Annotations are hidden."))))))

(defun ipa-show ()
  (if (not (ipa-get-buffer-file-name))
      (message "This buffer has no associated file.")

    (let ((filename (ipa-get-buffer-file-name)))
      (with-current-buffer (ipa-find-storage-file)
        (goto-char (point-min))
        (if (re-search-forward (concat ipa-file-regexp
                                       filename "\n")
                               nil t)
            (switch-to-buffer (current-buffer))

          (message "No annotations found for file."))))))

(defun ipa-save-annotations-in-buffer (&optional even-if-empty)
  (when (or ipa-annotations-in-buffer
    (let ((filename (ipa-get-buffer-file-name))
          (buffer (current-buffer))
          (annotations ipa-annotations-in-buffer))
      (with-current-buffer (ipa-find-storage-file)
          (goto-char (point-min))
          (unless (re-search-forward (concat ipa-file-regexp
                                             filename "\n")
                                     nil t)
            (goto-char (point-max))
            (insert ipa-file-marker " " filename "\n"))

          (let ((start (point)))
            (if (re-search-forward ipa-file-regexp nil t)
              (goto-char (point-max)))
            (delete-region start (point)))

          (if annotations
              (dolist (annotation annotations)
                (let* ((pos (overlay-start (car annotation)))
                        (with-current-buffer buffer
                          (list 'pos pos
                                'before (if (>= (- pos (point-min))
                                             (- pos ipa-context-size) pos))
                                'after (if (>= (- (point-max) pos)
                                            pos (+ pos ipa-context-size)))))))
                  (insert (let ((print-escape-newlines t))
                            (prin1-to-string pos-info))
                           "\n" (concat "\n" ipa-line-continuation)
                           (cdr annotation))

            ;; delete header
            (let ((end (point)))
              (forward-line -1)
              (delete-region (point) end)))

          (message "Annotations saved."))))))

(add-hook 'after-save-hook 'ipa-save-annotations-in-buffer)

(defun ipa-load-annotations-into-buffer ()
  (let ((filename (ipa-get-buffer-file-name))
        (buffer (current-buffer)))
    (with-current-buffer (ipa-find-storage-file)
        (goto-char (point-min))
        (if (re-search-forward (concat ipa-file-regexp filename "\n") 
                               nil t)
            (let ((end (save-excursion
                         (if (re-search-forward ipa-file-regexp nil t)
              (with-current-buffer buffer
                (setq ipa-annotations-in-buffer nil))

              (let (text pos)
                (while (< (point) end)
                  (if (and (not (looking-at ipa-line-continuation))
                      (with-current-buffer buffer
                        (ipa-create-overlay pos text)
                        (setq text nil)
                        (setq pos nil)))

                  (cond ((let ((pos-info (ipa-get-pos-info)))
                           (when pos-info
                             (let ((after (plist-get pos-info 'after))
                                   (before (plist-get pos-info 'before)))
                               (with-current-buffer buffer
                                   ;; using the same algorithm as bookmarks
                                   (goto-char (plist-get pos-info 'pos))

                                   (if (and after
                                            (search-forward after nil t))
                                       (goto-char (match-beginning 0)))
                                   (if (and before 
                                            (search-backward before nil t))
                                       (goto-char (match-end 0)))

                                   (setq pos (point)))))

                             (if (looking-at ":\\(.+\\)")
                                 (setq text (match-string 1))
                               (error "Annotation storage format error"))

                             ;; making it explicit

                        ((looking-at ipa-line-continuation)
                         (setq text 
                               (concat text "\n"
                                       (buffer-substring (1+ (point))


                  (forward-line 1)))

              (message "Resaving annotations so that positions are updated...")
              (with-current-buffer buffer
              (message "Annotations loaded.")))))))

(add-hook 'find-file-hook 'ipa-load-annotations-into-buffer)
(add-hook 'dired-after-readin-hook 'ipa-load-annotations-into-buffer)

(defun ipa-get-pos-info ()
  (and (looking-at "(")
       (read (current-buffer))))

(defun ipa-set-overlay-text (overlay text)
  (if (string-match ipa-annotation-id-regexp text)
      (setq text (match-string 2 text)))
  (overlay-put overlay 'before-string
               (if (equal text "")
                 (propertize (concat "[" text "]") 'face ipa-annotation-face))))

(defun ipa-save-annotations-if-necessary (&optional even-if-empty)
  (if (and (ipa-get-buffer-file-name)
           (not (buffer-modified-p)))
      (ipa-save-annotations-in-buffer even-if-empty)))

(defun ipa-create-overlay (pos text)
  (let ((overlay (make-overlay pos pos nil t nil)))
    (ipa-set-overlay-text overlay text)
    (push (cons overlay text) ipa-annotations-in-buffer)

(defun ipa-sort-overlays ()
  (setq ipa-annotations-in-buffer
        (sort ipa-annotations-in-buffer
              (lambda (first second)
                (< (overlay-start (car first))
                   (overlay-start (car second)))))))

(defun ipa-find-storage-file ()
  (with-current-buffer (find-file-noselect (funcall ipa-file-function))

(defun ipa-get-global-file ()

(defun ipa-get-directory-file ()
  (let ((current-file (ipa-get-buffer-file-name)))
    (if current-file
        (concat (if (file-directory-p current-file)
                  (file-name-directory current-file))
                (file-name-nondirectory ipa-file)))))

(defun ipa-go-to-annotation ()
  (cond ((save-excursion
           (looking-at (concat ipa-file-regexp "\\(.*\\)")))
         (unless ipa-annotation-display
         (find-file (match-string 1)))

        ((let ((pos-info (save-excursion
           (when pos-info
               (if (not (re-search-backward ipa-file-regexp nil t))
                   (error "Containing file header is not found")

                 (goto-char (plist-get pos-info 'pos))

           (looking-at ipa-line-continuation))
            (if (re-search-backward "^(" nil t)
              (error "Containing annotation is not found"))))

         (message "There is nothing on the current line."))))

(defun ipa-font-lock-pos-info (limit)
  (when (re-search-forward "^(" limit t)
    (let ((sexp-start (point))
          sexp-end colon-end)
      (setq sexp-end (point))
      (setq colon-end (point))
      (set-match-data (list sexp-start ;; whole
                            sexp-start ;; sexp
                            sexp-end ;; colon

(defun ipa-jump ()
  (with-current-buffer (ipa-find-storage-file)
      (goto-char (point-min))
      (let (ids)        
        (while (re-search-forward "^(" nil t)
          (if (looking-at (concat ":" ipa-annotation-id-regexp))
              (let ((id (match-string-no-properties 1)))
                (unless (some (lambda (id-info)
                                (equal (car id-info) id))
                  (push (cons id (point)) ids)))))

        (if ids
            (let ((selected (completing-read "Jump to annotation: " ids nil t)))
              (unless (equal selected "")
                (goto-char (assoc-default selected ids))

          (message "There are no annotations with ids."))))))

(defun ipa-get-buffer-file-name ()
  (let ((name (or (buffer-file-name)
                    (goto-char (point-min))
    (if name
        (file-truename name))))

(provide 'ipa)
;;; ipa.el ends here