Update Emacs packages
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.
This commit is contained in:
William Carroll
parent
de97c7bcd0
commit
9da3ffee41
1361 changed files with 16539 additions and 16483 deletions
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue