Implement font-lock for quasi quoted XML, HTML and JavaScript

haskell-compat.el

@@ -65,6 +65,9 @@ A process is considered alive if its status is `run', `open',
                        xref-prompt-for-identifier)))
       (find-tag ident next-p))))
 
+(unless (fboundp 'font-lock-ensure)
+  (defalias 'font-lock-ensure 'font-lock-fontify-buffer))
+
 (provide 'haskell-compat)
 
 ;;; haskell-compat.el ends here

haskell-font-lock.el

@@ -92,6 +92,27 @@ This is the case if the \".\" is part of a \"forall <tvar> . <type>\"."
               (string= " " (string (char-after start)))
               (string= " " (string (char-before start))))))))
 
+;;;###autoload
+(defcustom haskell-font-lock-quasi-quote-modes
+  `(("hsx" . xml-mode)
+    ("hamlet" . xml-mode)
+    ("shamlet" . xml-mode)
+    ("xmlQQ" . xml-mode)
+    ("xml" . xml-mode)
+    ("cmd" . shell-mode)
+    ("sh_" . shell-mode)
+    ("jmacro" . javascript-mode)
+    ("jmacroE" . javascript-mode)
+    ("r" . ess-mode)
+    ("rChan" . ess-mode)
+    ("sql" . sql-mode))
+  "Mapping from quasi quoter token to fontification mode.
+
+If a quasi quote is seen in Haskell code its contents will have
+font faces assigned as if respective mode was enabled."
+  :group 'haskell
+  :type '(repeat (cons string symbol)))
+
 ;;;###autoload
 (defface haskell-keyword-face
   '((t :inherit font-lock-keyword-face))
@@ -420,10 +441,54 @@ that should be commented under LaTeX-style literate scripts."
      ("^\\(\\\\\\)end{code}$" 1 "!"))
    haskell-basic-syntactic-keywords))
 
+(defun haskell-font-lock-fontify-block (lang-mode start end)
+  "Fontify a block as LANG-MODE."
+  (let ((string (buffer-substring-no-properties start end))
+        (modified (buffer-modified-p))
+        (org-buffer (current-buffer)) pos next)
+    (remove-text-properties start end '(face nil))
+    (with-current-buffer
+        (get-buffer-create
+         (concat " haskell-font-lock-fontify-block:" (symbol-name lang-mode)))
+      (delete-region (point-min) (point-max))
+      (insert string " ") ;; so there's a final property change
+      (unless (eq major-mode lang-mode) (funcall lang-mode))
+      (font-lock-ensure)
+      (setq pos (point-min))
+      (while (setq next (next-single-property-change pos 'face))
+        (put-text-property
+         (+ start (1- pos)) (1- (+ start next)) 'face
+         (get-text-property pos 'face) org-buffer)
+        (setq pos next)))
+    (add-text-properties
+     start end
+     '(font-lock-fontified t fontified t font-lock-multiline t))
+    (set-buffer-modified-p modified)))
+
 (defun haskell-syntactic-face-function (state)
   "`font-lock-syntactic-face-function' for Haskell."
   (cond
-   ((nth 3 state) 'font-lock-string-face) ; as normal
+   ((nth 3 state)
+    (if (equal ?| (nth 3 state))
+        ;; find out what kind of QuasiQuote is this
+        (let* ((qqname (save-excursion
+                        (goto-char (nth 8 state))
+                        (skip-syntax-backward "w._")
+                        (buffer-substring-no-properties (point) (nth 8 state))))
+               (lang-mode (cdr (assoc qqname haskell-font-lock-quasi-quote-modes))))
+
+          (if (and lang-mode
+                   (fboundp lang-mode))
+            (save-excursion
+              ;; find the end of the QuasiQuote
+              (parse-partial-sexp (point) (point-max) nil nil state
+                                  'syntax-table)
+              (haskell-font-lock-fontify-block lang-mode (nth 8 state) (point))
+              ;; must return nil here so that it is not fontified again as string
+              nil)
+            ;; fontify normally as string because lang-mode is not present
+            'font-lock-string-face))
+      'font-lock-string-face))
    ;; Else comment.  If it's from syntax table, use default face.
    ((or (eq 'syntax-table (nth 7 state))
         (and (eq haskell-literate 'bird)