[nongnu] elpa/tuareg b59c422 6/6: Merge commit 'refs/pull/254/head' of github.com:/ocaml/tuareg into elpa/tuareg

[ELPA Syncer]

branch: elpa/tuareg
commit b59c422759506402f990b089dbaa91c0578e2c2e
Merge: 1a2aa93 ad456eb
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@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 ()