WIP: experiment with line directives

lib/Cmt.ml

@@ -26,6 +26,20 @@ module T = struct
 
   let is_docstring = function Comment _ -> false | Docstring _ -> true
 
+  let is_line_directive = function
+    | Docstring _ -> None
+    | Comment {txt; _} -> (
+      try
+        let pattern = "<LINE_DIRECTIVE:([0-9]+)>(.*)" in
+        let regex = Re.Posix.compile_pat pattern in
+        match Re.exec_opt regex txt with
+        | Some groups ->
+            let line_number = Int.of_string (Re.Group.get groups 1) in
+            let name = Re.Group.get groups 2 in
+            Some (line_number, name)
+        | None -> None
+      with _ -> None )
+
   let compare = Poly.compare
 
   let sexp_of_t cmt =

lib/Cmt.mli

@@ -19,6 +19,8 @@ val create_docstring : string -> Location.t -> t
 
 val is_docstring : t -> bool
 
+val is_line_directive : t -> (int * string) option
+
 val loc : t -> Location.t
 
 val txt : t -> string

lib/Cmts.ml

@@ -449,19 +449,23 @@ let find_cmts ?(filter = Fn.const true) t pos loc =
       picked )
 
 let break_comment_group source margin a b =
-  let a = Cmt.loc a and b = Cmt.loc b in
+  let loc_a = Cmt.loc a and loc_b = Cmt.loc b in
   let vertical_align =
-    Location.line_difference a b = 1 && Location.compare_start_col a b = 0
+    Location.line_difference loc_a loc_b = 1
+    && Location.compare_start_col loc_a loc_b = 0
   in
   let horizontal_align =
-    Location.line_difference a b = 0
+    Location.line_difference loc_a loc_b = 0
     && List.is_empty
-         (Source.tokens_between source a.loc_end b.loc_start
+         (Source.tokens_between source loc_a.loc_end loc_b.loc_start
               ~filter:(function _ -> true) )
   in
-  not
-    ( (Location.is_single_line a margin && Location.is_single_line b margin)
-    && (vertical_align || horizontal_align) )
+  Option.is_some (Cmt.is_line_directive a)
+  || Option.is_some (Cmt.is_line_directive b)
+  || not
+       ( ( Location.is_single_line loc_a margin
+         && Location.is_single_line loc_b margin )
+       && (vertical_align || horizontal_align) )
 
 module Asterisk_prefixed = struct
   let split txt {Location.loc_start; _} =
@@ -633,6 +637,13 @@ let fmt_cmt (conf : Conf.t) cmt ~fmt_code pos =
   | `Unwrapped (x, _) -> Unwrapped.fmt ~opn ~offset x
   | `Asterisk_prefixed x -> Asterisk_prefixed.fmt ~opn x
 
+let fmt_cmt (conf : Conf.t) cmt ~fmt_code pos =
+  match Cmt.is_line_directive cmt with
+  | Some (line, filename) ->
+      let open Fmt in
+      str (Format.sprintf "#%i %S" line filename)
+  | None -> fmt_cmt conf cmt ~fmt_code pos
+
 let fmt_cmts_aux t (conf : Conf.t) cmts ~fmt_code pos =
   let open Fmt in
   let groups =
@@ -670,7 +681,11 @@ let fmt_cmts t conf ~fmt_code ?pro ?epi ?(eol = Fmt.fmt "@\n") ?(adj = eol)
         let adj_cmt = eol_cmt && Location.line_difference last_loc loc = 1 in
         fmt_or_k eol_cmt (fmt_or_k adj_cmt adj eol) (fmt_opt epi)
       in
-      fmt_opt pro $ fmt_cmts_aux t conf cmts ~fmt_code pos $ epi
+      ( match List.hd cmts with
+      | Some cmt when Option.is_some @@ Cmt.is_line_directive cmt -> fmt "\n"
+      | _ -> fmt_opt pro )
+      $ fmt_cmts_aux t conf cmts ~fmt_code pos
+      $ epi
 
 let fmt_before t conf ~fmt_code ?pro ?(epi = Fmt.break 1 0) ?eol ?adj loc =
   fmt_cmts t conf (find_cmts t `Before loc) ~fmt_code ?pro ~epi ?eol ?adj loc

lib/dune

@@ -28,6 +28,7 @@
   (backend bisect_ppx))
  (libraries
   format_
+  re
   ocaml_common
   parser_standard
   parser_extended

test/passing/dune.inc

@@ -3506,8 +3506,7 @@
  (action
   (with-stdout-to line_directives.ml.stdout
    (with-stderr-to line_directives.ml.stderr
-     (with-accepted-exit-codes 1
-       (run %{bin:ocamlformat} --margin-check %{dep:tests/line_directives.ml}))))))
+     (run %{bin:ocamlformat} --margin-check %{dep:tests/line_directives.ml})))))
 
 (rule
  (alias runtest)

test/passing/tests/line_directives.ml.err

@@ -1,5 +0,0 @@
-ocamlformat: ignoring "tests/line_directives.ml" (syntax error)
-File "tests/line_directives.ml", line 1, characters 1-9:
-1 | #3 "f.ml"
-     ^^^^^^^^
-Error: Invalid lexer directive "#3 \"f.ml\"": line directives are not supported

test/passing/tests/line_directives.ml.ref

@@ -0,0 +1,7 @@
+#3 "f.ml"
+
+let x =
+
+#4 "f.ml"
+  y
+#5 "f.ml"

vendor/parser-extended/lexer.mll

@@ -617,13 +617,14 @@ rule token = parse
       { error lexbuf (Illegal_character illegal_char) }
 
 and directive = parse
-  | ([' ' '\t']* (['0'-'9']+ as _num) [' ' '\t']*
-        ("\"" ([^ '\010' '\013' '\"' ] * as _name) "\"") as directive)
+  | ([' ' '\t']* (['0'-'9']+ as line) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\""))
         [^ '\010' '\013'] *
       {
-        (* Line directives are not preserved by the lexer so we error out. *)
-        let explanation = "line directives are not supported" in
-        error lexbuf (Invalid_directive ("#" ^ directive, Some explanation))
+        let loc = Location.curr lexbuf in
+        let line = int_of_string line in
+        let s = Format.sprintf "<LINE_DIRECTIVE:%i>%s" line name in
+        COMMENT (s, loc)
       }
 and comment = parse
     "(*"

vendor/parser-standard/lexer.mll

@@ -616,13 +616,14 @@ rule token = parse
       { error lexbuf (Illegal_character illegal_char) }
 
 and directive = parse
-  | ([' ' '\t']* (['0'-'9']+ as _num) [' ' '\t']*
-        ("\"" ([^ '\010' '\013' '\"' ] * as _name) "\"") as directive)
+  | ([' ' '\t']* (['0'-'9']+ as line) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\""))
         [^ '\010' '\013'] *
       {
-        (* Line directives are not preserved by the lexer so we error out. *)
-        let explanation = "line directives are not supported" in
-        error lexbuf (Invalid_directive ("#" ^ directive, Some explanation))
+        let loc = Location.curr lexbuf in
+        let line = int_of_string line in
+        let s = Format.sprintf "<LINE_DIRECTIVE:%i>%s" line name in
+        COMMENT (s, loc)
       }
 and comment = parse
     "(*"