Do not erase syntax directives.

Author: Dreian

lib/Ast.ml

@@ -718,7 +718,9 @@ module Class_type_field = struct
 end
 
 type toplevel_item =
-  [`Item of structure_item | `Directive of toplevel_directive]
+  [ `Item of structure_item
+  | `Directive of toplevel_directive
+  | `Lexer of lexer_directive ]
 
 (** Ast terms of various forms. *)
 module T = struct
@@ -775,6 +777,8 @@ module T = struct
         Format.fprintf fs "Ctf:@\n%a@\n" Printast.class_type_field ctf
     | Tli (`Directive d) ->
         Format.fprintf fs "Dir:@\n%a" Printast.top_phrase (Ptop_dir d)
+    | Tli (`Lexer l) ->
+        Format.fprintf fs "Lex:@\n%a" Printast.top_phrase (Ptop_lex l)
     | Jkd jkd ->
         Format.fprintf fs "Jkd:@\n%a" (Printast.jkind_annotation 0) jkd
     | Top -> Format.pp_print_string fs "Top"
@@ -836,6 +840,7 @@ let location = function
   | Ctf x -> x.pctf_loc
   | Tli (`Item x) -> x.pstr_loc
   | Tli (`Directive x) -> x.pdir_loc
+  | Tli (`Lexer x) -> x.plex_loc
   | Jkd _ -> Location.none
   | Top -> Location.none
   | Rep -> Location.none

lib/Ast.mli

@@ -100,7 +100,9 @@ module Tyd : sig
 end
 
 type toplevel_item =
-  [`Item of structure_item | `Directive of toplevel_directive]
+  [ `Item of structure_item
+  | `Directive of toplevel_directive
+  | `Lexer of lexer_directive ]
 
 (** Ast terms of various forms. *)
 type t =

lib/Chunk.ml

@@ -57,7 +57,8 @@ let last_loc (type a) (fg : a list item) (l : a list) =
       List.last l
       >>= function
       | Ptop_def x -> List.last x >>| fun x -> x.pstr_loc
-      | Ptop_dir x -> Some x.pdir_loc )
+      | Ptop_dir x -> Some x.pdir_loc
+      | Ptop_lex x -> Some x.plex_loc )
 
 let mk ~attr_loc ~chunk_loc state items = {attr_loc; chunk_loc; state; items}
 

lib/Fmt_ast.ml

@@ -5428,10 +5428,22 @@ let fmt_toplevel_directive c ~semisemi dir =
   in
   Cmts.fmt c pdir_loc (box_semisemi c ~parent_ctx:Top semisemi (name $ args))
 
+let fmt_lexer_directive c ~semisemi l =
+  let toggle_to_string = function true -> "on" | false -> "off" in
+  let fmt_lexer_arg l =
+    match l.plex_desc with
+    | Plex_syntax {psyn_mode; psyn_toggle} ->
+        str
+          (Printf.sprintf "#syntax %s %s" psyn_mode.txt
+             (toggle_to_string psyn_toggle) )
+  in
+  box_semisemi c ~parent_ctx:Top semisemi (fmt_lexer_arg l)
+
 let flatten_ptop =
   List.concat_map ~f:(function
     | Ptop_def items -> List.map items ~f:(fun i -> `Item i)
-    | Ptop_dir d -> [`Directive d] )
+    | Ptop_dir d -> [`Directive d]
+    | Ptop_lex l -> [`Lexer l] )
 
 let fmt_toplevel ?(force_semisemi = false) c ctx itms =
   let itms = flatten_ptop itms in
@@ -5451,6 +5463,7 @@ let fmt_toplevel ?(force_semisemi = false) c ctx itms =
     match itm with
     | `Item i -> fmt_structure_item c ~last ~semisemi (sub_str ~ctx i)
     | `Directive d -> fmt_toplevel_directive c ~semisemi d
+    | `Lexer l -> fmt_lexer_directive c ~semisemi l
   in
   let ast x = Tli x in
   fmt_item_list c ctx update_config ast fmt_item itms

lib/Std_ast.ml

@@ -53,7 +53,8 @@ let map (type a) (x : a t) (m : Ast_mapper.mapper) : a -> a =
           match m.toplevel_phrase m x with
           | Ptop_def [] -> None
           | Ptop_def _ as x -> Some x
-          | Ptop_dir _ as x -> Some x )
+          | Ptop_dir _ as x -> Some x
+          | Ptop_lex _ as x -> Some x )
   | Core_type -> m.typ m
   | Module_type -> m.module_type m
   | Expression -> m.expr m

test/passing/tests/quotations.ml

@@ -1,3 +1,5 @@
+#syntax quotations on
+
 let simple_number = <[123]>
 
 let npower x_quoted n =

test/passing/tests/quotations.ml.js-ref

@@ -1,3 +1,5 @@
+#syntax quotations on
+
 let simple_number = <[123]>
 
 let npower x_quoted n =

vendor/parser-extended/ast_mapper.ml

