diff options
Diffstat (limited to 'emacs.d/nxhtml/util/html-write.el')
| -rw-r--r-- | emacs.d/nxhtml/util/html-write.el | 455 |
1 files changed, 0 insertions, 455 deletions
diff --git a/emacs.d/nxhtml/util/html-write.el b/emacs.d/nxhtml/util/html-write.el deleted file mode 100644 index c7a7c76..0000000 --- a/emacs.d/nxhtml/util/html-write.el +++ /dev/null @@ -1,455 +0,0 @@ -;;; 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 < 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 |