1 files changed, 455 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/util/html-write.el b/emacs.d/nxhtml/util/html-write.el
new file mode 100644
index 0000000..c7a7c76
--- /dev/null
+++ b/emacs.d/nxhtml/util/html-write.el
@@ -0,0 +1,455 @@
+;;; html-write.el --- Hide some tags for writing text in XHTML
+;;
+;; Author: Lennart Borgman (lennart O borgman A gmail O com)
+;; Created: 2008-10-03T01:29:44+0200 Thu
+(defconst html-write:version "0.6") ;; Version:
+;; Last-Updated: 2009-08-11 Tue
+;; URL:
+;; Keywords:
+;; Compatibility:
+;;
+;; Features that might be required by this library:
+;;
+;;   None
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+;;
+;; The minor mode `html-write-mode' displays simple tags like <i>,
+;; <b>, <em>, <strong> or <a> with appropriate faces (for example bold
+;; and italic) instead of displaying the tags.
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; 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., 51 Franklin Street, Fifth
+;; Floor, Boston, MA 02110-1301, USA.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Code:
+
+;; Silence byte compiler
+(defvar jit-lock-start)
+(defvar jit-lock-end)
+
+(eval-when-compile (require 'mumamo)) ;; Just for the defmacro ...
+(eval-when-compile (require 'mlinks nil t))
+
+;;;###autoload
+(defgroup html-write nil
+  "Customization group for html-write."
+  :group 'nxhtml
+  :group 'convenience)
+
+(defface html-write-base
+  '((t (:inherit font-lock-type-face)))
+  "Face from which other faces inherits."
+  :group 'html-write)
+
+(defface html-write-em
+  '((t (:inherit html-write-base :slant italic)))
+  "Face used for <em> tags."
+  :group 'html-write)
+
+(defface html-write-strong
+  '((t (:inherit html-write-base :weight bold)))
+  "Face used for <strong> tags."
+  :group 'html-write)
+
+(defface html-write-link
+  '((t (:inherit html-write-base :underline t)))
+  "Face used for <a> tags."
+  :group 'html-write)
+
+(defconst html-write-tag-list
+  '(("i"      html-write-em-tag-actions)
+    ("b"      html-write-strong-tag-actions)
+    ("em"     html-write-em-tag-actions)
+    ("strong" html-write-strong-tag-actions)
+    ("a"      html-write-a-tag-actions)
+    ;;("img"    html-write-img-tag-actions t)
+    )
+  "List of tags that should be hidden.
+A record in the list has the format
+
+  \(TAG HANDLE [SINGLE])
+
+where
+- TAG is the tag name string.
+
+- HANDLE is a function to call when hiding the tag. It takes
+  three parameters, TAG-BEGIN, TAG-END and OVERLAY.  TAG-BEGIN
+  and TAG-END are start and end of the start tag.  OVERLAY is an
+  overlay used for faces, keymaps etc that covers the whole tag."
+  )
+
+(defun html-write-em-tag-actions (tag-begin tag-end overlay)
+  "Do actions for <em> tags for tag between TAG-BEGIN and TAG-END.
+OVERLAY is the overlay added by `html-write-mode' for this tag."
+  (overlay-put overlay 'face 'html-write-em))
+
+(defun html-write-strong-tag-actions (tag-begin tag-end overlay)
+  "Do actions for <strong> tags for tag between TAG-BEGIN and TAG-END.
+OVERLAY is the overlay added by `html-write-mode' for this tag."
+  (overlay-put overlay 'face 'html-write-strong))
+
+;; Fix-me
+(defun html-write-img-tag-actions (tag-begin tag-end overlay)
+  "Do actions for <img> tags for tag between TAG-BEGIN and TAG-END.
+OVERLAY is the overlay added by `html-write-mode' for this tag."
+  (save-match-data
+    (let ((here (point-marker))
+          href)
+      (save-restriction
+        (narrow-to-region tag-begin tag-end)
+        (goto-char tag-begin)
+        (when (looking-at (rx (*? anything)
+                              (1+ space)
+                              "src=\""
+                              (submatch
+                               (+ (not (any "\"\n"))))
+                              "\""))
+          (setq href (match-string-no-properties 1))))
+      (when href
+        (overlay-put overlay 'display (concat "image " href))
+        (overlay-put overlay 'html-write-url href))
+      (goto-char (point)))))
+
+(defun html-write-point-entered-echo (left entered)
+  (let ((msg (get-char-property entered 'help-echo)))
+    (when msg (message "%s" msg))))
+
+(defun html-write-a-tag-actions (tag-begin tag-end overlay)
+  "Do actions for <a> tags for tag between TAG-BEGIN and TAG-END.
+OVERLAY is the overlay added by `html-write-mode' for this tag."
+  (save-match-data
+    (let ((here (point-marker))
+          href)
+      (save-restriction
+        (narrow-to-region tag-begin tag-end)
+        (goto-char tag-begin)
+        (when (looking-at (rx (*? anything)
+                              (1+ space)
+                              "href=\""
+                              (submatch
+                               (+ (not (any "\"\n"))))
+                              "\""))
+          (setq href (match-string-no-properties 1))))
+      (when href
+        (overlay-put overlay 'face 'html-write-link)
+        (overlay-put overlay 'help-echo href)
+        ;; Fix-me: Seems like point-entered must be a text prop
+        (overlay-put overlay 'point-entered 'html-write-point-entered-echo)
+        (overlay-put overlay 'mouse-face 'highlight)
+        (if (eq ?# (string-to-char href))
+            (setq href (concat "file:///" buffer-file-name href))
+          (when (file-exists-p href)
+            (setq href (expand-file-name href))))
+        (overlay-put overlay 'html-write-url href))
+      (goto-char (point)))))
+
+(defun html-write-get-tag-ovl ()
+  "Get tag overlay at current point."
+  (catch 'ranges
+    (dolist (ovl (overlays-at (point)))
+      (let ((ranges (overlay-get ovl 'html-write)))
+        (when ranges
+          (throw 'ranges ovl))))))
+
+(defun html-write-toggle-current-tag ()
+  "Toggle display of tag at current point."
+  (interactive)
+  (let* ((ovl (html-write-get-tag-ovl))
+         (hiding-ranges (overlay-get ovl 'html-write))
+         (invis (get-text-property (caar hiding-ranges) 'invisible))
+         (ovl-start (overlay-start ovl))
+         (ovl-end (overlay-end ovl)))
+    (if invis
+        (progn
+          (overlay-put ovl 'html-face (overlay-get ovl 'face))
+          (overlay-put ovl 'face 'highlight)
+          (dolist (range hiding-ranges)
+            (let ((start (car range))
+                  (end   (cdr range)))
+              (mumamo-with-buffer-prepared-for-jit-lock
+               (put-text-property start end 'invisible nil)))))
+      (delete-overlay ovl)
+      (html-write-hide-tags ovl-start ovl-end))))
+
+(defun html-write-browse-link ()
+  "Browse link in current tag."
+  (interactive)
+  (let* ((ovl (html-write-get-tag-ovl))
+         (url (overlay-get ovl 'html-write-url)))
+    (unless url
+      (error "No link in this tag"))
+    (browse-url url)
+    ))
+
+(defvar html-write-keymap
+  (let ((map (make-sparse-keymap))
+        keys)
+    (define-key map [(control ?c) ?+] 'html-write-toggle-current-tag)
+    (define-key map [(control ?c) ?!] 'html-write-browse-link)
+    (define-key map [mouse-1] 'html-write-browse-link)
+    (when (featurep 'mlinks)
+      (setq keys (where-is-internal 'mlinks-goto mlinks-mode-map))
+      (dolist (key keys)
+        (define-key map key 'html-write-mlinks-goto))
+      (setq keys (where-is-internal 'mlinks-goto-other-window mlinks-mode-map))
+      (dolist (key keys)
+        (define-key map key 'html-write-mlinks-goto-other-window))
+      (setq keys (where-is-internal 'mlinks-goto-other-frame mlinks-mode-map))
+      (dolist (key keys)
+        (define-key map key 'html-write-mlinks-goto-other-frame))
+      )
+    map))
+
+(defun html-write-mlinks-goto ()
+  "Goto link."
+  (interactive)
+  (html-write-mlinks-goto-1 'mlinks-goto))
+
+(defun html-write-mlinks-goto-other-window ()
+  "Goto link in other window."
+  (interactive)
+  (html-write-mlinks-goto-1 'mlinks-goto-other-window))
+
+(defun html-write-mlinks-goto-other-frame ()
+  "Goto link in other frame."
+  (interactive)
+  (html-write-mlinks-goto-1 'mlinks-goto-other-frame))
+
+(defun html-write-mlinks-goto-1 (goto-fun)
+  (let* ((ovl (html-write-get-tag-ovl))
+         (ovl-start (overlay-start ovl))
+         (ovl-end (overlay-end ovl))
+         (here (point-marker)))
+    (goto-char ovl-start)
+    (skip-chars-forward "^\"" ovl-end)
+    (forward-char)
+    (unless (funcall goto-fun) (goto-char here))
+    ))
+
+;;(html-write-make-hide-tags-regexp)
+(defun html-write-make-hide-tags-regexp ()
+  "Make regexp used for finding tags to hide."
+  ;; fix-me: single tags. Fix-me: what did I mean??? Maybe &lt; etc...
+  (let ((tags-re
+         (mapconcat 'identity
+                    (mapcar (lambda (elt)
+                              (if (stringp elt)
+                                  elt
+                                (car elt)))
+                            html-write-tag-list)
+                    "\\|")))
+    (concat
+     "<\\(?1:"
+     "\\(?:" tags-re "\\)"
+     "\\)[^>]*>\\(?3:[^<]*\\)\\(?2:</\\1>\\)"
+     )))
+
+(defvar html-write-pending-changes nil)
+(make-variable-buffer-local 'html-write-pending-changes)
+(put 'html-write-pending-changes 'permanent-local t)
+
+
+(defun html-write-hide-tags (start end)
+  "Hide tags matching `html-write-tag-list' between START and END."
+  ;;(message "html-write-hide-tags %s %s" start end)
+  (let ((here (point-marker))
+        (buffer-name (buffer-file-name))
+        (dbg nil))
+    (save-restriction
+      (widen)
+      (goto-char start)
+      (save-match-data
+        (let ((hide-tags-regexp (html-write-make-hide-tags-regexp)))
+          (when dbg (message "before search start=%s end=%s, point=%s" start end (point)))
+          (while (re-search-forward hide-tags-regexp end t)
+            (let* ((ovl (make-overlay (match-beginning 0) (match-end 0)
+                                      nil t nil))
+                   (tag-fun (cadr (assoc (match-string-no-properties 1)
+                                         html-write-tag-list)))
+                   hiding-ranges)
+              ;;(overlay-put ovl 'face 'font-lock-variable-name-face)
+              (overlay-put ovl 'keymap html-write-keymap)
+              (setq hiding-ranges
+                    (list (cons (1- (match-beginning 1)) (match-beginning 3))
+                          (cons (match-beginning 2) (match-end 2))))
+              (overlay-put ovl 'html-write hiding-ranges)
+              (mumamo-with-buffer-prepared-for-jit-lock
+               (dolist (range hiding-ranges)
+                 (let ((start (car range))
+                       (end   (cdr range)))
+                   (put-text-property start end 'invisible 'html-write)
+                   ;; Fix-me: more careful rear-nonsticky?
+                   (put-text-property (1- end) end
+                                      'rear-nonsticky '(invisible)))))
+              ;; Let tag-fun override
+              (when tag-fun
+                (funcall tag-fun (match-end 1) (match-beginning 3) ovl))
+              )))))
+    (goto-char here)))
+
+(defun html-write-reveal-tags (start end)
+  "Reveal tags between START and END."
+  (let ((here (point-marker)))
+    (save-restriction
+      (widen)
+      (goto-char (point-min))
+      (save-match-data
+        (mumamo-with-buffer-prepared-for-jit-lock
+         (remove-text-properties start
+                                 end
+                                 '(invisible html-write))
+         (dolist (ovl (overlays-in start end))
+           (when (overlay-get ovl 'html-write)
+             (let ((end (overlay-end ovl)))
+               (remove-list-of-text-properties (1- end) end '(rear-nonsticky))
+               (delete-overlay ovl)))))))
+    (goto-char here)))
+
+;;;###autoload
+(define-minor-mode html-write-mode
+  "Minor mode for convenient display of some HTML tags.
+When this mode is on a tag in `html-write-tag-list' is displayed as
+the inner text of the tag with a face corresponding to the tag.
+By default for example <i>...</i> is displayed as italic and
+<a>...</a> is displayed as an underlined clickable link.
+
+Only non-nested tags are hidden.  The idea is just that it should
+be easier to read and write, not that it should look as html
+rendered text.
+
+See the customization group `html-write' for more information about
+faces.
+
+The following keys are defined when you are on a tag handled by
+this minor mode:
+
+\\{html-write-keymap}
+
+IMPORTANT: Most commands you use works also on the text that is
+hidden.  The movement commands is an exception, but as soon as
+you edit the buffer you may also change the hidden parts.
+
+Hint: Together with `wrap-to-fill-column-mode' this can make it
+easier to see what text you are actually writing in html parts of
+a web file."
+  :group 'html-write
+  (if t
+      (if html-write-mode
+          (html-write-font-lock t)
+        (html-write-font-lock nil)
+        (save-restriction
+          (widen)
+          (html-write-reveal-tags (point-min) (point-max))))))
+(put html-write-mode 'permanent-local t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Font lock
+
+(defun html-write-jit-extend-after-change (start end old-len)
+  "For JIT lock extending.
+Should be on `jit-lock-after-change-extend-region-functions'.
+
+START, END and OLD-LEN are the parameters from after change."
+  (let ((our-ovls nil))
+    (dolist (ovl (append (overlays-in start end)
+                        (overlays-at start)
+                        nil))
+      ;; Leave the overlays until re-fontification time, but note their extent.
+      (when (overlay-get ovl 'html-write)
+        (setq jit-lock-start (min jit-lock-start (overlay-start ovl)))
+        (setq jit-lock-end   (max jit-lock-end   (overlay-end   ovl)))))))
+
+
+(defun html-write-fontify (bound)
+  ;;(message "html-write-fontify %s" bound)
+  (let (tag-ovl)
+    ;;(save-match-data
+      (let* ((hide-tags-regexp (html-write-make-hide-tags-regexp))
+             (next-tag (re-search-forward hide-tags-regexp bound t))
+             (tag-beg (when next-tag (match-beginning 0)))
+             (tag-end (when next-tag (match-end 0)))
+             (tag-nam (when next-tag (match-string-no-properties 1)))
+             (tag-fun (when next-tag (cadr (assoc tag-nam html-write-tag-list))))
+             tag-hid
+             (old-start (next-single-char-property-change (max (point-min) (1- (point))) 'html-write nil bound)))
+        ;;(message "here a old-start=%s, tag-beg/end=%s/%s" old-start tag-beg tag-end)
+        (setq tag-ovl (when next-tag (make-overlay tag-beg tag-end)))
+        (when old-start
+          ;; Fix-me: maybe valid, perhaps better keep it then?
+          (let ((ovl (catch 'ovl
+                       (dolist (o (append (overlays-at old-start)
+                                          (overlays-in old-start (1+ old-start))
+                                          nil))
+                         (when (overlay-get o 'html-write)
+                           (throw 'ovl o))))))
+            (when ovl ;; fix-me: there should be one...
+              ;;(message "here b")
+              (mumamo-with-buffer-prepared-for-jit-lock
+               (remove-list-of-text-properties (overlay-start ovl) (overlay-end ovl) '(invisible html-write)))
+              (delete-overlay ovl))))
+        ;;(html-write-hide-tags start end)
+        ;;(message "here d, tag-ovl=%s" tag-ovl)
+        (when tag-ovl
+          (overlay-put tag-ovl 'face 'font-lock-variable-name-face)
+          (overlay-put tag-ovl 'keymap html-write-keymap)
+          (setq tag-hid
+                (list (cons (1- (match-beginning 1)) (match-beginning 3))
+                      (cons (match-beginning 2) (match-end 2))))
+          (overlay-put tag-ovl 'html-write tag-hid)
+          (when tag-fun
+            (funcall tag-fun (match-end 1) (match-beginning 3) tag-ovl))
+          (mumamo-with-buffer-prepared-for-jit-lock
+           (dolist (range tag-hid)
+             (let ((start (car range))
+                   (end   (cdr range)))
+               (put-text-property start end 'invisible 'html-write)
+               ;;(put-text-property start end 'html-write t)
+               ;; Fix-me: more careful rear-nonsticky?
+               (put-text-property (1- end) end
+                                  'rear-nonsticky '(invisible)))))))
+      ;;)
+    (when tag-ovl
+      (set-match-data (list (copy-marker (overlay-start tag-ovl))
+                            (copy-marker (overlay-end tag-ovl))))
+      (goto-char (1+ (overlay-end tag-ovl)))
+      t)))
+
+(defun html-write-font-lock (on)
+  ;; See mlinks.el
+  (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
+         (fontify-fun 'html-write-fontify)
+         (args (list nil `(( ,fontify-fun ( 0 'html-write-base t ))))))
+    (when fontify-fun
+      (when on (setq args (append args (list t))))
+      (apply add-or-remove args)
+      (font-lock-mode -1)
+      (font-lock-mode 1)
+      )))
+
+(provide 'html-write)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; html-write.el ends here