@@ -85,6 +85,7 @@ type mapper = {
   with_constraint: mapper -> with_constraint -> with_constraint;
   directive_argument: mapper -> directive_argument -> directive_argument;
   toplevel_directive: mapper -> toplevel_directive -> toplevel_directive;
+  lexer_directive: mapper -> lexer_directive -> lexer_directive;
   toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase;
   repl_phrase: mapper -> repl_phrase -> repl_phrase;
 }
@@ -1105,10 +1106,19 @@ let default_mapper =
          ; pdir_arg= map_opt (this.directive_argument this) d.pdir_arg
          ; pdir_loc= this.location this d.pdir_loc } );
 
+    lexer_directive =
+      (fun this l ->
+         match l.plex_desc with
+         | Plex_syntax s ->
+           {plex_desc= Plex_syntax { psyn_mode = map_loc this s.psyn_mode
+                                   ; psyn_toggle = s.psyn_toggle };
+            plex_loc= this.location this l.plex_loc });
+
     toplevel_phrase =
       (fun this -> function
          | Ptop_def s -> Ptop_def (this.structure this s)
-         | Ptop_dir d -> Ptop_dir (this.toplevel_directive this d) );
+         | Ptop_dir d -> Ptop_dir (this.toplevel_directive this d)
+         | Ptop_lex l -> Ptop_lex (this.lexer_directive this l) );
 
     repl_phrase =
       (fun this p ->

vendor/parser-extended/lexer.mll

@@ -895,12 +895,26 @@ and directive already_consumed = parse
         let explanation = "line directives are not supported" in
         directive_error lexbuf explanation ~already_consumed ~directive
       }
-  | "syntax" [' ' '\t']+ (lowercase identchar*) [' ' '\t']+
-    (lowercase identchar*) [^ '\010' '\013']*
-      {
-        (* Syntax directives are not preserved by the lexer so we error out. *)
-        let explanation = "syntax directives are not supported" in
-        directive_error lexbuf explanation ~already_consumed ~directive:"syntax"
+  | "syntax" [' ' '\t']+ (lowercase identchar* as mode) [' ' '\t']+
+    (lowercase identchar* as toggle) [^ '\010' '\013']*
+      { let toggle =
+          match toggle with
+          | "on" -> true
+          | "off" -> false
+          | _ ->
+            directive_error lexbuf
+              ("syntax directive can only be toggled on or off; "
+               ^ toggle ^ " not recognized")
+              ~already_consumed ~directive:"syntax"
+        in (
+          match mode with
+            | "quotations" ->
+                Syntax_mode.quotations := toggle;
+            | _ ->
+                directive_error lexbuf ("unknown syntax mode " ^ mode)
+                  ~already_consumed ~directive:"syntax"
+        );
+        HASH_SYNTAX(mode, toggle)
       }
 (* End Jane Street modification *)
 

vendor/parser-extended/parser.mly

@@ -402,7 +402,8 @@ let erase_toplevel_phrases phrases =
     List.map
       (function
         | Ptop_def str -> Ptop_def (erase_str_items str)
-        | Ptop_dir _ as phrase -> phrase)
+        | Ptop_dir _ as phrase -> phrase
+        | Ptop_lex lex -> Ptop_lex lex)
       phrases
 
 (*
@@ -774,6 +775,16 @@ let package_type_of_module_type pmty =
   | _ ->
       err pmty.pmty_loc Neither_identifier_nor_with_type
 
+let mk_hashsyntax ~loc mode toggle =
+  Ptop_lex {
+      plex_desc =
+        Plex_syntax {
+             psyn_mode = mode;
+             psyn_toggle = toggle;
+        };
+      plex_loc = make_loc loc;
+    }
+
 let mk_directive_arg ~loc k =
   { pdira_desc = k;
     pdira_loc = make_loc loc;
@@ -990,6 +1001,7 @@ let erase_call_pos_type ~arg_label ~arg_type ~loc =
 %token                        LESSLBRACKET "<["
 %token                        RBRACKETGREATER "]>"
 %token                        DOLLAR "$"
+%token <string * bool>        HASH_SYNTAX "#syntax foo on" (* just an example *)
 (* End Jane Street extension *)
 
 /* Precedences and associativities.
@@ -4949,9 +4961,12 @@ any_longident:
 /* Toplevel directives */
 
 toplevel_directive:
-  hash dir = mkrhs(ident)
-  arg = ioption(mk_directive_arg(toplevel_directive_argument))
-    { mk_directive ~loc:$sloc dir arg }
+  | HASH_SYNTAX
+      { let mode, toggle = $1 in
+        mk_hashsyntax ~loc:$sloc (mkloc mode (make_loc $sloc)) toggle }
+  | hash dir = mkrhs(ident)
+    arg = ioption(mk_directive_arg(toplevel_directive_argument))
+      { mk_directive ~loc:$sloc dir arg }
 ;
 
 %inline toplevel_directive_argument: