9da3ffee41
This is a massive diff that I had to do in a hurry - when leaving Urbint. I'm pretty sure that most of these are updating Emacs packages, but I'm not positive.
711 lines
30 KiB
EmacsLisp
711 lines
30 KiB
EmacsLisp
;;; haskell-font-lock.el --- Font locking module for Haskell Mode -*- lexical-binding: t -*-
|
||
|
||
;; Copyright 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
|
||
;; Copyright 1997-1998 Graeme E Moss, and Tommy Thorn
|
||
|
||
;; Author: 1997-1998 Graeme E Moss <gem@cs.york.ac.uk>
|
||
;; 1997-1998 Tommy Thorn <thorn@irisa.fr>
|
||
;; 2003 Dave Love <fx@gnu.org>
|
||
;; Keywords: faces files Haskell
|
||
|
||
;; This file is not part of GNU Emacs.
|
||
|
||
;; This file is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 3, or (at your option)
|
||
;; any later version.
|
||
|
||
;; This file is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'haskell-compat)
|
||
(require 'haskell-lexeme)
|
||
(require 'font-lock)
|
||
|
||
;;;###autoload
|
||
(defgroup haskell-appearance nil
|
||
"Haskell Appearance."
|
||
:group 'haskell)
|
||
|
||
|
||
(defcustom haskell-font-lock-symbols nil
|
||
"Display \\ and -> and such using symbols in fonts.
|
||
|
||
This may sound like a neat trick, but be extra careful: it changes the
|
||
alignment and can thus lead to nasty surprises with regards to layout."
|
||
:group 'haskell-appearance
|
||
:type 'boolean)
|
||
|
||
(defcustom haskell-font-lock-symbols-alist
|
||
'(("\\" . "λ")
|
||
("not" . "¬")
|
||
("->" . "→")
|
||
("<-" . "←")
|
||
("=>" . "⇒")
|
||
("()" . "∅")
|
||
("==" . "≡")
|
||
("/=" . "≢")
|
||
(">=" . "≥")
|
||
("<=" . "≤")
|
||
("!!" . "‼")
|
||
("&&" . "∧")
|
||
("||" . "∨")
|
||
("sqrt" . "√")
|
||
("undefined" . "⊥")
|
||
("pi" . "π")
|
||
("~>" . "⇝") ;; Omega language
|
||
;; ("~>" "↝") ;; less desirable
|
||
("-<" . "↢") ;; Paterson's arrow syntax
|
||
;; ("-<" "⤙") ;; nicer but uncommon
|
||
("::" . "∷")
|
||
("." "∘" ; "○"
|
||
;; Need a predicate here to distinguish the . used by
|
||
;; forall <foo> . <bar>.
|
||
haskell-font-lock-dot-is-not-composition)
|
||
("forall" . "∀"))
|
||
"Alist mapping Haskell symbols to chars.
|
||
|
||
Each element has the form (STRING . COMPONENTS) or (STRING
|
||
COMPONENTS PREDICATE).
|
||
|
||
STRING is the Haskell symbol.
|
||
COMPONENTS is a representation specification suitable as an argument to
|
||
`compose-region'.
|
||
PREDICATE if present is a function of one argument (the start position
|
||
of the symbol) which should return non-nil if this mapping should
|
||
be disabled at that position."
|
||
:type '(alist string string)
|
||
:group 'haskell-appearance)
|
||
|
||
(defcustom haskell-font-lock-keywords
|
||
;; `as', `hiding', and `qualified' are part of the import
|
||
;; spec syntax, but they are not reserved.
|
||
;; `_' can go in here since it has temporary word syntax.
|
||
'("case" "class" "data" "default" "deriving" "do"
|
||
"else" "if" "import" "in" "infix" "infixl"
|
||
"infixr" "instance" "let" "module" "mdo" "newtype" "of"
|
||
"rec" "pattern" "proc" "signature" "then" "type" "where" "_")
|
||
"Identifiers treated as reserved keywords in Haskell."
|
||
:group 'haskell-appearance
|
||
:type '(repeat string))
|
||
|
||
|
||
(defun haskell-font-lock-dot-is-not-composition (start)
|
||
"Return non-nil if the \".\" at START is not a composition operator.
|
||
This is the case if the \".\" is part of a \"forall <tvar> . <type>\"."
|
||
(save-excursion
|
||
(goto-char start)
|
||
(or (re-search-backward "\\<forall\\>[^.\"]*\\="
|
||
(line-beginning-position) t)
|
||
(not (or
|
||
(string= " " (string (char-after start)))
|
||
(null (char-before start))
|
||
(string= " " (string (char-before start))))))))
|
||
|
||
(defvar haskell-yesod-parse-routes-mode-keywords
|
||
'(("^\\([^ \t\n]+\\)\\(?:[ \t]+\\([^ \t\n]+\\)\\)?"
|
||
(1 'font-lock-string-face)
|
||
(2 'haskell-constructor-face nil lax))))
|
||
|
||
(define-derived-mode haskell-yesod-parse-routes-mode text-mode "Yesod parseRoutes mode"
|
||
"Mode for parseRoutes from Yesod."
|
||
(setq-local font-lock-defaults '(haskell-yesod-parse-routes-mode-keywords t t nil nil)))
|
||
|
||
(defcustom haskell-font-lock-quasi-quote-modes
|
||
`(("hsx" . xml-mode)
|
||
("hamlet" . shakespeare-hamlet-mode)
|
||
("shamlet" . shakespeare-hamlet-mode)
|
||
("whamlet" . shakespeare-hamlet-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)
|
||
("json" . json-mode)
|
||
("aesonQQ" . json-mode)
|
||
("parseRoutes" . haskell-yesod-parse-routes-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-appearance
|
||
:type '(repeat (cons string symbol)))
|
||
|
||
;;;###autoload
|
||
(defface haskell-keyword-face
|
||
'((t :inherit font-lock-keyword-face))
|
||
"Face used to highlight Haskell keywords."
|
||
:group 'haskell-appearance)
|
||
|
||
;;;###autoload
|
||
(defface haskell-type-face
|
||
'((t :inherit font-lock-type-face))
|
||
"Face used to highlight Haskell types"
|
||
:group 'haskell-appearance)
|
||
|
||
;;;###autoload
|
||
(defface haskell-constructor-face
|
||
'((t :inherit font-lock-type-face))
|
||
"Face used to highlight Haskell constructors."
|
||
:group 'haskell-appearance)
|
||
|
||
;; This used to be `font-lock-variable-name-face' but it doesn't result in
|
||
;; a highlighting that's consistent with other modes (it's mostly used
|
||
;; for function defintions).
|
||
(defface haskell-definition-face
|
||
'((t :inherit font-lock-function-name-face))
|
||
"Face used to highlight Haskell definitions."
|
||
:group 'haskell-appearance)
|
||
|
||
;; This is probably just wrong, but it used to use
|
||
;; `font-lock-function-name-face' with a result that was not consistent with
|
||
;; other major modes, so I just exchanged with `haskell-definition-face'.
|
||
;;;###autoload
|
||
(defface haskell-operator-face
|
||
'((t :inherit font-lock-variable-name-face))
|
||
"Face used to highlight Haskell operators."
|
||
:group 'haskell-appearance)
|
||
|
||
;;;###autoload
|
||
(defface haskell-pragma-face
|
||
'((t :inherit font-lock-preprocessor-face))
|
||
"Face used to highlight Haskell pragmas ({-# ... #-})."
|
||
:group 'haskell-appearance)
|
||
|
||
;;;###autoload
|
||
(defface haskell-liquid-haskell-annotation-face
|
||
'((t :inherit haskell-pragma-face))
|
||
"Face used to highlight LiquidHaskell annotations ({-@ ... @-})."
|
||
:group 'haskell-appearance)
|
||
|
||
;;;###autoload
|
||
(defface haskell-literate-comment-face
|
||
'((t :inherit font-lock-doc-face))
|
||
"Face with which to fontify literate comments.
|
||
Inherit from `default' to avoid fontification of them."
|
||
:group 'haskell-appearance)
|
||
|
||
(defface haskell-quasi-quote-face
|
||
'((t :inherit font-lock-string-face))
|
||
"Generic face for quasiquotes.
|
||
|
||
Some quote types are fontified according to other mode defined in
|
||
`haskell-font-lock-quasi-quote-modes'."
|
||
:group 'haskell-appearance)
|
||
|
||
(defun haskell-font-lock-compose-symbol (alist)
|
||
"Compose a sequence of ascii chars into a symbol.
|
||
Regexp match data 0 points to the chars."
|
||
;; Check that the chars should really be composed into a symbol.
|
||
(let* ((start (match-beginning 0))
|
||
(end (match-end 0))
|
||
(syntaxes (cond
|
||
((eq (char-syntax (char-after start)) ?w) '(?w))
|
||
((eq (char-syntax (char-after start)) ?.) '(?.))
|
||
;; Special case for the . used for qualified names.
|
||
((and (eq (char-after start) ?\.) (= end (1+ start)))
|
||
'(?_ ?\\ ?w))
|
||
(t '(?_ ?\\))))
|
||
sym-data)
|
||
(if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
|
||
(memq (char-syntax (or (char-after end) ?\ )) syntaxes)
|
||
(or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
|
||
(and (consp (setq sym-data (cdr (assoc (match-string 0) alist))))
|
||
(let ((pred (cadr sym-data)))
|
||
(setq sym-data (car sym-data))
|
||
(funcall pred start))))
|
||
;; No composition for you. Let's actually remove any composition
|
||
;; we may have added earlier and which is now incorrect.
|
||
(remove-text-properties start end '(composition))
|
||
;; That's a symbol alright, so add the composition.
|
||
(compose-region start end sym-data)))
|
||
;; Return nil because we're not adding any face property.
|
||
nil)
|
||
|
||
(defun haskell-font-lock-symbols-keywords ()
|
||
(when (and haskell-font-lock-symbols
|
||
haskell-font-lock-symbols-alist)
|
||
`((,(regexp-opt (mapcar 'car haskell-font-lock-symbols-alist) t)
|
||
(0 (haskell-font-lock-compose-symbol ',haskell-font-lock-symbols-alist)
|
||
;; In Emacs-21, if the `override' field is nil, the face
|
||
;; expressions is only evaluated if the text has currently
|
||
;; no face. So force evaluation by using `keep'.
|
||
keep)))))
|
||
|
||
(defun haskell-font-lock--forward-type (&optional ignore)
|
||
"Find where does this type declaration end.
|
||
|
||
Moves the point to the end of type declaration. It should be
|
||
invoked with point just after one of type introducing keywords
|
||
like ::, class, instance, data, newtype, type."
|
||
(interactive)
|
||
(let ((cont t)
|
||
(end (point))
|
||
(token nil)
|
||
;; we are starting right after ::
|
||
(last-token-was-operator t)
|
||
(last-token-was-newline nil)
|
||
(open-parens 0))
|
||
(while cont
|
||
(setq token (haskell-lexeme-looking-at-token 'newline))
|
||
|
||
(cond
|
||
((null token)
|
||
(setq cont nil))
|
||
((member token '(newline))
|
||
(setq last-token-was-newline (not last-token-was-operator))
|
||
(setq end (match-end 0))
|
||
(goto-char (match-end 0)))
|
||
((member (match-string-no-properties 0)
|
||
'(")" "]" "}"))
|
||
(setq open-parens (1- open-parens))
|
||
(if (< open-parens 0)
|
||
;; unmatched closing parenthesis closes type declaration
|
||
(setq cont nil)
|
||
(setq end (match-end 0))
|
||
(goto-char end))
|
||
(setq last-token-was-newline nil))
|
||
((and (member (match-string-no-properties 0)
|
||
'("," ";" "|"))
|
||
(not (member (match-string-no-properties 0) ignore)))
|
||
(if (equal 0 open-parens)
|
||
(setq cont nil)
|
||
(setq last-token-was-operator t)
|
||
(setq end (match-end 0))
|
||
(goto-char end))
|
||
(setq last-token-was-newline nil))
|
||
((and (or (member (match-string-no-properties 0)
|
||
'("<-" "=" "←"))
|
||
(member (match-string-no-properties 0) haskell-font-lock-keywords))
|
||
(not (member (match-string-no-properties 0) ignore)))
|
||
(setq cont nil)
|
||
(setq last-token-was-newline nil))
|
||
((member (match-string-no-properties 0)
|
||
'("(" "[" "{"))
|
||
(if last-token-was-newline
|
||
(setq cont nil)
|
||
(setq open-parens (1+ open-parens))
|
||
(setq end (match-end 0))
|
||
(goto-char end)
|
||
(setq last-token-was-newline nil)))
|
||
((member token '(qsymid char string number template-haskell-quote template-haskell-quasi-quote))
|
||
(setq last-token-was-operator (member (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
|
||
'(varsym consym)))
|
||
(if (and (not last-token-was-operator) last-token-was-newline)
|
||
(setq cont nil)
|
||
|
||
(goto-char (match-end 0))
|
||
(setq end (point)))
|
||
(setq last-token-was-newline nil))
|
||
((member token '(comment nested-comment literate-comment))
|
||
(goto-char (match-end 0))
|
||
(setq end (point)))
|
||
(t
|
||
(goto-char (match-end 0))
|
||
(setq end (point))
|
||
(setq last-token-was-newline nil))))
|
||
(goto-char end)))
|
||
|
||
|
||
(defun haskell-font-lock--select-face-on-type-or-constructor ()
|
||
"Private function used to select either type or constructor face
|
||
on an uppercase identifier."
|
||
(cl-case (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
|
||
(varid (let ((word (match-string-no-properties 0)))
|
||
(cond
|
||
((member word haskell-font-lock-keywords)
|
||
;; Note: keywords parse as keywords only when not qualified.
|
||
;; GHC parses Control.let as a single but illegal lexeme.
|
||
(when (member word '("class" "instance" "type" "data" "newtype"))
|
||
(save-excursion
|
||
(goto-char (match-end 0))
|
||
(save-match-data
|
||
(haskell-font-lock--forward-type
|
||
(cond
|
||
((member word '("class" "instance"))
|
||
'("|"))
|
||
((member word '("type"))
|
||
;; Need to support 'type instance'
|
||
'("=" "instance")))))
|
||
(add-text-properties (match-end 0) (point) '(font-lock-multiline t haskell-type t))))
|
||
'haskell-keyword-face)
|
||
((member word '("forall"))
|
||
(when (get-text-property (match-beginning 0) 'haskell-type)
|
||
'haskell-keyword-face)))))
|
||
(conid (if (get-text-property (match-beginning 0) 'haskell-type)
|
||
'haskell-type-face
|
||
'haskell-constructor-face))
|
||
(varsym (unless (and (member (match-string 0) '("-" "+" "."))
|
||
(equal (string-to-syntax "w") (syntax-after (match-beginning 0))))
|
||
;; We need to protect against the case of
|
||
;; plus, minus or dot inside a floating
|
||
;; point number.
|
||
'haskell-operator-face))
|
||
(consym (if (not (member (match-string 1) '("::" "∷")))
|
||
(if (get-text-property (match-beginning 0) 'haskell-type)
|
||
'haskell-type-face
|
||
'haskell-constructor-face)
|
||
(save-excursion
|
||
(goto-char (match-end 0))
|
||
(save-match-data
|
||
(haskell-font-lock--forward-type))
|
||
(add-text-properties (match-end 0) (point) '(font-lock-multiline t haskell-type t)))
|
||
'haskell-operator-face))))
|
||
|
||
(defun haskell-font-lock--put-face-on-type-or-constructor ()
|
||
"Private function used to put either type or constructor face
|
||
on an uppercase identifier."
|
||
(let ((face (haskell-font-lock--select-face-on-type-or-constructor)))
|
||
(when (and face
|
||
(not (text-property-not-all (match-beginning 0) (match-end 0) 'face nil)))
|
||
(put-text-property (match-beginning 0) (match-end 0) 'face face))))
|
||
|
||
|
||
(defun haskell-font-lock-keywords ()
|
||
;; this has to be a function because it depends on global value of
|
||
;; `haskell-font-lock-symbols'
|
||
"Generate font lock eywords."
|
||
(let* (;; Bird-style literate scripts start a line of code with
|
||
;; "^>", otherwise a line of code starts with "^".
|
||
(line-prefix "^\\(?:> ?\\)?")
|
||
|
||
(varid "[[:lower:]_][[:alnum:]'_]*")
|
||
;; We allow ' preceding conids because of DataKinds/PolyKinds
|
||
(conid "'?[[:upper:]][[:alnum:]'_]*")
|
||
(sym "\\s.+")
|
||
|
||
;; Top-level declarations
|
||
(topdecl-var
|
||
(concat line-prefix "\\(" varid "\\(?:\\s-*,\\s-*" varid "\\)*" "\\)"
|
||
;; optionally allow for a single newline after identifier
|
||
"\\(\\s-+\\|\\s-*[\n]\\s-+\\)"
|
||
;; A toplevel declaration can be followed by a definition
|
||
;; (=), a type (::) or (∷), a guard, or a pattern which can
|
||
;; either be a variable, a constructor, a parenthesized
|
||
;; thingy, or an integer or a string.
|
||
"\\(" varid "\\|" conid "\\|::\\|∷\\|=\\||\\|\\s(\\|[0-9\"']\\)"))
|
||
(topdecl-var2
|
||
(concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*`\\(" varid "\\)`"))
|
||
(topdecl-bangpat
|
||
(concat line-prefix "\\(" varid "\\)\\s-*!"))
|
||
(topdecl-sym
|
||
(concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*\\(" sym "\\)"))
|
||
(topdecl-sym2 (concat line-prefix "(\\(" sym "\\))"))
|
||
|
||
keywords)
|
||
|
||
(setq keywords
|
||
`(;; NOTICE the ordering below is significant
|
||
;;
|
||
("^#\\(?:[^\\\n]\\|\\\\\\(?:.\\|\n\\|\\'\\)\\)*\\(?:\n\\|\\'\\)" 0 'font-lock-preprocessor-face t)
|
||
|
||
,@(haskell-font-lock-symbols-keywords)
|
||
|
||
;; Special case for `as', `hiding', `safe' and `qualified', which are
|
||
;; keywords in import statements but are not otherwise reserved.
|
||
("\\<import[ \t]+\\(?:\\(safe\\>\\)[ \t]*\\)?\\(?:\\(qualified\\>\\)[ \t]*\\)?\\(?:\"[^\"]*\"[\t ]*\\)?[^ \t\n()]+[ \t]*\\(?:\\(\\<as\\>\\)[ \t]*[^ \t\n()]+[ \t]*\\)?\\(\\<hiding\\>\\)?"
|
||
(1 'haskell-keyword-face nil lax)
|
||
(2 'haskell-keyword-face nil lax)
|
||
(3 'haskell-keyword-face nil lax)
|
||
(4 'haskell-keyword-face nil lax))
|
||
|
||
;; Special case for `foreign import'
|
||
;; keywords in foreign import statements but are not otherwise reserved.
|
||
("\\<\\(foreign\\)[ \t]+\\(import\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?\\(?:\\(safe\\|unsafe\\|interruptible\\)[ \t]+\\)?"
|
||
(1 'haskell-keyword-face nil lax)
|
||
(2 'haskell-keyword-face nil lax)
|
||
(3 'haskell-keyword-face nil lax)
|
||
(4 'haskell-keyword-face nil lax))
|
||
|
||
;; Special case for `foreign export'
|
||
;; keywords in foreign export statements but are not otherwise reserved.
|
||
("\\<\\(foreign\\)[ \t]+\\(export\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?"
|
||
(1 'haskell-keyword-face nil lax)
|
||
(2 'haskell-keyword-face nil lax)
|
||
(3 'haskell-keyword-face nil lax))
|
||
|
||
;; Special case for `type family' and `data family'.
|
||
;; `family' is only reserved in these contexts.
|
||
("\\<\\(type\\|data\\)[ \t]+\\(family\\>\\)"
|
||
(1 'haskell-keyword-face nil lax)
|
||
(2 'haskell-keyword-face nil lax))
|
||
|
||
;; Special case for `type role'
|
||
;; `role' is only reserved in this context.
|
||
("\\<\\(type\\)[ \t]+\\(role\\>\\)"
|
||
(1 'haskell-keyword-face nil lax)
|
||
(2 'haskell-keyword-face nil lax))
|
||
|
||
;; Toplevel Declarations.
|
||
;; Place them *before* generic id-and-op highlighting.
|
||
(,topdecl-var (1 (unless (member (match-string 1) haskell-font-lock-keywords)
|
||
'haskell-definition-face)))
|
||
(,topdecl-var2 (2 (unless (member (match-string 2) haskell-font-lock-keywords)
|
||
'haskell-definition-face)))
|
||
(,topdecl-bangpat (1 (unless (member (match-string 1) haskell-font-lock-keywords)
|
||
'haskell-definition-face)))
|
||
(,topdecl-sym (2 (unless (member (match-string 2) '("\\" "=" "->" "→" "<-" "←" "::" "∷" "," ";" "`"))
|
||
'haskell-definition-face)))
|
||
(,topdecl-sym2 (1 (unless (member (match-string 1) '("\\" "=" "->" "→" "<-" "←" "::" "∷" "," ";" "`"))
|
||
'haskell-definition-face)))
|
||
|
||
;; These four are debatable...
|
||
("(\\(,*\\|->\\))" 0 'haskell-constructor-face)
|
||
("\\[\\]" 0 'haskell-constructor-face)
|
||
|
||
("`"
|
||
(0 (if (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
|
||
(parse-partial-sexp (point) (point-max) nil nil (syntax-ppss)
|
||
'syntax-table)
|
||
(when (save-excursion
|
||
(goto-char (match-beginning 0))
|
||
(haskell-lexeme-looking-at-backtick))
|
||
(goto-char (match-end 0))
|
||
(unless (text-property-not-all (match-beginning 1) (match-end 1) 'face nil)
|
||
(put-text-property (match-beginning 1) (match-end 1) 'face 'haskell-operator-face))
|
||
(unless (text-property-not-all (match-beginning 2) (match-end 2) 'face nil)
|
||
(put-text-property (match-beginning 2) (match-end 2) 'face 'haskell-operator-face))
|
||
(unless (text-property-not-all (match-beginning 4) (match-end 4) 'face nil)
|
||
(put-text-property (match-beginning 4) (match-end 4) 'face 'haskell-operator-face))
|
||
(add-text-properties
|
||
(match-beginning 0) (match-end 0)
|
||
'(font-lock-fontified t fontified t font-lock-multiline t))))))
|
||
|
||
(,haskell-lexeme-idsym-first-char
|
||
(0 (if (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
|
||
(parse-partial-sexp (point) (point-max) nil nil (syntax-ppss)
|
||
'syntax-table)
|
||
(when (save-excursion
|
||
(goto-char (match-beginning 0))
|
||
(haskell-lexeme-looking-at-qidsym))
|
||
(goto-char (match-end 0))
|
||
;; note that we have to put face ourselves here because font-lock
|
||
;; will use match data from the original matcher
|
||
(haskell-font-lock--put-face-on-type-or-constructor)))))))
|
||
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
|
||
(cl-letf (((symbol-function 'message)
|
||
(lambda (_fmt &rest _args))))
|
||
;; silence messages
|
||
(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
|
||
(or (get-text-property pos 'face) 'default) org-buffer)
|
||
(setq pos next))
|
||
(unless (equal pos (point-max))
|
||
(put-text-property
|
||
(+ start (1- pos)) (1- (+ start (point-max))) 'face
|
||
'default org-buffer)))
|
||
(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)
|
||
(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 (1+ (nth 8 state)) (1- (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
|
||
'haskell-quasi-quote-face))
|
||
(save-excursion
|
||
(let
|
||
((state2
|
||
(parse-partial-sexp (point) (point-max) nil nil state
|
||
'syntax-table))
|
||
(end-of-string (point)))
|
||
|
||
(put-text-property (nth 8 state) (point)
|
||
'face 'font-lock-string-face)
|
||
|
||
|
||
(if (or (equal t (nth 3 state)) (nth 3 state2))
|
||
;; This is an unterminated string constant, use warning
|
||
;; face for the opening quote.
|
||
(put-text-property (nth 8 state) (1+ (nth 8 state))
|
||
'face 'font-lock-warning-face))
|
||
|
||
(goto-char (1+ (nth 8 state)))
|
||
(while (re-search-forward "\\\\" end-of-string t)
|
||
|
||
(goto-char (1- (point)))
|
||
|
||
(if (looking-at haskell-lexeme-string-literal-inside-item)
|
||
(goto-char (match-end 0))
|
||
|
||
;; We are looking at an unacceptable escape
|
||
;; sequence. Use warning face to highlight that.
|
||
(put-text-property (point) (1+ (point))
|
||
'face 'font-lock-warning-face)
|
||
(goto-char (1+ (point)))))))
|
||
;; must return nil here so that it is not fontified again as string
|
||
nil))
|
||
;; Detect literate comment lines starting with syntax class '<'
|
||
((save-excursion
|
||
(goto-char (nth 8 state))
|
||
(equal (string-to-syntax "<") (syntax-after (point))))
|
||
'haskell-literate-comment-face)
|
||
;; Detect pragmas. A pragma is enclosed in special comment
|
||
;; delimiters {-# .. #-}.
|
||
((save-excursion
|
||
(goto-char (nth 8 state))
|
||
(and (looking-at-p "{-#")
|
||
(forward-comment 1)
|
||
(goto-char (- (point) 3))
|
||
(looking-at-p "#-}")))
|
||
'haskell-pragma-face)
|
||
;; Detect Liquid Haskell annotations enclosed in special comment
|
||
;; delimiters {-@ .. @-}.
|
||
((save-excursion
|
||
(goto-char (nth 8 state))
|
||
(and (looking-at-p "{-@")
|
||
(forward-comment 1)
|
||
(goto-char (- (point) 3))
|
||
(looking-at-p "@-}")))
|
||
'haskell-liquid-haskell-annotation-face)
|
||
;; Haddock comment start with either "-- [|^*$]" or "{- ?[|^*$]"
|
||
;; (note space optional for nested comments and mandatory for
|
||
;; double dash comments).
|
||
;;
|
||
;; Haddock comment will also continue on next line, provided:
|
||
;; - current line is a double dash haddock comment
|
||
;; - next line is also double dash comment
|
||
;; - there is only whitespace between
|
||
;;
|
||
;; We recognize double dash haddock comments by property
|
||
;; 'font-lock-doc-face attached to newline. In case of {- -}
|
||
;; comments newline is outside of comment.
|
||
((save-excursion
|
||
(goto-char (nth 8 state))
|
||
(or (looking-at-p "\\(?:{- ?\\|-- \\)[|^*$]")
|
||
(and (looking-at-p "--") ; are we at double dash comment
|
||
(forward-line -1) ; this is nil on first line
|
||
(eq (get-text-property (line-end-position) 'face)
|
||
'font-lock-doc-face) ; is a doc face
|
||
(forward-line)
|
||
(skip-syntax-forward "-") ; see if there is only whitespace
|
||
(eq (point) (nth 8 state))))) ; we are back in position
|
||
;; Here we look inside the comment to see if there are substrings
|
||
;; worth marking inside we try to emulate as much of haddock as
|
||
;; possible. First we add comment face all over the comment, then
|
||
;; we add special features.
|
||
(let ((beg (nth 8 state))
|
||
(end (save-excursion
|
||
(parse-partial-sexp (point) (point-max) nil nil state
|
||
'syntax-table)
|
||
(point)))
|
||
(emphasis-open-point nil)
|
||
(strong-open-point nil))
|
||
(put-text-property beg end 'face 'font-lock-doc-face)
|
||
|
||
(when (fboundp 'add-face-text-property)
|
||
;; `add-face-text-property' is not defined in Emacs 23
|
||
|
||
;; iterate over chars, take escaped chars unconditionally
|
||
;; mark when a construct is opened, close and face it when
|
||
;; it is closed
|
||
|
||
(save-excursion
|
||
(while (< (point) end)
|
||
(if (looking-at "__\\|\\\\.\\|\\\n\\|[/]")
|
||
(progn
|
||
(cond
|
||
((equal (match-string 0) "/")
|
||
(if emphasis-open-point
|
||
(progn
|
||
(add-face-text-property emphasis-open-point (match-end 0)
|
||
'(:slant italic))
|
||
(setq emphasis-open-point nil))
|
||
(setq emphasis-open-point (point))))
|
||
((equal (match-string 0) "__")
|
||
(if strong-open-point
|
||
(progn
|
||
(add-face-text-property strong-open-point (match-end 0)
|
||
'(:weight bold))
|
||
(setq strong-open-point nil))
|
||
(setq strong-open-point (point))))
|
||
(t
|
||
;; this is a backslash escape sequence, skip over it
|
||
))
|
||
(goto-char (match-end 0)))
|
||
;; skip chars that are not interesting
|
||
(goto-char (1+ (point)))
|
||
(skip-chars-forward "^_\\\\/" end))))))
|
||
nil)
|
||
(t 'font-lock-comment-face)))
|
||
|
||
(defun haskell-font-lock-defaults-create ()
|
||
"Locally set `font-lock-defaults' for Haskell."
|
||
(setq-local font-lock-defaults
|
||
'((haskell-font-lock-keywords)
|
||
nil nil nil nil
|
||
(font-lock-syntactic-face-function
|
||
. haskell-syntactic-face-function)
|
||
;; Get help from font-lock-syntactic-keywords.
|
||
(parse-sexp-lookup-properties . t)
|
||
(font-lock-extra-managed-props . (composition)))))
|
||
|
||
(defun haskell-fontify-as-mode (text mode)
|
||
"Fontify TEXT as MODE, returning the fontified text."
|
||
(with-temp-buffer
|
||
(funcall mode)
|
||
(insert text)
|
||
(if (fboundp 'font-lock-ensure)
|
||
(font-lock-ensure)
|
||
(with-no-warnings (font-lock-fontify-buffer)))
|
||
(buffer-substring (point-min) (point-max))))
|
||
|
||
;; Provide ourselves:
|
||
|
||
(provide 'haskell-font-lock)
|
||
|
||
;; Local Variables:
|
||
;; coding: utf-8-unix
|
||
;; tab-width: 8
|
||
;; End:
|
||
|
||
;;; haskell-font-lock.el ends here
|