Klimi's new dotfiles with stow.
您最多选择25个主题 主题必须以字母或数字开头,可以包含连字符 (-),并且长度不得超过35个字符

712 行
30 KiB

  1. ;;; haskell-font-lock.el --- Font locking module for Haskell Mode -*- lexical-binding: t -*-
  2. ;; Copyright 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
  3. ;; Copyright 1997-1998 Graeme E Moss, and Tommy Thorn
  4. ;; Author: 1997-1998 Graeme E Moss <gem@cs.york.ac.uk>
  5. ;; 1997-1998 Tommy Thorn <thorn@irisa.fr>
  6. ;; 2003 Dave Love <fx@gnu.org>
  7. ;; Keywords: faces files Haskell
  8. ;; This file is not part of GNU Emacs.
  9. ;; This file 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, or (at your option)
  12. ;; any later version.
  13. ;; This file is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;; GNU General Public License for more details.
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  19. ;;; Code:
  20. (require 'cl-lib)
  21. (require 'haskell-compat)
  22. (require 'haskell-lexeme)
  23. (require 'font-lock)
  24. ;;;###autoload
  25. (defgroup haskell-appearance nil
  26. "Haskell Appearance."
  27. :group 'haskell)
  28. (defcustom haskell-font-lock-symbols nil
  29. "Display \\ and -> and such using symbols in fonts.
  30. This may sound like a neat trick, but be extra careful: it changes the
  31. alignment and can thus lead to nasty surprises with regards to layout."
  32. :group 'haskell-appearance
  33. :type 'boolean)
  34. (defcustom haskell-font-lock-symbols-alist
  35. '(("\\" . "λ")
  36. ("not" . "¬")
  37. ("->" . "")
  38. ("<-" . "")
  39. ("=>" . "")
  40. ("()" . "")
  41. ("==" . "")
  42. ("/=" . "")
  43. (">=" . "")
  44. ("<=" . "")
  45. ("!!" . "")
  46. ("&&" . "")
  47. ("||" . "")
  48. ("sqrt" . "")
  49. ("undefined" . "")
  50. ("pi" . "π")
  51. ("~>" . "") ;; Omega language
  52. ;; ("~>" "↝") ;; less desirable
  53. ("-<" . "") ;; Paterson's arrow syntax
  54. ;; ("-<" "⤙") ;; nicer but uncommon
  55. ("::" . "")
  56. ("." "" ; "○"
  57. ;; Need a predicate here to distinguish the . used by
  58. ;; forall <foo> . <bar>.
  59. haskell-font-lock-dot-is-not-composition)
  60. ("forall" . ""))
  61. "Alist mapping Haskell symbols to chars.
  62. Each element has the form (STRING . COMPONENTS) or (STRING
  63. COMPONENTS PREDICATE).
  64. STRING is the Haskell symbol.
  65. COMPONENTS is a representation specification suitable as an argument to
  66. `compose-region'.
  67. PREDICATE if present is a function of one argument (the start position
  68. of the symbol) which should return non-nil if this mapping should
  69. be disabled at that position."
  70. :type '(alist string string)
  71. :group 'haskell-appearance)
  72. (defcustom haskell-font-lock-keywords
  73. ;; `as', `hiding', and `qualified' are part of the import
  74. ;; spec syntax, but they are not reserved.
  75. ;; `_' can go in here since it has temporary word syntax.
  76. '("case" "class" "data" "default" "deriving" "do"
  77. "else" "if" "import" "in" "infix" "infixl"
  78. "infixr" "instance" "let" "module" "mdo" "newtype" "of"
  79. "rec" "pattern" "proc" "signature" "then" "type" "where" "_"
  80. "anyclass" "stock" "via")
  81. "Identifiers treated as reserved keywords in Haskell."
  82. :group 'haskell-appearance
  83. :type '(repeat string))
  84. (defun haskell-font-lock-dot-is-not-composition (start)
  85. "Return non-nil if the \".\" at START is not a composition operator.
  86. This is the case if the \".\" is part of a \"forall <tvar> . <type>\"."
  87. (save-excursion
  88. (goto-char start)
  89. (or (re-search-backward "\\<forall\\>[^.\"]*\\="
  90. (line-beginning-position) t)
  91. (not (or
  92. (string= " " (string (char-after start)))
  93. (null (char-before start))
  94. (string= " " (string (char-before start))))))))
  95. (defvar haskell-yesod-parse-routes-mode-keywords
  96. '(("^\\([^ \t\n]+\\)\\(?:[ \t]+\\([^ \t\n]+\\)\\)?"
  97. (1 'font-lock-string-face)
  98. (2 'haskell-constructor-face nil lax))))
  99. (define-derived-mode haskell-yesod-parse-routes-mode text-mode "Yesod parseRoutes mode"
  100. "Mode for parseRoutes from Yesod."
  101. (setq-local font-lock-defaults '(haskell-yesod-parse-routes-mode-keywords t t nil nil)))
  102. (defcustom haskell-font-lock-quasi-quote-modes
  103. `(("hsx" . xml-mode)
  104. ("hamlet" . shakespeare-hamlet-mode)
  105. ("shamlet" . shakespeare-hamlet-mode)
  106. ("whamlet" . shakespeare-hamlet-mode)
  107. ("xmlQQ" . xml-mode)
  108. ("xml" . xml-mode)
  109. ("cmd" . shell-mode)
  110. ("sh_" . shell-mode)
  111. ("jmacro" . javascript-mode)
  112. ("jmacroE" . javascript-mode)
  113. ("r" . ess-mode)
  114. ("rChan" . ess-mode)
  115. ("sql" . sql-mode)
  116. ("json" . json-mode)
  117. ("aesonQQ" . json-mode)
  118. ("parseRoutes" . haskell-yesod-parse-routes-mode))
  119. "Mapping from quasi quoter token to fontification mode.
  120. If a quasi quote is seen in Haskell code its contents will have
  121. font faces assigned as if respective mode was enabled."
  122. :group 'haskell-appearance
  123. :type '(repeat (cons string symbol)))
  124. ;;;###autoload
  125. (defface haskell-keyword-face
  126. '((t :inherit font-lock-keyword-face))
  127. "Face used to highlight Haskell keywords."
  128. :group 'haskell-appearance)
  129. ;;;###autoload
  130. (defface haskell-type-face
  131. '((t :inherit font-lock-type-face))
  132. "Face used to highlight Haskell types"
  133. :group 'haskell-appearance)
  134. ;;;###autoload
  135. (defface haskell-constructor-face
  136. '((t :inherit font-lock-type-face))
  137. "Face used to highlight Haskell constructors."
  138. :group 'haskell-appearance)
  139. ;; This used to be `font-lock-variable-name-face' but it doesn't result in
  140. ;; a highlighting that's consistent with other modes (it's mostly used
  141. ;; for function defintions).
  142. (defface haskell-definition-face
  143. '((t :inherit font-lock-function-name-face))
  144. "Face used to highlight Haskell definitions."
  145. :group 'haskell-appearance)
  146. ;; This is probably just wrong, but it used to use
  147. ;; `font-lock-function-name-face' with a result that was not consistent with
  148. ;; other major modes, so I just exchanged with `haskell-definition-face'.
  149. ;;;###autoload
  150. (defface haskell-operator-face
  151. '((t :inherit font-lock-variable-name-face))
  152. "Face used to highlight Haskell operators."
  153. :group 'haskell-appearance)
  154. ;;;###autoload
  155. (defface haskell-pragma-face
  156. '((t :inherit font-lock-preprocessor-face))
  157. "Face used to highlight Haskell pragmas ({-# ... #-})."
  158. :group 'haskell-appearance)
  159. ;;;###autoload
  160. (defface haskell-liquid-haskell-annotation-face
  161. '((t :inherit haskell-pragma-face))
  162. "Face used to highlight LiquidHaskell annotations ({-@ ... @-})."
  163. :group 'haskell-appearance)
  164. ;;;###autoload
  165. (defface haskell-literate-comment-face
  166. '((t :inherit font-lock-doc-face))
  167. "Face with which to fontify literate comments.
  168. Inherit from `default' to avoid fontification of them."
  169. :group 'haskell-appearance)
  170. (defface haskell-quasi-quote-face
  171. '((t :inherit font-lock-string-face))
  172. "Generic face for quasiquotes.
  173. Some quote types are fontified according to other mode defined in
  174. `haskell-font-lock-quasi-quote-modes'."
  175. :group 'haskell-appearance)
  176. (defun haskell-font-lock-compose-symbol (alist)
  177. "Compose a sequence of ascii chars into a symbol.
  178. Regexp match data 0 points to the chars."
  179. ;; Check that the chars should really be composed into a symbol.
  180. (let* ((start (match-beginning 0))
  181. (end (match-end 0))
  182. (syntaxes (cond
  183. ((eq (char-syntax (char-after start)) ?w) '(?w))
  184. ((eq (char-syntax (char-after start)) ?.) '(?.))
  185. ;; Special case for the . used for qualified names.
  186. ((and (eq (char-after start) ?\.) (= end (1+ start)))
  187. '(?_ ?\\ ?w))
  188. (t '(?_ ?\\))))
  189. sym-data)
  190. (if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
  191. (memq (char-syntax (or (char-after end) ?\ )) syntaxes)
  192. (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
  193. (and (consp (setq sym-data (cdr (assoc (match-string 0) alist))))
  194. (let ((pred (cadr sym-data)))
  195. (setq sym-data (car sym-data))
  196. (funcall pred start))))
  197. ;; No composition for you. Let's actually remove any composition
  198. ;; we may have added earlier and which is now incorrect.
  199. (remove-text-properties start end '(composition))
  200. ;; That's a symbol alright, so add the composition.
  201. (compose-region start end sym-data)))
  202. ;; Return nil because we're not adding any face property.
  203. nil)
  204. (defun haskell-font-lock-symbols-keywords ()
  205. (when (and haskell-font-lock-symbols
  206. haskell-font-lock-symbols-alist)
  207. `((,(regexp-opt (mapcar 'car haskell-font-lock-symbols-alist) t)
  208. (0 (haskell-font-lock-compose-symbol ',haskell-font-lock-symbols-alist)
  209. ;; In Emacs-21, if the `override' field is nil, the face
  210. ;; expressions is only evaluated if the text has currently
  211. ;; no face. So force evaluation by using `keep'.
  212. keep)))))
  213. (defun haskell-font-lock--forward-type (&optional ignore)
  214. "Find where does this type declaration end.
  215. Moves the point to the end of type declaration. It should be
  216. invoked with point just after one of type introducing keywords
  217. like ::, class, instance, data, newtype, type."
  218. (interactive)
  219. (let ((cont t)
  220. (end (point))
  221. (token nil)
  222. ;; we are starting right after ::
  223. (last-token-was-operator t)
  224. (last-token-was-newline nil)
  225. (open-parens 0))
  226. (while cont
  227. (setq token (haskell-lexeme-looking-at-token 'newline))
  228. (cond
  229. ((null token)
  230. (setq cont nil))
  231. ((member token '(newline))
  232. (setq last-token-was-newline (not last-token-was-operator))
  233. (setq end (match-end 0))
  234. (goto-char (match-end 0)))
  235. ((member (match-string-no-properties 0)
  236. '(")" "]" "}"))
  237. (setq open-parens (1- open-parens))
  238. (if (< open-parens 0)
  239. ;; unmatched closing parenthesis closes type declaration
  240. (setq cont nil)
  241. (setq end (match-end 0))
  242. (goto-char end))
  243. (setq last-token-was-newline nil))
  244. ((and (member (match-string-no-properties 0)
  245. '("," ";" "|"))
  246. (not (member (match-string-no-properties 0) ignore)))
  247. (if (equal 0 open-parens)
  248. (setq cont nil)
  249. (setq last-token-was-operator t)
  250. (setq end (match-end 0))
  251. (goto-char end))
  252. (setq last-token-was-newline nil))
  253. ((and (or (member (match-string-no-properties 0)
  254. '("<-" "=" ""))
  255. (member (match-string-no-properties 0) haskell-font-lock-keywords))
  256. (not (member (match-string-no-properties 0) ignore)))
  257. (setq cont nil)
  258. (setq last-token-was-newline nil))
  259. ((member (match-string-no-properties 0)
  260. '("(" "[" "{"))
  261. (if last-token-was-newline
  262. (setq cont nil)
  263. (setq open-parens (1+ open-parens))
  264. (setq end (match-end 0))
  265. (goto-char end)
  266. (setq last-token-was-newline nil)))
  267. ((member token '(qsymid char string number template-haskell-quote template-haskell-quasi-quote))
  268. (setq last-token-was-operator (member (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
  269. '(varsym consym)))
  270. (if (and (not last-token-was-operator) last-token-was-newline)
  271. (setq cont nil)
  272. (goto-char (match-end 0))
  273. (setq end (point)))
  274. (setq last-token-was-newline nil))
  275. ((member token '(comment nested-comment literate-comment))
  276. (goto-char (match-end 0))
  277. (setq end (point)))
  278. (t
  279. (goto-char (match-end 0))
  280. (setq end (point))
  281. (setq last-token-was-newline nil))))
  282. (goto-char end)))
  283. (defun haskell-font-lock--select-face-on-type-or-constructor ()
  284. "Private function used to select either type or constructor face
  285. on an uppercase identifier."
  286. (cl-case (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
  287. (varid (let ((word (match-string-no-properties 0)))
  288. (cond
  289. ((member word haskell-font-lock-keywords)
  290. ;; Note: keywords parse as keywords only when not qualified.
  291. ;; GHC parses Control.let as a single but illegal lexeme.
  292. (when (member word '("class" "instance" "type" "data" "newtype"))
  293. (save-excursion
  294. (goto-char (match-end 0))
  295. (save-match-data
  296. (haskell-font-lock--forward-type
  297. (cond
  298. ((member word '("class" "instance"))
  299. '("|"))
  300. ((member word '("type"))
  301. ;; Need to support 'type instance'
  302. '("=" "instance")))))
  303. (add-text-properties (match-end 0) (point) '(font-lock-multiline t haskell-type t))))
  304. 'haskell-keyword-face)
  305. ((member word '("forall"))
  306. (when (get-text-property (match-beginning 0) 'haskell-type)
  307. 'haskell-keyword-face)))))
  308. (conid (if (get-text-property (match-beginning 0) 'haskell-type)
  309. 'haskell-type-face
  310. 'haskell-constructor-face))
  311. (varsym (unless (and (member (match-string 0) '("-" "+" "."))
  312. (equal (string-to-syntax "w") (syntax-after (match-beginning 0))))
  313. ;; We need to protect against the case of
  314. ;; plus, minus or dot inside a floating
  315. ;; point number.
  316. 'haskell-operator-face))
  317. (consym (if (not (member (match-string 1) '("::" "")))
  318. (if (get-text-property (match-beginning 0) 'haskell-type)
  319. 'haskell-type-face
  320. 'haskell-constructor-face)
  321. (save-excursion
  322. (goto-char (match-end 0))
  323. (save-match-data
  324. (haskell-font-lock--forward-type))
  325. (add-text-properties (match-end 0) (point) '(font-lock-multiline t haskell-type t)))
  326. 'haskell-operator-face))))
  327. (defun haskell-font-lock--put-face-on-type-or-constructor ()
  328. "Private function used to put either type or constructor face
  329. on an uppercase identifier."
  330. (let ((face (haskell-font-lock--select-face-on-type-or-constructor)))
  331. (when (and face
  332. (not (text-property-not-all (match-beginning 0) (match-end 0) 'face nil)))
  333. (put-text-property (match-beginning 0) (match-end 0) 'face face))))
  334. (defun haskell-font-lock-keywords ()
  335. ;; this has to be a function because it depends on global value of
  336. ;; `haskell-font-lock-symbols'
  337. "Generate font lock eywords."
  338. (let* (;; Bird-style literate scripts start a line of code with
  339. ;; "^>", otherwise a line of code starts with "^".
  340. (line-prefix "^\\(?:> ?\\)?")
  341. (varid "[[:lower:]_][[:alnum:]'_]*")
  342. ;; We allow ' preceding conids because of DataKinds/PolyKinds
  343. (conid "'?[[:upper:]][[:alnum:]'_]*")
  344. (sym "\\s.+")
  345. ;; Top-level declarations
  346. (topdecl-var
  347. (concat line-prefix "\\(" varid "\\(?:\\s-*,\\s-*" varid "\\)*" "\\)"
  348. ;; optionally allow for a single newline after identifier
  349. "\\(\\s-+\\|\\s-*[\n]\\s-+\\)"
  350. ;; A toplevel declaration can be followed by a definition
  351. ;; (=), a type (::) or (∷), a guard, or a pattern which can
  352. ;; either be a variable, a constructor, a parenthesized
  353. ;; thingy, or an integer or a string.
  354. "\\(" varid "\\|" conid "\\|::\\|∷\\|=\\||\\|\\s(\\|[0-9\"']\\)"))
  355. (topdecl-var2
  356. (concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*`\\(" varid "\\)`"))
  357. (topdecl-bangpat
  358. (concat line-prefix "\\(" varid "\\)\\s-*!"))
  359. (topdecl-sym
  360. (concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*\\(" sym "\\)"))
  361. (topdecl-sym2 (concat line-prefix "(\\(" sym "\\))"))
  362. keywords)
  363. (setq keywords
  364. `(;; NOTICE the ordering below is significant
  365. ;;
  366. ("^#\\(?:[^\\\n]\\|\\\\\\(?:.\\|\n\\|\\'\\)\\)*\\(?:\n\\|\\'\\)" 0 'font-lock-preprocessor-face t)
  367. ,@(haskell-font-lock-symbols-keywords)
  368. ;; Special case for `as', `hiding', `safe' and `qualified', which are
  369. ;; keywords in import statements but are not otherwise reserved.
  370. ("\\<import[ \t]+\\(?:\\(safe\\>\\)[ \t]*\\)?\\(?:\\(qualified\\>\\)[ \t]*\\)?\\(?:\"[^\"]*\"[\t ]*\\)?[^ \t\n()]+[ \t]*\\(?:\\(\\<as\\>\\)[ \t]*[^ \t\n()]+[ \t]*\\)?\\(\\<hiding\\>\\)?"
  371. (1 'haskell-keyword-face nil lax)
  372. (2 'haskell-keyword-face nil lax)
  373. (3 'haskell-keyword-face nil lax)
  374. (4 'haskell-keyword-face nil lax))
  375. ;; Special case for `foreign import'
  376. ;; keywords in foreign import statements but are not otherwise reserved.
  377. ("\\<\\(foreign\\)[ \t]+\\(import\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?\\(?:\\(safe\\|unsafe\\|interruptible\\)[ \t]+\\)?"
  378. (1 'haskell-keyword-face nil lax)
  379. (2 'haskell-keyword-face nil lax)
  380. (3 'haskell-keyword-face nil lax)
  381. (4 'haskell-keyword-face nil lax))
  382. ;; Special case for `foreign export'
  383. ;; keywords in foreign export statements but are not otherwise reserved.
  384. ("\\<\\(foreign\\)[ \t]+\\(export\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?"
  385. (1 'haskell-keyword-face nil lax)
  386. (2 'haskell-keyword-face nil lax)
  387. (3 'haskell-keyword-face nil lax))
  388. ;; Special case for `type family' and `data family'.
  389. ;; `family' is only reserved in these contexts.
  390. ("\\<\\(type\\|data\\)[ \t]+\\(family\\>\\)"
  391. (1 'haskell-keyword-face nil lax)
  392. (2 'haskell-keyword-face nil lax))
  393. ;; Special case for `type role'
  394. ;; `role' is only reserved in this context.
  395. ("\\<\\(type\\)[ \t]+\\(role\\>\\)"
  396. (1 'haskell-keyword-face nil lax)
  397. (2 'haskell-keyword-face nil lax))
  398. ;; Toplevel Declarations.
  399. ;; Place them *before* generic id-and-op highlighting.
  400. (,topdecl-var (1 (unless (member (match-string 1) haskell-font-lock-keywords)
  401. 'haskell-definition-face)))
  402. (,topdecl-var2 (2 (unless (member (match-string 2) haskell-font-lock-keywords)
  403. 'haskell-definition-face)))
  404. (,topdecl-bangpat (1 (unless (member (match-string 1) haskell-font-lock-keywords)
  405. 'haskell-definition-face)))
  406. (,topdecl-sym (2 (unless (member (match-string 2) '("\\" "=" "->" "" "<-" "" "::" "" "," ";" "`"))
  407. 'haskell-definition-face)))
  408. (,topdecl-sym2 (1 (unless (member (match-string 1) '("\\" "=" "->" "" "<-" "" "::" "" "," ";" "`"))
  409. 'haskell-definition-face)))
  410. ;; These four are debatable...
  411. ("(\\(,*\\|->\\))" 0 'haskell-constructor-face)
  412. ("\\[\\]" 0 'haskell-constructor-face)
  413. ("`"
  414. (0 (if (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
  415. (parse-partial-sexp (point) (point-max) nil nil (syntax-ppss)
  416. 'syntax-table)
  417. (when (save-excursion
  418. (goto-char (match-beginning 0))
  419. (haskell-lexeme-looking-at-backtick))
  420. (goto-char (match-end 0))
  421. (unless (text-property-not-all (match-beginning 1) (match-end 1) 'face nil)
  422. (put-text-property (match-beginning 1) (match-end 1) 'face 'haskell-operator-face))
  423. (unless (text-property-not-all (match-beginning 2) (match-end 2) 'face nil)
  424. (put-text-property (match-beginning 2) (match-end 2) 'face 'haskell-operator-face))
  425. (unless (text-property-not-all (match-beginning 4) (match-end 4) 'face nil)
  426. (put-text-property (match-beginning 4) (match-end 4) 'face 'haskell-operator-face))
  427. (add-text-properties
  428. (match-beginning 0) (match-end 0)
  429. '(font-lock-fontified t fontified t font-lock-multiline t))))))
  430. (,haskell-lexeme-idsym-first-char
  431. (0 (if (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
  432. (parse-partial-sexp (point) (point-max) nil nil (syntax-ppss)
  433. 'syntax-table)
  434. (when (save-excursion
  435. (goto-char (match-beginning 0))
  436. (haskell-lexeme-looking-at-qidsym))
  437. (goto-char (match-end 0))
  438. ;; note that we have to put face ourselves here because font-lock
  439. ;; will use match data from the original matcher
  440. (haskell-font-lock--put-face-on-type-or-constructor)))))))
  441. keywords))
  442. (defun haskell-font-lock-fontify-block (lang-mode start end)
  443. "Fontify a block as LANG-MODE."
  444. (let ((string (buffer-substring-no-properties start end))
  445. (modified (buffer-modified-p))
  446. (org-buffer (current-buffer)) pos next)
  447. (remove-text-properties start end '(face nil))
  448. (with-current-buffer
  449. (get-buffer-create
  450. (concat " haskell-font-lock-fontify-block:" (symbol-name lang-mode)))
  451. (delete-region (point-min) (point-max))
  452. (insert string " ") ;; so there's a final property change
  453. (cl-letf (((symbol-function 'message)
  454. (lambda (_fmt &rest _args))))
  455. ;; silence messages
  456. (unless (eq major-mode lang-mode) (funcall lang-mode))
  457. (font-lock-ensure))
  458. (setq pos (point-min))
  459. (while (setq next (next-single-property-change pos 'face))
  460. (put-text-property
  461. (+ start (1- pos)) (1- (+ start next)) 'face
  462. (or (get-text-property pos 'face) 'default) org-buffer)
  463. (setq pos next))
  464. (unless (equal pos (point-max))
  465. (put-text-property
  466. (+ start (1- pos)) (1- (+ start (point-max))) 'face
  467. 'default org-buffer)))
  468. (add-text-properties
  469. start end
  470. '(font-lock-fontified t fontified t font-lock-multiline t))
  471. (set-buffer-modified-p modified)))
  472. (defun haskell-syntactic-face-function (state)
  473. "`font-lock-syntactic-face-function' for Haskell."
  474. (cond
  475. ((nth 3 state)
  476. (if (equal ?| (nth 3 state))
  477. ;; find out what kind of QuasiQuote is this
  478. (let* ((qqname (save-excursion
  479. (goto-char (nth 8 state))
  480. (skip-syntax-backward "w._")
  481. (buffer-substring-no-properties (point) (nth 8 state))))
  482. (lang-mode (cdr (assoc qqname haskell-font-lock-quasi-quote-modes))))
  483. (if (and lang-mode
  484. (fboundp lang-mode))
  485. (save-excursion
  486. ;; find the end of the QuasiQuote
  487. (parse-partial-sexp (point) (point-max) nil nil state
  488. 'syntax-table)
  489. (haskell-font-lock-fontify-block lang-mode (1+ (nth 8 state)) (1- (point)))
  490. ;; must return nil here so that it is not fontified again as string
  491. nil)
  492. ;; fontify normally as string because lang-mode is not present
  493. 'haskell-quasi-quote-face))
  494. (save-excursion
  495. (let
  496. ((state2
  497. (parse-partial-sexp (point) (point-max) nil nil state
  498. 'syntax-table))
  499. (end-of-string (point)))
  500. (put-text-property (nth 8 state) (point)
  501. 'face 'font-lock-string-face)
  502. (if (or (equal t (nth 3 state)) (nth 3 state2))
  503. ;; This is an unterminated string constant, use warning
  504. ;; face for the opening quote.
  505. (put-text-property (nth 8 state) (1+ (nth 8 state))
  506. 'face 'font-lock-warning-face))
  507. (goto-char (1+ (nth 8 state)))
  508. (while (re-search-forward "\\\\" end-of-string t)
  509. (goto-char (1- (point)))
  510. (if (looking-at haskell-lexeme-string-literal-inside-item)
  511. (goto-char (match-end 0))
  512. ;; We are looking at an unacceptable escape
  513. ;; sequence. Use warning face to highlight that.
  514. (put-text-property (point) (1+ (point))
  515. 'face 'font-lock-warning-face)
  516. (goto-char (1+ (point)))))))
  517. ;; must return nil here so that it is not fontified again as string
  518. nil))
  519. ;; Detect literate comment lines starting with syntax class '<'
  520. ((save-excursion
  521. (goto-char (nth 8 state))
  522. (equal (string-to-syntax "<") (syntax-after (point))))
  523. 'haskell-literate-comment-face)
  524. ;; Detect pragmas. A pragma is enclosed in special comment
  525. ;; delimiters {-# .. #-}.
  526. ((save-excursion
  527. (goto-char (nth 8 state))
  528. (and (looking-at-p "{-#")
  529. (forward-comment 1)
  530. (goto-char (- (point) 3))
  531. (looking-at-p "#-}")))
  532. 'haskell-pragma-face)
  533. ;; Detect Liquid Haskell annotations enclosed in special comment
  534. ;; delimiters {-@ .. @-}.
  535. ((save-excursion
  536. (goto-char (nth 8 state))
  537. (and (looking-at-p "{-@")
  538. (forward-comment 1)
  539. (goto-char (- (point) 3))
  540. (looking-at-p "@-}")))
  541. 'haskell-liquid-haskell-annotation-face)
  542. ;; Haddock comment start with either "-- [|^*$]" or "{- ?[|^*$]"
  543. ;; (note space optional for nested comments and mandatory for
  544. ;; double dash comments).
  545. ;;
  546. ;; Haddock comment will also continue on next line, provided:
  547. ;; - current line is a double dash haddock comment
  548. ;; - next line is also double dash comment
  549. ;; - there is only whitespace between
  550. ;;
  551. ;; We recognize double dash haddock comments by property
  552. ;; 'font-lock-doc-face attached to newline. In case of {- -}
  553. ;; comments newline is outside of comment.
  554. ((save-excursion
  555. (goto-char (nth 8 state))
  556. (or (looking-at-p "\\(?:{- ?\\|-- \\)[|^*$]")
  557. (and (looking-at-p "--") ; are we at double dash comment
  558. (forward-line -1) ; this is nil on first line
  559. (eq (get-text-property (line-end-position) 'face)
  560. 'font-lock-doc-face) ; is a doc face
  561. (forward-line)
  562. (skip-syntax-forward "-") ; see if there is only whitespace
  563. (eq (point) (nth 8 state))))) ; we are back in position
  564. ;; Here we look inside the comment to see if there are substrings
  565. ;; worth marking inside we try to emulate as much of haddock as
  566. ;; possible. First we add comment face all over the comment, then
  567. ;; we add special features.
  568. (let ((beg (nth 8 state))
  569. (end (save-excursion
  570. (parse-partial-sexp (point) (point-max) nil nil state
  571. 'syntax-table)
  572. (point)))
  573. (emphasis-open-point nil)
  574. (strong-open-point nil))
  575. (put-text-property beg end 'face 'font-lock-doc-face)
  576. (when (fboundp 'add-face-text-property)
  577. ;; `add-face-text-property' is not defined in Emacs 23
  578. ;; iterate over chars, take escaped chars unconditionally
  579. ;; mark when a construct is opened, close and face it when
  580. ;; it is closed
  581. (save-excursion
  582. (while (< (point) end)
  583. (if (looking-at "__\\|\\\\.\\|\\\n\\|[/]")
  584. (progn
  585. (cond
  586. ((equal (match-string 0) "/")
  587. (if emphasis-open-point
  588. (progn
  589. (add-face-text-property emphasis-open-point (match-end 0)
  590. '(:slant italic))
  591. (setq emphasis-open-point nil))
  592. (setq emphasis-open-point (point))))
  593. ((equal (match-string 0) "__")
  594. (if strong-open-point
  595. (progn
  596. (add-face-text-property strong-open-point (match-end 0)
  597. '(:weight bold))
  598. (setq strong-open-point nil))
  599. (setq strong-open-point (point))))
  600. (t
  601. ;; this is a backslash escape sequence, skip over it
  602. ))
  603. (goto-char (match-end 0)))
  604. ;; skip chars that are not interesting
  605. (goto-char (1+ (point)))
  606. (skip-chars-forward "^_\\\\/" end))))))
  607. nil)
  608. (t 'font-lock-comment-face)))
  609. (defun haskell-font-lock-defaults-create ()
  610. "Locally set `font-lock-defaults' for Haskell."
  611. (setq-local font-lock-defaults
  612. '((haskell-font-lock-keywords)
  613. nil nil nil nil
  614. (font-lock-syntactic-face-function
  615. . haskell-syntactic-face-function)
  616. ;; Get help from font-lock-syntactic-keywords.
  617. (parse-sexp-lookup-properties . t)
  618. (font-lock-extra-managed-props . (composition)))))
  619. (defun haskell-fontify-as-mode (text mode)
  620. "Fontify TEXT as MODE, returning the fontified text."
  621. (with-temp-buffer
  622. (funcall mode)
  623. (insert text)
  624. (if (fboundp 'font-lock-ensure)
  625. (font-lock-ensure)
  626. (with-no-warnings (font-lock-fontify-buffer)))
  627. (buffer-substring (point-min) (point-max))))
  628. ;; Provide ourselves:
  629. (provide 'haskell-font-lock)
  630. ;; Local Variables:
  631. ;; coding: utf-8
  632. ;; tab-width: 8
  633. ;; End:
  634. ;;; haskell-font-lock.el ends here