neocaml alternative font-lock-mode

init.el

;; OCaml stuff

; locate opam's site-lisp
(setq opam-share
      (replace-regexp-in-string "\n$" ""
         (shell-command-to-string "opam var share 2> /dev/null")))
(add-to-list 'load-path (expand-file-name "emacs/site-lisp" opam-share))

; merlin
(require 'merlin)
(require 'merlin-company)
(setq merlin-error-on-single-line t)
(setq merlin-completion-with-doc t)

; ocp-indent
(require 'ocp-indent)
(setq ocp-indent-path
     (concat
      (replace-regexp-in-string "\n$" ""
          (shell-command-to-string "opam var bin")) "/ocp-indent"))

; neocaml-mode
(use-package neocaml :ensure t)
(neocaml--setup-compilation) ; install compilation regexp

; Completely override the neocaml font-locking settings
(defun neocaml-use-alt-font-lock ()
  (defface ocaml-comment
    '((t :inherit font-lock-comment-face)) "")
  (defface ocaml-doc-comment
    '((t :inherit font-lock-doc-face)) "")
  (defface ocaml-directive
    '((t :inherit font-lock-preprocessor-face)) "")
  (defface ocaml-keyword-definition
    '((t :inherit font-lock-type-face)) "")
  (defface ocaml-keyword-block
    '((t :inherit font-lock-keyword-face)) "")
  (defface ocaml-keyword-control
    '((t :inherit font-lock-type-face)) "")
  (defface ocaml-keyword-exception
    '((t :inherit font-lock-comment-face)) "")
  (defface ocaml-keyword-module-manipulation
    '((t :inherit font-lock-variable-name-face)) "")
  (defface ocaml-operator-infix
    '((t :inherit font-lock-builtin-face)) "")
  (defface ocaml-operator-boolean
    '((t :inherit font-lock-type-face)) "")
  (defface ocaml-operator-hash
    '((t :inherit font-lock-type-face)) "")
  (defface ocaml-module-name
    '((t :inherit font-lock-function-name-face)) "")
  (defface ocaml-constructor
    '((t :inherit font-lock-function-name-face)) "")
  (defface ocaml-label
    '((t :inherit font-lock-variable-name-face)) "")

  (defun neocaml--alt-let-operator-keyword-only (node override &rest _)
    (let ((start (treesit-node-start node)))
      (treesit-fontify-with-override
       start (+ start 3) 'ocaml-keyword-definition override)))

  (defun neocaml--alt-treesit-font-lock-settings (language)
    (append
     (treesit-font-lock-rules
      :language language
      :feature 'doc-comment
      '((((comment) @ocaml-doc-comment)
         (:match "^(\\*\\*[^*]" @ocaml-doc-comment)))

      :language language
      :feature 'comment
      '((comment) @ocaml-comment)

      :language language
      :feature 'directive
      '(([(line_number_directive) (directive)]
         @font-lock-preprocessor-face))

      :language language
      :feature 'string
      '([(string) (quoted_string) (character)] @font-lock-string-face)

      :language language
      :feature 'keyword-definition
      '((["and" "as" "constraint" "class" "effect" "exception" "external" "fun"
          "function"  "functor" "in" "inherit" "initializer" "let" "method"
          "mutable" "module" "nonrec" "of" "private" "rec" "type" "val"
          "virtual" "|" "->"] @ocaml-keyword-definition)
        ((let_operator) @neocaml--alt-let-operator-keyword-only)
        ((let_and_operator) @neocaml--alt-let-operator-keyword-only))

      :language language
      :feature 'keyword-block
      '((["begin" "end" "object" "sig" "struct"] @ocaml-keyword-block))

      :language language
      :feature 'keyword-control
      '((["assert" "do" "done" "downto" "else" "for" "if" "lazy" "match" "new"
          "then" "to" "try" "when" "while" "with"]
         @ocaml-keyword-control)
        (((value_path :anchor (value_name) @ocaml-keyword-control)
          (:match "ignore" @ocaml-keyword-control))))

      :language language
      :feature 'keyword-exception
      `(((value_path :anchor (value_name) @ocaml-keyword-exception)
         (:match ,(rx bos (or "raise" "raise_notrace" "failwith" "invalid_arg")
                      eos)
                 @ocaml-keyword-exception)))

      :language language
      :feature 'keyword-module-manipulation
      '(([ "open" "include"] @ocaml-keyword-module-manipulation))

      :language language
      :feature 'operator-infix
      `(((infix_expression operator: _ @ocaml-operator-infix)
         (:match ,(rx bos (or "lor" "land" "lxor" "asr" "lsl" "lsr" "mod") eos)
                 @ocaml-operator-infix)))

      :language language
      :feature 'operator-boolean
      `(((infix_expression operator: _ @ocaml-operator-boolean)
         (:match ,(rx bos (or "&" "&&" "or" "||") eos)
                 @ocaml-operator-boolean)))

      :language language
      :feature 'operator-hash
      '((["#"] @ocaml-operator-hash)
        ((hash_operator) @ocaml-operator-hash))

      :language language
      :feature 'module-name
      '(([(module_name) (module_type_name)] @ocaml-module-name))

      :language language
      :feature 'constructor
      '(([(constructor_name) (tag)] @ocaml-constructor))

      :language language
      :feature 'label
      '((("~" @ocaml-label):? (label_name) @ocaml-label (":" @ocaml-label):?)
        ("?" @ocaml-label (label_name) @ocaml-label (":" @ocaml-label):?)
        (parameter
         ["?" "~"] @ocaml-label
         :anchor
         pattern: (value_pattern) @ocaml-label)
        (parameter
         "?" @ocaml-label
         :anchor
         "(" @ocaml-label
         pattern: (value_pattern) @ocaml-label)
        )
      )
      ; shebang doesn't work in ocaml-interface
      (when (eq language 'ocaml)
        (treesit-font-lock-rules
         :language language
         :feature 'directive
         '((shebang) @font-lock-preprocessor-face))))
    )

  (setq-local treesit-font-lock-settings
    (append
     (neocaml--alt-treesit-font-lock-settings 'ocaml)
     (neocaml--alt-treesit-font-lock-settings 'ocaml-interface)))

  (setq-local treesit-font-lock-feature-list
    '((doc-comment comment directive string keyword-definition
       keyword-block keyword-control keyword-exception
       keyword-module-manipulation operator-infix operator-boolean
       operator-hash module-name constructor label)
      () () ()))
  (treesit-major-mode-setup))

(add-hook 'neocaml-base-mode-hook
  (lambda ()
    (neocaml-use-alt-font-lock)
    (merlin-mode)
    (setq-local indent-line-function #'ocp-indent-line)
    (setq-local indent-region-function #'ocp-indent-region)))

test.ml

open List
open! List
include Int

(* This is a comment *)

(** The type for M *)
module type S = sig
  type t = Int of int | String of string

  val x : 'a -> unit

  val f : ?alpha:int -> x:int -> y:int -> bool
  (** This is a doc comment. *)
end

module A = struct
  type t = Int of int | String of string
  type 'a gadt =
  | Gint : int -> int gadt
  | Gstring : string -> string gadt

  type b = [ `Int of int | `String of int]
  type c = [ `A | b ]

  let x v = ignore (ref v)
  let f x =
    let open List in
    let open! List in
    if true then "" else begin
      for i = 0 to 1 do () done;
      let _x = lazy (2 * 3) in
      try "hu" with
      | Exit -> raise_notrace Exit
      | Failure e -> failwith e
      | Invalid_argument _ -> raise Exit
      | e -> assert (false)
    end

  let string = function
  | Int v -> "bla"
  | String v -> ignore (v); "hey"

  let string x = match x with
  | Int v -> "bla"
  | String v -> ignore (v); "hey"

  let poly = function
  | `A _ when true -> failwith "BLA"
  | _ -> 3
  ;;

  let rec f ?x ~x ~y = f ?x ~x ~y
  let rec f ?x ~x ~y = f ?x:None ~x:3 ~y:3
  let rec f ?x:a ~x:b ~y:c = f ?x:a ~x:b ~y:c
  let f ?(subtle_paren = true) () = subtle_paren
  let f ?name:(rename = true) () = rename
end

module Crunch = struct
  let id_of_filename s = failwith "TODO"

  let string_to_string ~id ~data:s =
    let len = String.length s in
    let len = len * 4 + (len / 18) * (3 + 2) in
    let b = Buffer.create (len + String.length id + 3) in
    let adds = Buffer.add_string in
    adds b "let "; adds b id; adds b " =\n  \"";
    for i = 0 to String.length s - 1 do
      if i mod 18 = 0 && i <> 0 then adds b "\\\n   ";
      let c = String.get_uint8 s i in
      adds b "\\x";
      Buffer.add_char b (Char.Ascii.lower_hex_digit_of_int (c lsr 4));
      Buffer.add_char b (Char.Ascii.lower_hex_digit_of_int (c      ))
    done;
    adds b "\"\n";
    Buffer.contents b
end

(* Let operators and annotations *)

open Result.Syntax

let[@inline] f x = x

let v =
  let* x = Ok (3. ** 3.)
  and* y = Ok 4 in
  let+ x = Ok 3
  and+ y = Ok 5 in
  Ok (x, y)

let the_bool_is_in_the_pudding =
  true || (false && true) || (true && true)

(* Object system and hash operators *)

let ( #. ) x proj = proj x

let f x =  x #. List.length

class virtual abstract_point x_init =
  object (self)
    method virtual get_x : int
    method get_offset = self#get_x - x_init
    method virtual private move : int -> unit
    initializer print_endline "hey"
  end

let () =
  let p =
    object
      val mutable x = 0
      method get_x = x
      method move d = x <- x + d
    end
  in
  ignore (p#get_x);
  ignore (p # get_x)

(* Directives *)

#3 "hey.ml"