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