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