branch: elpa/tuareg
commit b59c422759506402f990b089dbaa91c0578e2c2e
Merge: 1a2aa93 ad456eb
Author: Stefan Monnier <monn...@iro.umontreal.ca>
Commit: Stefan Monnier <monn...@iro.umontreal.ca>
Merge commit 'refs/pull/254/head' of github.com:/ocaml/tuareg into
elpa/tuareg
---
tuareg.el | 179 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---
1 file changed, 173 insertions(+), 6 deletions(-)
diff --git a/tuareg.el b/tuareg.el
index 12ea951..f8ecab0 100644
--- a/tuareg.el
+++ b/tuareg.el
@@ -460,8 +460,9 @@ Valid names are `browse-url', `browse-url-firefox', etc."
(defface tuareg-font-lock-extension-node-face
(if tuareg-faces-inherit-p
- '((t :inherit tuareg-font-lock-infix-extension-node-face
- :background "gray92"))
+ '((default :inherit tuareg-font-lock-infix-extension-node-face)
+ (((background dark)) :foreground "LightSteelBlue")
+ (t :background "gray92"))
'((((background light)) (:foreground "Orchid" :background "gray92"))
(((background dark)) (:foreground "LightSteelBlue" :background "gray92"))
(t (:foreground "LightSteelBlue"))))
@@ -470,6 +471,16 @@ Valid names are `browse-url', `browse-url-firefox', etc."
(defvar tuareg-font-lock-extension-node-face
'tuareg-font-lock-extension-node-face)
+(defface tuareg-font-lock-doc-markup-face
+ '((t :inherit font-lock-constant-face)) ; FIXME: find something better
+ "Face for mark-up syntax in OCaml doc comments."
+ :group 'tuareg-faces)
+
+(defface tuareg-font-lock-doc-verbatim-face
+ '((t :inherit fixed-pitch)) ; FIXME: find something better
+ "Face for verbatim text in OCaml doc comments (inside {v ... v})."
+ :group 'tuareg-faces)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support definitions
@@ -586,7 +597,7 @@ Regexp match data 0 points to the chars."
(if (or (eq (char-syntax (or (char-before mbegin) ?\ )) syntax)
(eq (char-syntax (or (char-after mend) ?\ )) syntax)
(memq (get-text-property mbegin 'face)
- '(tuareg-doc-face
+ '(font-lock-doc-face
font-lock-string-face
font-lock-comment-face
tuareg-font-lock-error-face
@@ -640,8 +651,6 @@ Regexp match data 0 points to the chars."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Font-Lock
-(defvar tuareg-doc-face 'font-lock-doc-face)
-
(defconst tuareg-font-lock-syntactic-keywords
;; Char constants start with ' but ' can also appear in identifiers.
;; Beware not to match things like '*)hel' or '"hel' since the first '
@@ -700,6 +709,162 @@ Regexp match data 0 points to the chars."
'syntax-table (string-to-syntax "|")))))
(c (error "Unexpected char '%c' starting delimited string" c))))))
+(defmacro tuareg--syntax-rules (&rest rules)
+ "Generate a function to parse according to RULES.
+Each argument has the form (RE BODY...) where RE is a regexp to
+match and BODY what to execute upon match. BODY is executed with
+point at the end of the match, `start' bound to the start of the
+match and `group' to the number of the first group in RE, if any.
+The returned function takes the two arguments BEGIN and END
+delimiting the region of interest. "
+ (let ((group-number 1)
+ (clauses nil)
+ (regexps nil))
+ (dolist (rule rules)
+ (let* ((re (macroexpand (car rule)))
+ (body (cdr rule))
+ (re-ngroups (regexp-opt-depth re))
+ (clause-body
+ (if (> re-ngroups 0)
+ `((let ((group ,(1+ group-number)))
+ ,@body))
+ body)))
+ (push re regexps)
+ (push `((match-beginning ,group-number) . ,clause-body)
+ clauses)
+ (setq group-number (+ group-number 1 re-ngroups))))
+ (let ((combined-re (mapconcat (lambda (re) (concat "\\(" re "\\)"))
+ (nreverse regexps) "\\|"))
+ (begin (gensym "begin"))
+ (end (gensym "end")))
+ `(lambda (,begin ,end)
+ (goto-char ,begin)
+ (while (and (< (point) ,end)
+ (re-search-forward ,combined-re ,end t)
+ (let ((start (match-beginning 0)))
+ (cond . ,(nreverse clauses))
+ t)))))))
+
+;; FIXME: using nil here is a tad unstable -- sometimes we get a full
+;; fontification as code (which is nice!), sometimes not.
+(defconst tuareg-font-lock-doc-code-face nil
+ "Face to use for parts of a doc comment marked up as code (ie, [TEXT]).")
+
+(defun tuareg-fontify-doc-comment (state)
+ (let ((beg (nth 8 state))
+ (end (save-excursion
+ (parse-partial-sexp (point) (point-max) nil nil state
+ 'syntax-table)
+ (point))))
+ (put-text-property beg end 'face 'font-lock-doc-face)
+ (when (and (eq (char-after (- end 2)) ?*)
+ (eq (char-after (- end 1)) ?\)))
+ (setq end (- end 2))) ; stop before closing "*)"
+ (save-excursion
+ (let ((case-fold-search nil))
+ (funcall
+ (tuareg--syntax-rules
+ ((rx "[")
+ ;; Fontify opening bracket.
+ (put-text-property start (1+ start) 'face
+ 'tuareg-font-lock-doc-markup-face)
+ ;; Skip balanced set of brackets.
+ (let ((level 1))
+ (while (and (< (point) end)
+ (re-search-forward (rx (? "\\") (in "[]"))
+ end 'noerror)
+ (let ((next (char-after (match-beginning 0))))
+ (cond
+ ((eq next ?\[)
+ (setq level (1+ level))
+ t)
+ ((eq next ?\])
+ (setq level (1- level))
+ (if (> level 0)
+ t
+ (forward-char -1)
+ nil))
+ (t t)))))
+ (put-text-property (1+ start) (point) 'face
+ tuareg-font-lock-doc-code-face)
+ (if (> level 0)
+ ;; Highlight unbalanced opening bracket.
+ (put-text-property start (1+ start) 'face
+ 'tuareg-font-lock-error-face)
+ ;; Fontify closing bracket.
+ (put-text-property (point) (1+ (point)) 'face
+ 'tuareg-font-lock-doc-markup-face)
+ (forward-char 1))))
+
+ ((rx "]")
+ (put-text-property start (1+ start) 'face
+ 'tuareg-font-lock-error-face))
+
+ ;; @-tag.
+ ((rx "@" (group (+ (in "a-z" "_"))))
+ (put-text-property start (point) 'face
+ 'tuareg-font-lock-doc-markup-face)
+ ;; Use code face for the first argument of some tags.
+ (when (and (member (match-string group)
+ '("param" "raise" "before"))
+ (looking-at (rx (+ space)
+ (group
+ (+ (in "a-zA-Z0-9" "_.'-"))))))
+ (put-text-property (match-beginning 1) (match-end 1) 'face
+ tuareg-font-lock-doc-code-face)
+ (goto-char (match-end 0))))
+
+ ;; Cross-reference.
+ ((rx "{!" (? (or "tag" "module" "modtype" "class"
+ "classtype" "val" "type"
+ "exception" "attribute" "method"
+ "section" "const" "recfield")
+ ":")
+ (group (* (in "a-zA-Z0-9" "_.'"))))
+ (put-text-property start (match-beginning group) 'face
+ 'tuareg-font-lock-doc-markup-face)
+ ;; Use code face for the reference.
+ (put-text-property (match-beginning group) (match-end group) 'face
+ tuareg-font-lock-doc-code-face))
+
+ ;; {v ... v}
+ ((rx "{v" (in " \t\n"))
+ (put-text-property start (+ 3 start) 'face
+ 'tuareg-font-lock-doc-markup-face)
+ (let ((verbatim-end end))
+ (when (re-search-forward (rx (in " \t\n") "v}")
+ end 'noerror)
+ (setq verbatim-end (match-beginning 0))
+ (put-text-property verbatim-end (point) 'face
+ 'tuareg-font-lock-doc-markup-face))
+ (put-text-property (+ 3 start) verbatim-end 'face
+ 'tuareg-font-lock-doc-verbatim-face)))
+
+ ;; Other {..} and <..> constructs.
+ ((rx (or (seq "{"
+ (or (or "-" ":" "_" "^"
+ "b" "i" "e" "C" "L" "R"
+ "ul" "ol" "%"
+ "")
+ ;; Section header with optional label.
+ (seq (+ digit)
+ (? ":"
+ (+ (in "a-zA-Z0-9" "_"))))))
+ "}"
+ ;; HTML-style tags
+ (seq "<" (? "/")
+ (or "b" "i" "code" "ul" "ol" "li"
+ "center" "left" "right"
+ (seq "h" (+ digit)))
+ ">")))
+ (put-text-property start (point) 'face
+ 'tuareg-font-lock-doc-markup-face))
+
+ ;; Escaped syntax characters.
+ ((rx "\\" (in "{}[]@"))))
+ beg end))))
+ nil)
+
(defun tuareg-font-lock-syntactic-face-function (state)
"`font-lock-syntactic-face-function' for Tuareg."
(if (nth 3 state)
@@ -709,7 +874,7 @@ Regexp match data 0 points to the chars."
(eq (char-after (+ start 2)) ?*)
(not (eq (char-after (+ start 3)) ?*)))
;; This is a documentation comment
- tuareg-doc-face
+ (tuareg-fontify-doc-comment state)
font-lock-comment-face))))
;; Initially empty, set in `tuareg--install-font-lock-1'
@@ -1169,6 +1334,8 @@ This based on the fontification and is faster than
calling `syntax-ppss'."
(memq face '(font-lock-comment-face
font-lock-comment-delimiter-face
font-lock-doc-face
+ tuareg-font-lock-doc-markup-face
+ tuareg-font-lock-doc-verbatim-face
font-lock-string-face)))))
(defun tuareg--pattern-pre-form-let ()
