lisp/textmodes/mhtml-mode.el

   1 ;;; mhtml-mode.el --- HTML editing mode that handles CSS and JS -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2017-2018 Free Software Foundation, Inc.
   4
   5 ;; Keywords: wp, hypermedia, comm, languages
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 ;;; Code:
  23
  24 (eval-and-compile
  25   (require 'cl-lib)
  26   (require 'flyspell)
  27   (require 'sgml-mode))
  28 (require 'js)
  29 (require 'css-mode)
  30 (require 'prog-mode)
  31 (require 'font-lock)
  32
  33 (defcustom mhtml-tag-relative-indent t
  34   "How <script> and <style> bodies are indented relative to the tag.
  35
  36 When t, indentation looks like:
  37
  38   <script>
  39     code();
  40   </script>
  41
  42 When nil, indentation of the script body starts just below the
  43 tag, like:
  44
  45   <script>
  46   code();
  47   </script>
  48
  49 When `ignore', the script body starts in the first column, like:
  50
  51   <script>
  52 code();
  53   </script>"
  54   :group 'sgml
  55   :type '(choice (const nil) (const t) (const ignore))
  56   :safe 'symbolp
  57   :version "26.1")
  58
  59 (cl-defstruct mhtml--submode
  60   ;; Name of this submode.
  61   name
  62   ;; HTML end tag.
  63   end-tag
  64   ;; Syntax table.
  65   syntax-table
  66   ;; Propertize function.
  67   propertize
  68   ;; Keymap.
  69   keymap
  70   ;; Captured locals that are set when entering a region.
  71   crucial-captured-locals
  72   ;; Other captured local variables; these are not set when entering a
  73   ;; region but let-bound during certain operations, e.g.,
  74   ;; indentation.
  75   captured-locals)
  76
  77 (defconst mhtml--crucial-variable-prefix
  78   (regexp-opt '("comment-" "uncomment-" "electric-indent-"
  79                 "smie-" "forward-sexp-function" "completion-" "major-mode"))
  80   "Regexp matching the prefix of \"crucial\" buffer-locals we want to capture.")
  81
  82 (defconst mhtml--variable-prefix
  83   (regexp-opt '("font-lock-" "indent-line-function"))
  84   "Regexp matching the prefix of buffer-locals we want to capture.")
  85
  86 (defun mhtml--construct-submode (mode &rest args)
  87   "A wrapper for make-mhtml--submode that computes the buffer-local variables."
  88   (let ((captured-locals nil)
  89         (crucial-captured-locals nil)
  90         (submode (apply #'make-mhtml--submode args)))
  91     (with-temp-buffer
  92       (funcall mode)
  93       ;; Make sure font lock is all set up.
  94       (font-lock-set-defaults)
  95       ;; This has to be set to a value other than the mhtml-mode
  96       ;; value, to avoid recursion.
  97       (unless (variable-binding-locus 'font-lock-fontify-region-function)
  98         (setq-local font-lock-fontify-region-function
  99                     #'font-lock-default-fontify-region))
 100       (dolist (iter (buffer-local-variables))
 101         (when (string-match mhtml--crucial-variable-prefix
 102                             (symbol-name (car iter)))
 103           (push iter crucial-captured-locals))
 104         (when (string-match mhtml--variable-prefix (symbol-name (car iter)))
 105           (push iter captured-locals)))
 106       (setf (mhtml--submode-crucial-captured-locals submode)
 107             crucial-captured-locals)
 108       (setf (mhtml--submode-captured-locals submode) captured-locals))
 109     submode))
 110
 111 (defun mhtml--mark-buffer-locals (submode)
 112   (dolist (iter (mhtml--submode-captured-locals submode))
 113     (make-local-variable (car iter))))
 114
 115 (defvar-local mhtml--crucial-variables nil
 116   "List of all crucial variable symbols.")
 117
 118 (defun mhtml--mark-crucial-buffer-locals (submode)
 119   (dolist (iter (mhtml--submode-crucial-captured-locals submode))
 120     (make-local-variable (car iter))
 121     (push (car iter) mhtml--crucial-variables)))
 122
 123 (defconst mhtml--css-submode
 124   (mhtml--construct-submode 'css-mode
 125                             :name "CSS"
 126                             :end-tag "</style>"
 127                             :syntax-table css-mode-syntax-table
 128                             :propertize css-syntax-propertize-function
 129                             :keymap css-mode-map))
 130
 131 (defconst mhtml--js-submode
 132   (mhtml--construct-submode 'js-mode
 133                             :name "JS"
 134                             :end-tag "</script>"
 135                             :syntax-table js-mode-syntax-table
 136                             :propertize #'js-syntax-propertize
 137                             :keymap js-mode-map))
 138
 139 (defmacro mhtml--with-locals (submode &rest body)
 140   (declare (indent 1))
 141   `(cl-progv
 142        (when ,submode (mapcar #'car (mhtml--submode-captured-locals ,submode)))
 143        (when ,submode (mapcar #'cdr (mhtml--submode-captured-locals ,submode)))
 144      (cl-progv
 145          (when ,submode (mapcar #'car (mhtml--submode-crucial-captured-locals
 146                                        ,submode)))
 147          (when ,submode (mapcar #'cdr (mhtml--submode-crucial-captured-locals
 148                                        ,submode)))
 149        ,@body)))
 150
 151 (defun mhtml--submode-lighter ()
 152   "Mode-line lighter indicating the current submode."
 153   ;; The end of the buffer has no text properties, so in this case
 154   ;; back up one character, if possible.
 155   (let* ((where (if (and (eobp) (not (bobp)))
 156                     (1- (point))
 157                   (point)))
 158          (submode (get-text-property where 'mhtml-submode)))
 159     (if submode
 160         (mhtml--submode-name submode)
 161       "")))
 162
 163 (defvar font-lock-beg)
 164 (defvar font-lock-end)
 165
 166 (defun mhtml--extend-font-lock-region ()
 167   "Extend the font lock region according to HTML sub-mode needs.
 168
 169 This is used via `font-lock-extend-region-functions'.  It ensures
 170 that the font-lock region is extended to cover either whole
 171 lines, or to the spot where the submode changes, whichever is
 172 smallest."
 173   (let ((orig-beg font-lock-beg)
 174         (orig-end font-lock-end))
 175     ;; The logic here may look odd but it is needed to ensure that we
 176     ;; do the right thing when trying to limit the search.
 177     (save-excursion
 178       (goto-char font-lock-beg)
 179       ;; previous-single-property-change starts by looking at the
 180       ;; previous character, but we're trying to extend a region to
 181       ;; include just characters with the same submode as this
 182       ;; character.
 183       (unless (eobp)
 184         (forward-char))
 185       (setq font-lock-beg (previous-single-property-change
 186                            (point) 'mhtml-submode nil
 187                            (line-beginning-position)))
 188       (unless (eq (get-text-property font-lock-beg 'mhtml-submode)
 189                   (get-text-property orig-beg 'mhtml-submode))
 190         (cl-incf font-lock-beg))
 191
 192       (goto-char font-lock-end)
 193       (unless (bobp)
 194         (backward-char))
 195       (setq font-lock-end (next-single-property-change
 196                            (point) 'mhtml-submode nil
 197                            (line-beginning-position 2)))
 198       (unless (eq (get-text-property font-lock-end 'mhtml-submode)
 199                   (get-text-property orig-end 'mhtml-submode))
 200         (cl-decf font-lock-end)))
 201
 202     ;; Also handle the multiline property -- but handle it here, and
 203     ;; not via font-lock-extend-region-functions, to avoid the
 204     ;; situation where the two extension functions disagree.
 205     ;; See bug#29159.
 206     (font-lock-extend-region-multiline)
 207
 208     (or (/= font-lock-beg orig-beg)
 209         (/= font-lock-end orig-end))))
 210
 211 (defun mhtml--submode-fontify-one-region (submode beg end &optional loudly)
 212   (if submode
 213       (mhtml--with-locals submode
 214         (save-restriction
 215           (font-lock-fontify-region beg end loudly)))
 216     (font-lock-set-defaults)
 217     (font-lock-default-fontify-region beg end loudly)))
 218
 219 (defun mhtml--submode-fontify-region (beg end loudly)
 220   (syntax-propertize end)
 221   (let ((orig-beg beg)
 222         (orig-end end)
 223         (new-beg beg)
 224         (new-end end))
 225     (while (< beg end)
 226       (let ((submode (get-text-property beg 'mhtml-submode))
 227             (this-end (next-single-property-change beg 'mhtml-submode
 228                                                    nil end)))
 229         (let ((extended (mhtml--submode-fontify-one-region submode beg
 230                                                            this-end loudly)))
 231           ;; If the call extended the region, take note.  We track the
 232           ;; bounds we were passed and take the union of any extended
 233           ;; bounds.
 234           (when (and (consp extended)
 235                      (eq (car extended) 'jit-lock-bounds))
 236             (setq new-beg (min new-beg (cadr extended)))
 237             ;; Make sure that the next region starts where the
 238             ;; extension of this region ends.
 239             (setq this-end (cddr extended))
 240             (setq new-end (max new-end this-end))))
 241         (setq beg this-end)))
 242     (when (or (/= orig-beg new-beg)
 243               (/= orig-end new-end))
 244       (cons 'jit-lock-bounds (cons new-beg new-end)))))
 245
 246 (defvar-local mhtml--last-submode nil
 247   "Record the last visited submode.
 248 This is used by `mhtml--pre-command'.")
 249
 250 (defvar-local mhtml--stashed-crucial-variables nil
 251   "Alist of stashed values of the crucial variables.")
 252
 253 (defun mhtml--stash-crucial-variables ()
 254   (setq mhtml--stashed-crucial-variables
 255         (mapcar (lambda (sym)
 256                   (cons sym (buffer-local-value sym (current-buffer))))
 257                 mhtml--crucial-variables)))
 258
 259 (defun mhtml--map-in-crucial-variables (alist)
 260   (dolist (item alist)
 261     (set (car item) (cdr item))))
 262
 263 (defun mhtml--pre-command ()
 264   (let ((submode (get-text-property (point) 'mhtml-submode)))
 265     (unless (eq submode mhtml--last-submode)
 266       ;; If we're entering a submode, and the previous submode was
 267       ;; nil, then stash the current values first.  This lets the user
 268       ;; at least modify some values directly.  FIXME maybe always
 269       ;; stash into the current mode?
 270       (when (and submode (not mhtml--last-submode))
 271         (mhtml--stash-crucial-variables))
 272       (mhtml--map-in-crucial-variables
 273        (if submode
 274            (mhtml--submode-crucial-captured-locals submode)
 275          mhtml--stashed-crucial-variables))
 276       (setq mhtml--last-submode submode))))
 277
 278 (defun mhtml--syntax-propertize-submode (submode end)
 279   (save-excursion
 280     (when (search-forward (mhtml--submode-end-tag submode) end t)
 281       (setq end (match-beginning 0))))
 282   (set-text-properties (point) end
 283                        (list 'mhtml-submode submode
 284                              'syntax-table (mhtml--submode-syntax-table submode)
 285                              ;; We want local-map here so that we act
 286                              ;; more like the sub-mode and don't
 287                              ;; override minor mode maps.
 288                              'local-map (mhtml--submode-keymap submode)))
 289   (funcall (mhtml--submode-propertize submode) (point) end)
 290   (goto-char end))
 291
 292 (defun mhtml-syntax-propertize (start end)
 293   ;; First remove our special settings from the affected text.  They
 294   ;; will be re-applied as needed.
 295   (remove-list-of-text-properties start end
 296                                   '(syntax-table local-map mhtml-submode))
 297   (goto-char start)
 298   ;; Be sure to look back one character, because START won't yet have
 299   ;; been propertized.
 300   (unless (bobp)
 301     (let ((submode (get-text-property (1- (point)) 'mhtml-submode)))
 302       (if submode
 303           (mhtml--syntax-propertize-submode submode end)
 304         ;; No submode, so do what sgml-mode does.
 305         (sgml-syntax-propertize-inside end))))
 306   (funcall
 307    (syntax-propertize-rules
 308     ("<style.*?>"
 309      (0 (ignore
 310          (goto-char (match-end 0))
 311          ;; Don't apply in a comment.
 312          (unless (syntax-ppss-context (syntax-ppss))
 313            (mhtml--syntax-propertize-submode mhtml--css-submode end)))))
 314     ("<script.*?>"
 315      (0 (ignore
 316          (goto-char (match-end 0))
 317          ;; Don't apply in a comment.
 318          (unless (syntax-ppss-context (syntax-ppss))
 319            (mhtml--syntax-propertize-submode mhtml--js-submode end)))))
 320     sgml-syntax-propertize-rules)
 321    ;; Make sure to handle the situation where
 322    ;; mhtml--syntax-propertize-submode moved point.
 323    (point) end))
 324
 325 (defun mhtml-indent-line ()
 326   "Indent the current line as HTML, JS, or CSS, according to its context."
 327   (interactive)
 328   (let ((submode (save-excursion
 329                    (back-to-indentation)
 330                    (get-text-property (point) 'mhtml-submode))))
 331     (if submode
 332         (save-restriction
 333           (let* ((region-start
 334                   (or (previous-single-property-change (point) 'mhtml-submode)
 335                       (point)))
 336                  (base-indent (save-excursion
 337                                 (goto-char region-start)
 338                                 (sgml-calculate-indent))))
 339             (cond
 340              ((eq mhtml-tag-relative-indent nil)
 341               (setq base-indent (- base-indent sgml-basic-offset)))
 342              ((eq mhtml-tag-relative-indent 'ignore)
 343               (setq base-indent 0)))
 344             (narrow-to-region region-start (point-max))
 345             (let ((prog-indentation-context (list base-indent)))
 346               (mhtml--with-locals submode
 347                 ;; indent-line-function was rebound by
 348                 ;; mhtml--with-locals.
 349                 (funcall indent-line-function)))))
 350       ;; HTML.
 351       (sgml-indent-line))))
 352
 353 (defun mhtml--flyspell-check-word ()
 354   (let ((submode (get-text-property (point) 'mhtml-submode)))
 355     (if submode
 356         (flyspell-generic-progmode-verify)
 357       t)))
 358
 359 ;;;###autoload
 360 (define-derived-mode mhtml-mode html-mode
 361   '((sgml-xml-mode "XHTML+" "HTML+") (:eval (mhtml--submode-lighter)))
 362   "Major mode based on `html-mode', but works with embedded JS and CSS.
 363
 364 Code inside a <script> element is indented using the rules from
 365 `js-mode'; and code inside a <style> element is indented using
 366 the rules from `css-mode'."
 367   (setq-local indent-line-function #'mhtml-indent-line)
 368   (setq-local syntax-propertize-function #'mhtml-syntax-propertize)
 369   (setq-local font-lock-fontify-region-function
 370               #'mhtml--submode-fontify-region)
 371   (setq-local font-lock-extend-region-functions
 372               '(mhtml--extend-font-lock-region))
 373
 374   ;; Attach this to both pre- and post- hooks just in case it ever
 375   ;; changes a key binding that might be accessed from the menu bar.
 376   (add-hook 'pre-command-hook #'mhtml--pre-command nil t)
 377   (add-hook 'post-command-hook #'mhtml--pre-command nil t)
 378
 379   ;; Make any captured variables buffer-local.
 380   (mhtml--mark-buffer-locals mhtml--css-submode)
 381   (mhtml--mark-buffer-locals mhtml--js-submode)
 382
 383   (mhtml--mark-crucial-buffer-locals mhtml--css-submode)
 384   (mhtml--mark-crucial-buffer-locals mhtml--js-submode)
 385   (setq mhtml--crucial-variables (delete-dups mhtml--crucial-variables))
 386
 387   ;: Hack
 388   (js--update-quick-match-re)
 389
 390   ;; This is sort of a prog-mode as well as a text mode.
 391   (run-hooks 'prog-mode-hook))
 392
 393 (put 'mhtml-mode 'flyspell-mode-predicate #'mhtml--flyspell-check-word)
 394
 395 (provide 'mhtml-mode)
 396
 397 ;;; mhtml-mode.el ends here