diff --git a/haskell-compat.el b/haskell-compat.el index b08254325..f18bea5c2 100644 --- a/haskell-compat.el +++ b/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 diff --git a/haskell-font-lock.el b/haskell-font-lock.el index 8e6e342b4..17ce008ba 100644 --- a/haskell-font-lock.el +++ b/haskell-font-lock.el @@ -92,6 +92,27 @@ This is the case if the \".\" is part of a \"forall . \"." (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)