diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-font-lock.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-font-lock.el | 711 |
1 files changed, 711 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-font-lock.el b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-font-lock.el new file mode 100644 index 000000000000..8360c7dd06e3 --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-font-lock.el @@ -0,0 +1,711 @@ +;;; 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 |