;;; mlinks.el --- Minor mode making major mode dependent links
;;
;; Author: Lennar Borgman
;; Created: Tue Jan 16 22:17:34 2007
(defconst mlinks:version "0.2") ;;Version:
;; Last-Updated: Tue Jan 23 01:49:18 2007 (3600 +0100)
;; Keywords:
;; Compatibility:
;;
;; Features that might be required by this library:
;;
;;   `cl'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; This file implements the minor mode `mlinks-mode' that create
;; hyperlinks for different major modes.
;;
;; To-do: Underline all links?
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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, 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

(eval-when-compile (require 'cl))

(defcustom mlinks-mode-functions
  '((emacs-lisp-mode
     ((goto mlinks-elisp-goto)
      (hili mlinks-elisp-hili)
      (hion t)
      )
     )
    (help-mode
     ((goto mlinks-elisp-goto)
      (hili mlinks-elisp-hili)
      (hion t)
      )
     )
    (Info-mode
     ((goto mlinks-elisp-goto)
      (hili mlinks-elisp-hili)
      (hion t)
      )
     )
    (text-mode
     ((goto mlinks-html-style-goto)
      (hili mlinks-html-style-hili)
      (hion t)
      (next somehtml-forward-link)
      (prev somehtml-backward-link)
      )
     )
    (nxhtml-mode
     ((goto mlinks-html-style-goto)
      (hili mlinks-html-style-hili)
      (hion t)
      (next somehtml-forward-link)
      (prev somehtml-backward-link)
      )
     )
    (nxml-mode
     ((goto mlinks-html-style-goto)
      (hili mlinks-html-style-hili)
      (hion t)
      (next somehtml-forward-link)
      (prev somehtml-backward-link)
      )
     )
    (sgml-mode
     ((goto mlinks-html-style-goto)
      (hili mlinks-html-style-hili)
      (hion t)
      (next somehtml-forward-link)
      (prev somehtml-backward-link)
      )
     )
    (xml-mode
     ((goto mlinks-html-style-goto)
      (hili mlinks-html-style-hili)
      (hion t)
      (next somehtml-forward-link)
      (prev somehtml-backward-link)
      )
     )
    (html-mode
     ((goto mlinks-html-style-goto)
      (hili mlinks-html-style-hili)
      (hion t)
      (next somehtml-forward-link)
      (prev somehtml-backward-link)
      )
     )
    )
  "List telling how to create and handle hyperlinks for major modes.
Each element in the list is a list with two elements

  \(MAJOR-MODE SETTINGS)

where MAJOR-MODE is the major mode for which the settings SETTINGS should be used.
SETTINGS is an association list which can have the following element types

  \(hili HILIGHT-FUN)  ;; Mandatory
  \(goto GOTO-FUN)     ;; Mandatory
  \(hion HION-BOOL)    ;; Optional
  \(next NEXT-FUN)     ;; Optional
  \(prev PREV-FUN)     ;; Optional

Where
- HILIGHT-FUN is the function to hilight a link when point is
  inside the link.
- GOTO-FUN is the function to follow the link at point.
- HION-BOOL is t or nil depending on if highlighting should be on
  by default.
- NEXT-FUN is the function to go to the next link.
- PREV-FUN is the function to go to the previous link."
  :group 'mlinks)

(defvar mlinks-mode-map
  (let ((m (make-sparse-keymap)))
    (define-key m [(control ?c) ?\r ?\r]   'mlinks-goto)
    (define-key m [(control ?c) ?\r ?n]    'mlinks-next-saved-position)
    (define-key m [(control ?c) ?\r ?p]    'mlinks-prev-saved-position)
    (define-key m [(control ?c) ?\r S-tab] 'mlinks-backward-link)
    (define-key m [(control ?c) ?\r tab]   'mlinks-forward-link)
    (define-key m [(control ?c) ?\r ?h]    'mlinks-toggle-highlight)
    m))

(define-minor-mode mlinks-mode
  "Recognizes certain parts of a buffer as hyperlinks.
The hyperlinks are created in different ways for different major
modes with the help of the functions in the list
`mlinks-mode-functions'.

The hyperlinks can be highlighted when the point is over them.
Use `mlinks-toggle-highlight' to toggle this feature for the
current buffer.

All keybindings in this mode are by default done under the prefix
key

  C-c RET

which is supposed to be a kind of mnemonic for link (alluding to
the RET key commonly used in web browser to follow a link).
\(Unfortunately this breaks the rules in info node `Key Binding
Conventions'.) Below are the key bindings defined by this mode:

\\{mlinks-mode-map}

For some major modes `mlinks-backward-link' and
`mlinks-forward-link' will take you to the previous/next link.
Immediately after using these functions the highlighting changes
color. When the new color is shown the following keys are active

\\{mlinks-active-highlight-keymap}
"
  nil
  " L"
  nil
  :global t
  :keymap mlinks-mode-map
  :group 'mlinks
  (if mlinks-mode
      (progn
        (mlinks-start-highlighter)
        (add-hook 'after-change-major-mode-hook 'mlinks-after-change-major-mode))
    (mlinks-stop-highlighter)
    (remove-hook 'after-change-major-mode-hook 'mlinks-after-change-major-mode)))

(defun mlinks-after-change-major-mode()
  (let ((hion (car (mlinks-get-action 'hion))))
    (setq mlinks-highlight-this-buffer hion)))

(defvar mlinks-highlight-this-buffer nil)
(make-variable-buffer-local 'mlinks-highlight-this-buffer)

(defvar mlinks-highlight-point-ovl nil)
(make-variable-buffer-local 'mlinks-highlight-point-ovl)

(defvar mlinks-highlighter-timer nil)

(defun mlinks-toggle-highlight()
  "Toggle highlighting of links in current buffer."
  (interactive)
  (setq mlinks-highlight-this-buffer (not mlinks-highlight-this-buffer))
  (if mlinks-highlight-this-buffer
      (message "MLinks highlighter was turned on in buffer")
    (message "MLinks highlighter was turned off in buffer")))

(defun mlinks-stop-highlighter()
  (when mlinks-highlighter-timer
    (cancel-timer mlinks-highlighter-timer))
  (setq mlinks-highlighter-timer nil)
  (when mlinks-highlight-point-ovl
    (delete-overlay mlinks-highlight-point-ovl)))

(defun mlinks-start-highlighter()
  (mlinks-stop-highlighter)
  (setq mlinks-highlighter-timer
        (run-with-idle-timer 0 t 'mlinks-highlighter)))

(defun mlinks-make-point-ovl(bounds)
  (unless mlinks-highlight-point-ovl
    (setq mlinks-highlight-point-ovl
          (make-overlay (car bounds) (cdr bounds)))
    (overlay-put mlinks-highlight-point-ovl
                 'face 'highlight)))

(defun mlinks-highlighter()
  (when mlinks-highlight-this-buffer
    (let* ((funs-- (mlinks-get-action 'hili))
           (bounds-- (run-hook-with-args-until-success 'funs--)))
      (if bounds--
          (if mlinks-highlight-point-ovl
              (move-overlay mlinks-highlight-point-ovl (car bounds--) (cdr bounds--))
            (mlinks-make-point-ovl bounds--))
        (delete-overlay mlinks-highlight-point-ovl)))))

(defvar mlinks-active-highlight-keymap
  (let ((m (make-sparse-keymap)))
    (define-key m [S-tab] 'mlinks-backward-link)
    (define-key m [tab]   'mlinks-forward-link)
    (define-key m "\t"    'mlinks-forward-link)
    (define-key m [?\r]   'mlinks-goto)
    m))

(defun mlinks-pre-command()
  (unless (where-is-internal this-command
                             (list
                              (overlay-get mlinks-highlight-point-ovl 'keymap)))
    (mlinks-deactivate-highlight)
    (unless mlinks-highlighter-timer
      (delete-overlay mlinks-highlight-point-ovl))))

(defun mlinks-activate-highlight()
  (add-hook 'pre-command-hook 'mlinks-pre-command nil t)
  (unless mlinks-highlight-point-ovl
    (mlinks-make-point-ovl (cons (point-min) (point-min))))
  (overlay-put mlinks-highlight-point-ovl 'keymap mlinks-active-highlight-keymap)
  (overlay-put mlinks-highlight-point-ovl 'face 'isearch)
  (mlinks-highlighter)
;;   (message "kb tab=%s, \\t=%s, ovl=%s, keymap=%s"
;;            (key-binding [tab])
;;            (key-binding "\t")
;;            (overlays-at (point))
;;            (overlay-get mlinks-highlight-point-ovl 'keymap))
  )

(defun mlinks-deactivate-highlight()
  (remove-hook 'pre-command-hook 'mlinks-pre-command t)
  (overlay-put mlinks-highlight-point-ovl 'face 'highlight)
  (overlay-put mlinks-highlight-point-ovl 'keymap nil))

(defun mlinks-backward-link()
  "Find previous `mlinks-mode' link in buffer."
  (interactive)
  (let ((funs (mlinks-get-action 'prev)))
    (if (not funs)
        (message "There is no way given to go to previous link for this mode")
      (let ((res (run-hook-with-args-until-success 'funs)))
        (if res
            (mlinks-activate-highlight)
          (message "No previous link found"))))))

(defun mlinks-forward-link()
  "Find next `mlinks-mode' link in buffer."
  (interactive)
  (let ((funs (mlinks-get-action 'next)))
    (if (not funs)
        (message "There is no way given to go to next link for this mode")
      (let ((res (run-hook-with-args-until-success 'funs)))
        (if res
            (mlinks-activate-highlight)
          (message "No next link found"))))))


(defun mlinks-goto()
  "Follow then `mlinks-mode' link at current point.
Save the current position so that they can be move to again by
`mlinks-prev-saved-position' and `mlinks-next-saved-position'."
  (interactive)
  (let* ((funs (mlinks-get-action 'goto))
         (old (point-marker))
         (res (run-hook-with-args-until-success 'funs)))
    (if (not res)
        (message "No MLink link here")
      (unless (= old (point-marker))
        (let* ((prev (car mlinks-places)))
          (when (or (not prev)
                    (not (= old prev)))
            (setq mlinks-places (cons old mlinks-places))
            (setq mlinks-places-n (length mlinks-places))))))))

(defun mlinks-get-action(which)
  (let ((mode-rec (assoc major-mode mlinks-mode-functions)))
    (when mode-rec
      (let* ((mode (car mode-rec))
             (funs-alist (cadr mode-rec))
             (funs (assoc which funs-alist)))
        (cdr funs)))))


(defun mlinks-prev-saved-position()
  "Go to previous position saved by `mlinks-goto'."
  (interactive)
  (unless (mlinks-goto-n (1- mlinks-places-n))
    (message "No previous MLink position")))

(defun mlinks-next-saved-position()
  "Go to next position saved by `mlinks-goto'."
  (interactive)
  (unless (mlinks-goto-n (1+ mlinks-places-n))
    (message "No next MLink position")))

(defun mlinks-goto-n(to)
  (if (not mlinks-places)
      (message "No saved MLinks positions")
    (let ((minp 1)
          (maxp (length mlinks-places)))
      (if (<= to minp)
          (progn
            (setq to minp)
            (message "Going to first MLinks position"))
        (if (>= to maxp)
            (progn
              (setq to maxp)
              (message "Going to last MLinks position"))))
      (setq mlinks-places-n to)
      (let ((n (- maxp to))
            (places mlinks-places)
            place
            buffer
            point)
        (while (> n 0)
          (setq places (cdr places))
          (setq n (1- n)))
        (setq place (car places))
        (switch-to-buffer (marker-buffer place))
        (goto-char place)))))

(defvar mlinks-places-n 0)
(defvar mlinks-places nil)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;; nxhtml-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mlinks-html-style-goto()
  (mlinks-html-style-mode-fun t))

(defun mlinks-html-style-hili()
  (mlinks-html-style-mode-fun nil))

;; Fix-me: All on one line now
(defvar mlinks-html-link-regex
  "\\(?:^\\|[[:space:]]\\)\\(?:href\\|src\\)[[:space:]]*=[[:space:]]*\"\\([^\"]*\\)\"")

(defun somehtml-forward-link()
  (when (re-search-forward mlinks-html-link-regex nil t)
    (goto-char (match-beginning 1))
    t))

(defun somehtml-backward-link()
  (when (re-search-backward mlinks-html-link-regex nil t)
    (goto-char (match-beginning 1))
    t))

(defun mlinks-html-style-mode-fun(goto)
  (let ((here (point))
        start
        end
        bounds)
    (when (search-forward "\"" (line-end-position) t)
      (save-match-data
        (when (looking-back
               mlinks-html-link-regex
               (line-beginning-position))
          (setq start (match-beginning 1))
          (setq end   (match-end 1))
          (setq bounds (cons start end)))))
    (goto-char here)
    (if (not goto)
        bounds
      (let ((href-val (buffer-substring-no-properties start end)))
        (somehtml-href-act-on href-val))
      t)))

(defun somehtml-edit-at(file &optional anchor)
  (find-file file)
  (when anchor
    (let ((here (point))
          ;; Fix-me: better anchor regexp
	  (anchor-regexp (concat "\\(?:id\\|name\\) *= *\"" anchor "\"")))
      (goto-char (point-min))
      (unless (search-forward-regexp anchor-regexp nil t)
	(message "Anchor \"%s\" not found" anchor)
	(goto-char here)))))

(defun somehtml-mail-to(addr)
  (cond ((fboundp 'w32-shell-execute)
	 (w32-shell-execute "open" href-val))
	(t (message "Don't know how to how to start mail"))))

(defun somehtml-href-act-on(href-val)
  (if href-val
      (let* ((possible (somehtml-possible-href-actions href-val))
             (edit (assoc 'edit possible))
             (file (nth 1 edit))
             (anchor (nth 2 edit))
             )
        (cond (edit
               (somehtml-edit-at file anchor)
               t)
              ((assoc 'mailto possible)
               (when (y-or-n-p "This is a mail address.  Do you want to send a message to this mail address? ")
                 (somehtml-mail-to href-val)))
              ((assoc 'view-web possible)
               (when (y-or-n-p "Can't edit this URL, it is on the web.  View the URL in your web browser? ")
                 (browse-url href-val)))
              ((assoc 'view-web-base possible)
               (when (y-or-n-p "Can't edit, based URL is to the web.  View resulting URL in your web browser? ")
                 (browse-url (cdr view-web-base))))
              (t
		 (message "Do not know how to handle this URL"))
              ))
    (message "No value for href attribute")))

(defun somehtml-possible-href-actions(link)
  (let ((urlobj (url-generic-parse-url link))
	(edit nil)
	(possible nil))
    (cond ((member (url-type urlobj) '("http" "https"))
	   (add-to-list 'possible (cons 'view-web link)))
	  ((member (url-type urlobj) '("mailto"))
	   (add-to-list 'possible (cons 'mailto link)))
	  ((url-host urlobj)
	   (message "Do not know how to handle this URL"))
	  (t (setq edit t)))
    (when edit
      (let ((base-href (somehtml-find-base-href)))
	(when base-href
	  (let ((baseobj (url-generic-parse-url base-href)))
	    (setq edit nil)
	    (cond ((member (url-type baseobj) '("http" "https"))
		   (add-to-list 'possible (cons 'view-web-base (url-expand-file-name href-val base-href))))
		  ((url-host urlobj)
		   (message "Do not know how to handle this URL"))
		  (t (setq edit t)))))
	(when edit
	  (let* ((full (split-string (url-filename urlobj) "#"))
		 (file (nth 0 full))
		 (anchor (nth 1 full))
		 )
	    (when (equal file "")
	      (setq file (buffer-file-name)))
	    (when base-href
              ;; We not at this point it is not a http url
	      (setq file (expand-file-name file base-href)))
            (let ((ext (file-name-extension file)))
              (when (member ext '("htm" "html"))
                (add-to-list 'possible (cons 'view-local (list file anchor)))))
	    (add-to-list 'possible (cons 'edit (list file anchor)))))))
    possible))

(defun somehtml-find-base-href()
  "Return base href found in the current file."
  (let ((base-href))
    (save-excursion
      (goto-char (point-min))
      (while (and (not base-href)
		  (search-forward-regexp "<!--[^!]*-->\\|<base[[:space:]]" nil t))
	(when (equal " " (char-to-string (char-before)))
	  (backward-char 6)
	  (when (looking-at "<base [^>]*href *= *\"\\(.*?\\)\"")
	    (setq base-href (match-string-no-properties 1))))))
    base-href))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;; emacs-lisp-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mlinks-elisp-goto()
  (mlinks-elisp-mode-fun t))

(defun mlinks-elisp-hili()
  (mlinks-elisp-mode-fun nil))

(defun mlinks-elisp-mode-fun(goto)
  (let ((symbol-name (thing-at-point 'symbol)))
    (when symbol-name
      (let ((bounds-- (bounds-of-thing-at-point 'symbol))
            ret--)
        (if (save-excursion
              (goto-char (cdr bounds--))
              (looking-back (concat "(require\s+'" symbol-name)
                            (line-beginning-position)))
            (progn
              (setq ret-- bounds--)
              (when goto
                (mlinks-elisp-mode-require symbol-name)))
          (when (mlinks-elisp-mode-symbol symbol-name goto)
            (setq ret-- bounds--)))
        ret--))))

(defun mlinks-elisp-mode-symbol(symbol-name-- goto--)
  ;; Fix-me: use uninterned variables (see mail from Miles)
  ;; Make these names a bit strange because they are boundp at the time of checking:
  (let ((symbol-- (intern-soft symbol-name--))
        defs--)
    (when (and symbol-- (boundp symbol--))
      (add-to-list 'defs-- 'variable))
    (when (fboundp symbol--)
      (add-to-list 'defs-- 'function))
    (when (facep symbol--)
      (add-to-list 'defs-- 'face))
    ;; Avoid some fails hits
    (when (memq symbol--
                '(goto t
                       bounds-- funs-- ret--
                       symbol-- defs-- symbol-name-- goto--))
      (setq defs-- nil))
    (let (defs-places
           def)
      (if (not goto--)
          (progn
            defs--)
        (if (not defs--)
            (progn
              (message "Could not find definition of '%s" symbol-name--)
              nil)
          (dolist (type '(nil defvar defface))
            (condition-case err
                (add-to-list 'defs-places
                             (cons type
                                   (save-excursion (find-definition-noselect symbol-- type))))
              (error
               ;;(lwarn '(mlinks) :error "%s" (error-message-string err))
               nil)))
          (if (= 1 (length defs-places))
            (setq def (car defs-places))
            (let ((many nil)
                  lnk)
              (dolist (d defs-places)
                (if (not lnk)
                    (setq lnk (cdr d))
                  (unless (equal lnk (cdr d))
                    (setq many t))))
              (if (not many)
                  (setq def (car defs-places))
                (let* ((alts (mapcar (lambda(elt)
                                       (let ((type (car elt))
                                             str)
                                         (setq str
                                               (cond
                                                ((not type)
                                                 "Function")
                                                ((eq type 'defvar)
                                                 "Variable")
                                                ((eq type 'defface)
                                                 "Face")))
                                         (cons str elt)))
                                     defs--))
                       (stralts (mapcar (lambda(elt)
                                          (car elt))
                                        alts))
                       (stralt (completing-read "Type: " stralts nil t))
                       (alt (assoc stralt alts)))
                  (setq def (cdr alt))))))
          (when def
            (switch-to-buffer (car (cdr def)))
            (goto-char (cdr (cdr def)))))))))

(defun mlinks-elisp-mode-require(module)
  (find-library module))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;; Helpers when adopting for modes ;;;;;;;;;;;;;;;;;
(defun mlinks-hit-test()
  "Just a helper function for adding support for new modes."
  (let* (
         (s0 (if (match-string 0) (match-string 0) ""))
         (s1 (if (match-string 1) (match-string 1) ""))
         (s2 (if (match-string 2) (match-string 2) ""))
         (s3 (if (match-string 3) (match-string 3) ""))
         )
  (message "match0=%s, match1=%s, match2=%s, match3=%s" s0 s1 s2 s3)))

(defun mlinks-handle-reg-fun-list(reg-fun-list)
  "Just a helper function."
  (dolist (rh reg-fun-list)
    (message "rh=%s" rh);(sit-for 2)
    (unless done
      (setq regexp (car rh))
      (setq hitfun (cadr rh))
      (message "regexp=%s, hitfun=%s" regexp hitfun);(sit-for 1)
      (when (and (setq m (re-search-backward regexp (line-beginning-position) t))
                 (> p (match-beginning 0)))
        (setq done t)
        (setq b (match-beginning 0))
        (setq e (match-end 0))
        )
      (if (not (and b e
                    (< b p)
                    (< p e)))
          (message "MLinks Mode did not find any link here")
        (goto-char b)
        (if (not (looking-at regexp))
            (error "Internal error, regexp %s, no match looking-at" regexp)
          (let ((last (car mlinks-places))
                (m (make-marker)))
            (set-marker m (line-beginning-position))
            (when (or (not last)
                      (not (= m last)))
              (setq mlinks-places (cons m mlinks-places))))
          (funcall hitfun))
        ))))

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