final tt updates
[emacs-init.git] / nxhtml / util / html-write.el
1 ;;; html-write.el --- Hide some tags for writing text in XHTML
2 ;;
3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
4 ;; Created: 2008-10-03T01:29:44+0200 Thu
5 (defconst html-write:version "0.6") ;; Version:
6 ;; Last-Updated: 2009-08-11 Tue
7 ;; URL:
8 ;; Keywords:
9 ;; Compatibility:
10 ;;
11 ;; Features that might be required by this library:
12 ;;
13 ;;   None
14 ;;
15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
16 ;;
17 ;;; Commentary:
18 ;;
19 ;; The minor mode `html-write-mode' displays simple tags like <i>,
20 ;; <b>, <em>, <strong> or <a> with appropriate faces (for example bold
21 ;; and italic) instead of displaying the tags.
22 ;;
23 ;;
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 ;;
26 ;;; Change log:
27 ;;
28 ;;
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;
31 ;; This program is free software; you can redistribute it and/or
32 ;; modify it under the terms of the GNU General Public License as
33 ;; published by the Free Software Foundation; either version 2, or
34 ;; (at your option) any later version.
35 ;;
36 ;; This program is distributed in the hope that it will be useful,
37 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
38 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
39 ;; General Public License for more details.
40 ;;
41 ;; You should have received a copy of the GNU General Public License
42 ;; along with this program; see the file COPYING.  If not, write to
43 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
44 ;; Floor, Boston, MA 02110-1301, USA.
45 ;;
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;
48 ;;; Code:
49
50 ;; Silence byte compiler
51 (defvar jit-lock-start)
52 (defvar jit-lock-end)
53
54 (eval-when-compile (require 'mumamo)) ;; Just for the defmacro ...
55 (eval-when-compile (require 'mlinks nil t))
56
57 ;;;###autoload
58 (defgroup html-write nil
59   "Customization group for html-write."
60   :group 'nxhtml
61   :group 'convenience)
62
63 (defface html-write-base
64   '((t (:inherit font-lock-type-face)))
65   "Face from which other faces inherits."
66   :group 'html-write)
67
68 (defface html-write-em
69   '((t (:inherit html-write-base :slant italic)))
70   "Face used for <em> tags."
71   :group 'html-write)
72
73 (defface html-write-strong
74   '((t (:inherit html-write-base :weight bold)))
75   "Face used for <strong> tags."
76   :group 'html-write)
77
78 (defface html-write-link
79   '((t (:inherit html-write-base :underline t)))
80   "Face used for <a> tags."
81   :group 'html-write)
82
83 (defconst html-write-tag-list
84   '(("i"      html-write-em-tag-actions)
85     ("b"      html-write-strong-tag-actions)
86     ("em"     html-write-em-tag-actions)
87     ("strong" html-write-strong-tag-actions)
88     ("a"      html-write-a-tag-actions)
89     ;;("img"    html-write-img-tag-actions t)
90     )
91   "List of tags that should be hidden.
92 A record in the list has the format
93
94   \(TAG HANDLE [SINGLE])
95
96 where
97 - TAG is the tag name string.
98
99 - HANDLE is a function to call when hiding the tag. It takes
100   three parameters, TAG-BEGIN, TAG-END and OVERLAY.  TAG-BEGIN
101   and TAG-END are start and end of the start tag.  OVERLAY is an
102   overlay used for faces, keymaps etc that covers the whole tag."
103   )
104
105 (defun html-write-em-tag-actions (tag-begin tag-end overlay)
106   "Do actions for <em> tags for tag between TAG-BEGIN and TAG-END.
107 OVERLAY is the overlay added by `html-write-mode' for this tag."
108   (overlay-put overlay 'face 'html-write-em))
109
110 (defun html-write-strong-tag-actions (tag-begin tag-end overlay)
111   "Do actions for <strong> tags for tag between TAG-BEGIN and TAG-END.
112 OVERLAY is the overlay added by `html-write-mode' for this tag."
113   (overlay-put overlay 'face 'html-write-strong))
114
115 ;; Fix-me
116 (defun html-write-img-tag-actions (tag-begin tag-end overlay)
117   "Do actions for <img> tags for tag between TAG-BEGIN and TAG-END.
118 OVERLAY is the overlay added by `html-write-mode' for this tag."
119   (save-match-data
120     (let ((here (point-marker))
121           href)
122       (save-restriction
123         (narrow-to-region tag-begin tag-end)
124         (goto-char tag-begin)
125         (when (looking-at (rx (*? anything)
126                               (1+ space)
127                               "src=\""
128                               (submatch
129                                (+ (not (any "\"\n"))))
130                               "\""))
131           (setq href (match-string-no-properties 1))))
132       (when href
133         (overlay-put overlay 'display (concat "image " href))
134         (overlay-put overlay 'html-write-url href))
135       (goto-char (point)))))
136
137 (defun html-write-point-entered-echo (left entered)
138   (let ((msg (get-char-property entered 'help-echo)))
139     (when msg (message "%s" msg))))
140
141 (defun html-write-a-tag-actions (tag-begin tag-end overlay)
142   "Do actions for <a> tags for tag between TAG-BEGIN and TAG-END.
143 OVERLAY is the overlay added by `html-write-mode' for this tag."
144   (save-match-data
145     (let ((here (point-marker))
146           href)
147       (save-restriction
148         (narrow-to-region tag-begin tag-end)
149         (goto-char tag-begin)
150         (when (looking-at (rx (*? anything)
151                               (1+ space)
152                               "href=\""
153                               (submatch
154                                (+ (not (any "\"\n"))))
155                               "\""))
156           (setq href (match-string-no-properties 1))))
157       (when href
158         (overlay-put overlay 'face 'html-write-link)
159         (overlay-put overlay 'help-echo href)
160         ;; Fix-me: Seems like point-entered must be a text prop
161         (overlay-put overlay 'point-entered 'html-write-point-entered-echo)
162         (overlay-put overlay 'mouse-face 'highlight)
163         (if (eq ?# (string-to-char href))
164             (setq href (concat "file:///" buffer-file-name href))
165           (when (file-exists-p href)
166             (setq href (expand-file-name href))))
167         (overlay-put overlay 'html-write-url href))
168       (goto-char (point)))))
169
170 (defun html-write-get-tag-ovl ()
171   "Get tag overlay at current point."
172   (catch 'ranges
173     (dolist (ovl (overlays-at (point)))
174       (let ((ranges (overlay-get ovl 'html-write)))
175         (when ranges
176           (throw 'ranges ovl))))))
177
178 (defun html-write-toggle-current-tag ()
179   "Toggle display of tag at current point."
180   (interactive)
181   (let* ((ovl (html-write-get-tag-ovl))
182          (hiding-ranges (overlay-get ovl 'html-write))
183          (invis (get-text-property (caar hiding-ranges) 'invisible))
184          (ovl-start (overlay-start ovl))
185          (ovl-end (overlay-end ovl)))
186     (if invis
187         (progn
188           (overlay-put ovl 'html-face (overlay-get ovl 'face))
189           (overlay-put ovl 'face 'highlight)
190           (dolist (range hiding-ranges)
191             (let ((start (car range))
192                   (end   (cdr range)))
193               (mumamo-with-buffer-prepared-for-jit-lock
194                (put-text-property start end 'invisible nil)))))
195       (delete-overlay ovl)
196       (html-write-hide-tags ovl-start ovl-end))))
197
198 (defun html-write-browse-link ()
199   "Browse link in current tag."
200   (interactive)
201   (let* ((ovl (html-write-get-tag-ovl))
202          (url (overlay-get ovl 'html-write-url)))
203     (unless url
204       (error "No link in this tag"))
205     (browse-url url)
206     ))
207
208 (defvar html-write-keymap
209   (let ((map (make-sparse-keymap))
210         keys)
211     (define-key map [(control ?c) ?+] 'html-write-toggle-current-tag)
212     (define-key map [(control ?c) ?!] 'html-write-browse-link)
213     (define-key map [mouse-1] 'html-write-browse-link)
214     (when (featurep 'mlinks)
215       (setq keys (where-is-internal 'mlinks-goto mlinks-mode-map))
216       (dolist (key keys)
217         (define-key map key 'html-write-mlinks-goto))
218       (setq keys (where-is-internal 'mlinks-goto-other-window mlinks-mode-map))
219       (dolist (key keys)
220         (define-key map key 'html-write-mlinks-goto-other-window))
221       (setq keys (where-is-internal 'mlinks-goto-other-frame mlinks-mode-map))
222       (dolist (key keys)
223         (define-key map key 'html-write-mlinks-goto-other-frame))
224       )
225     map))
226
227 (defun html-write-mlinks-goto ()
228   "Goto link."
229   (interactive)
230   (html-write-mlinks-goto-1 'mlinks-goto))
231
232 (defun html-write-mlinks-goto-other-window ()
233   "Goto link in other window."
234   (interactive)
235   (html-write-mlinks-goto-1 'mlinks-goto-other-window))
236
237 (defun html-write-mlinks-goto-other-frame ()
238   "Goto link in other frame."
239   (interactive)
240   (html-write-mlinks-goto-1 'mlinks-goto-other-frame))
241
242 (defun html-write-mlinks-goto-1 (goto-fun)
243   (let* ((ovl (html-write-get-tag-ovl))
244          (ovl-start (overlay-start ovl))
245          (ovl-end (overlay-end ovl))
246          (here (point-marker)))
247     (goto-char ovl-start)
248     (skip-chars-forward "^\"" ovl-end)
249     (forward-char)
250     (unless (funcall goto-fun) (goto-char here))
251     ))
252
253 ;;(html-write-make-hide-tags-regexp)
254 (defun html-write-make-hide-tags-regexp ()
255   "Make regexp used for finding tags to hide."
256   ;; fix-me: single tags. Fix-me: what did I mean??? Maybe &lt; etc...
257   (let ((tags-re
258          (mapconcat 'identity
259                     (mapcar (lambda (elt)
260                               (if (stringp elt)
261                                   elt
262                                 (car elt)))
263                             html-write-tag-list)
264                     "\\|")))
265     (concat
266      "<\\(?1:"
267      "\\(?:" tags-re "\\)"
268      "\\)[^>]*>\\(?3:[^<]*\\)\\(?2:</\\1>\\)"
269      )))
270
271 (defvar html-write-pending-changes nil)
272 (make-variable-buffer-local 'html-write-pending-changes)
273 (put 'html-write-pending-changes 'permanent-local t)
274
275
276 (defun html-write-hide-tags (start end)
277   "Hide tags matching `html-write-tag-list' between START and END."
278   ;;(message "html-write-hide-tags %s %s" start end)
279   (let ((here (point-marker))
280         (buffer-name (buffer-file-name))
281         (dbg nil))
282     (save-restriction
283       (widen)
284       (goto-char start)
285       (save-match-data
286         (let ((hide-tags-regexp (html-write-make-hide-tags-regexp)))
287           (when dbg (message "before search start=%s end=%s, point=%s" start end (point)))
288           (while (re-search-forward hide-tags-regexp end t)
289             (let* ((ovl (make-overlay (match-beginning 0) (match-end 0)
290                                       nil t nil))
291                    (tag-fun (cadr (assoc (match-string-no-properties 1)
292                                          html-write-tag-list)))
293                    hiding-ranges)
294               ;;(overlay-put ovl 'face 'font-lock-variable-name-face)
295               (overlay-put ovl 'keymap html-write-keymap)
296               (setq hiding-ranges
297                     (list (cons (1- (match-beginning 1)) (match-beginning 3))
298                           (cons (match-beginning 2) (match-end 2))))
299               (overlay-put ovl 'html-write hiding-ranges)
300               (mumamo-with-buffer-prepared-for-jit-lock
301                (dolist (range hiding-ranges)
302                  (let ((start (car range))
303                        (end   (cdr range)))
304                    (put-text-property start end 'invisible 'html-write)
305                    ;; Fix-me: more careful rear-nonsticky?
306                    (put-text-property (1- end) end
307                                       'rear-nonsticky '(invisible)))))
308               ;; Let tag-fun override
309               (when tag-fun
310                 (funcall tag-fun (match-end 1) (match-beginning 3) ovl))
311               )))))
312     (goto-char here)))
313
314 (defun html-write-reveal-tags (start end)
315   "Reveal tags between START and END."
316   (let ((here (point-marker)))
317     (save-restriction
318       (widen)
319       (goto-char (point-min))
320       (save-match-data
321         (mumamo-with-buffer-prepared-for-jit-lock
322          (remove-text-properties start
323                                  end
324                                  '(invisible html-write))
325          (dolist (ovl (overlays-in start end))
326            (when (overlay-get ovl 'html-write)
327              (let ((end (overlay-end ovl)))
328                (remove-list-of-text-properties (1- end) end '(rear-nonsticky))
329                (delete-overlay ovl)))))))
330     (goto-char here)))
331
332 ;;;###autoload
333 (define-minor-mode html-write-mode
334   "Minor mode for convenient display of some HTML tags.
335 When this mode is on a tag in `html-write-tag-list' is displayed as
336 the inner text of the tag with a face corresponding to the tag.
337 By default for example <i>...</i> is displayed as italic and
338 <a>...</a> is displayed as an underlined clickable link.
339
340 Only non-nested tags are hidden.  The idea is just that it should
341 be easier to read and write, not that it should look as html
342 rendered text.
343
344 See the customization group `html-write' for more information about
345 faces.
346
347 The following keys are defined when you are on a tag handled by
348 this minor mode:
349
350 \\{html-write-keymap}
351
352 IMPORTANT: Most commands you use works also on the text that is
353 hidden.  The movement commands is an exception, but as soon as
354 you edit the buffer you may also change the hidden parts.
355
356 Hint: Together with `wrap-to-fill-column-mode' this can make it
357 easier to see what text you are actually writing in html parts of
358 a web file."
359   :group 'html-write
360   (if t
361       (if html-write-mode
362           (html-write-font-lock t)
363         (html-write-font-lock nil)
364         (save-restriction
365           (widen)
366           (html-write-reveal-tags (point-min) (point-max))))))
367 (put html-write-mode 'permanent-local t)
368
369 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
370 ;;; Font lock
371
372 (defun html-write-jit-extend-after-change (start end old-len)
373   "For JIT lock extending.
374 Should be on `jit-lock-after-change-extend-region-functions'.
375
376 START, END and OLD-LEN are the parameters from after change."
377   (let ((our-ovls nil))
378     (dolist (ovl (append (overlays-in start end)
379                         (overlays-at start)
380                         nil))
381       ;; Leave the overlays until re-fontification time, but note their extent.
382       (when (overlay-get ovl 'html-write)
383         (setq jit-lock-start (min jit-lock-start (overlay-start ovl)))
384         (setq jit-lock-end   (max jit-lock-end   (overlay-end   ovl)))))))
385
386
387 (defun html-write-fontify (bound)
388   ;;(message "html-write-fontify %s" bound)
389   (let (tag-ovl)
390     ;;(save-match-data
391       (let* ((hide-tags-regexp (html-write-make-hide-tags-regexp))
392              (next-tag (re-search-forward hide-tags-regexp bound t))
393              (tag-beg (when next-tag (match-beginning 0)))
394              (tag-end (when next-tag (match-end 0)))
395              (tag-nam (when next-tag (match-string-no-properties 1)))
396              (tag-fun (when next-tag (cadr (assoc tag-nam html-write-tag-list))))
397              tag-hid
398              (old-start (next-single-char-property-change (max (point-min) (1- (point))) 'html-write nil bound)))
399         ;;(message "here a old-start=%s, tag-beg/end=%s/%s" old-start tag-beg tag-end)
400         (setq tag-ovl (when next-tag (make-overlay tag-beg tag-end)))
401         (when old-start
402           ;; Fix-me: maybe valid, perhaps better keep it then?
403           (let ((ovl (catch 'ovl
404                        (dolist (o (append (overlays-at old-start)
405                                           (overlays-in old-start (1+ old-start))
406                                           nil))
407                          (when (overlay-get o 'html-write)
408                            (throw 'ovl o))))))
409             (when ovl ;; fix-me: there should be one...
410               ;;(message "here b")
411               (mumamo-with-buffer-prepared-for-jit-lock
412                (remove-list-of-text-properties (overlay-start ovl) (overlay-end ovl) '(invisible html-write)))
413               (delete-overlay ovl))))
414         ;;(html-write-hide-tags start end)
415         ;;(message "here d, tag-ovl=%s" tag-ovl)
416         (when tag-ovl
417           (overlay-put tag-ovl 'face 'font-lock-variable-name-face)
418           (overlay-put tag-ovl 'keymap html-write-keymap)
419           (setq tag-hid
420                 (list (cons (1- (match-beginning 1)) (match-beginning 3))
421                       (cons (match-beginning 2) (match-end 2))))
422           (overlay-put tag-ovl 'html-write tag-hid)
423           (when tag-fun
424             (funcall tag-fun (match-end 1) (match-beginning 3) tag-ovl))
425           (mumamo-with-buffer-prepared-for-jit-lock
426            (dolist (range tag-hid)
427              (let ((start (car range))
428                    (end   (cdr range)))
429                (put-text-property start end 'invisible 'html-write)
430                ;;(put-text-property start end 'html-write t)
431                ;; Fix-me: more careful rear-nonsticky?
432                (put-text-property (1- end) end
433                                   'rear-nonsticky '(invisible)))))))
434       ;;)
435     (when tag-ovl
436       (set-match-data (list (copy-marker (overlay-start tag-ovl))
437                             (copy-marker (overlay-end tag-ovl))))
438       (goto-char (1+ (overlay-end tag-ovl)))
439       t)))
440
441 (defun html-write-font-lock (on)
442   ;; See mlinks.el
443   (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
444          (fontify-fun 'html-write-fontify)
445          (args (list nil `(( ,fontify-fun ( 0 'html-write-base t ))))))
446     (when fontify-fun
447       (when on (setq args (append args (list t))))
448       (apply add-or-remove args)
449       (font-lock-mode -1)
450       (font-lock-mode 1)
451       )))
452
453 (provide 'html-write)
454 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
455 ;;; html-write.el ends here