Support for runtime metaprogramming

lib/Ast.ml

@@ -220,7 +220,7 @@ module Exp = struct
      |Pexp_override _ | Pexp_open _ | Pexp_extension _ | Pexp_hole
      |Pexp_record _ | Pexp_record_unboxed_product _ | Pexp_array _
      |Pexp_list _ | Pexp_list_comprehension _ | Pexp_array_comprehension _
-     |Pexp_unboxed_tuple _ | Pexp_idx _ ->
+     |Pexp_unboxed_tuple _ | Pexp_idx _ | Pexp_quote _ | Pexp_splice _ ->
         true
     | Pexp_constant c -> not (is_uminus_constant c)
     | Pexp_prefix (op, _) -> not (is_uminus_op op || is_uplus_op op)
@@ -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
@@ -1055,7 +1060,9 @@ end = struct
               | {pof_desc= Oinherit t1; _} -> typ == t1 ) )
       | Ptyp_class (_, l) -> assert (List.exists l ~f)
       | Ptyp_of_kind _ -> assert false
-      | Ptyp_constr_unboxed (_, t1N) -> assert (List.exists t1N ~f) )
+      | Ptyp_constr_unboxed (_, t1N) -> assert (List.exists t1N ~f)
+      | Ptyp_quote t1 -> assert (typ == t1)
+      | Ptyp_splice t1 -> assert (typ == t1) )
     | Td {ptype_params; ptype_cstrs; ptype_kind; ptype_manifest; _} ->
         assert (
           List.exists ptype_params ~f:fst_f
@@ -1448,7 +1455,7 @@ end = struct
        |Pexp_variant _ | Pexp_while _ | Pexp_hole | Pexp_beginend _
        |Pexp_parens _ | Pexp_cons _ | Pexp_letopen _
        |Pexp_indexop_access _ | Pexp_prefix _ | Pexp_infix _ | Pexp_stack _
-       |Pexp_idx _ ->
+       |Pexp_idx _ | Pexp_quote _ | Pexp_splice _ ->
           assert false
       | Pexp_extension (_, ext) -> assert (check_extensions ext)
       | Pexp_object {pcstr_self; _} ->
@@ -1596,7 +1603,9 @@ end = struct
          |Pexp_letopen (_, e)
          |Pexp_poly (e, _)
          |Pexp_send (e, _)
-         |Pexp_setinstvar (_, e) ->
+         |Pexp_setinstvar (_, e)
+         |Pexp_quote e
+         |Pexp_splice e ->
             assert (e == exp)
         | Pexp_sequence (e1, e2) -> assert (e1 == exp || e2 == exp)
         | Pexp_setfield (e1, _, e2) | Pexp_while (e1, e2) ->
@@ -1784,7 +1793,7 @@ end = struct
       | Ptyp_constr _ -> Some (Apply, Non)
       | Ptyp_any | Ptyp_var _ | Ptyp_object _ | Ptyp_class _
        |Ptyp_variant _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_extension _
-       |Ptyp_of_kind _ ->
+       |Ptyp_of_kind _ | Ptyp_quote _ | Ptyp_splice _ ->
           None
       | Ptyp_constr_unboxed (_, _ :: _ :: _) -> Some (Comma, Non)
       | Ptyp_constr_unboxed _ -> Some (Apply, Non) )
@@ -1921,7 +1930,9 @@ end = struct
       | Ptyp_any | Ptyp_var _ | Ptyp_constr _ | Ptyp_object _
        |Ptyp_class _ | Ptyp_variant _ | Ptyp_poly _ | Ptyp_extension _ ->
           None
-      | Ptyp_constr_unboxed _ | Ptyp_of_kind _ -> None )
+      | Ptyp_constr_unboxed _ | Ptyp_of_kind _ | Ptyp_quote _ | Ptyp_splice _
+        ->
+          None )
     | Td _ -> None
     | Tyv _ -> None
     | Kab _ -> None
@@ -2313,6 +2324,7 @@ end = struct
         | Pexp_apply (_, args) -> continue (snd (List.last_exn args))
         | Pexp_tuple es -> continue (snd (List.last_exn es))
         | Pexp_unboxed_tuple _ -> false
+        | Pexp_splice e -> continue e
         | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
          |Pexp_constraint _
          |Pexp_construct (_, None)
@@ -2323,7 +2335,7 @@ end = struct
          |Pexp_variant (_, None)
          |Pexp_hole | Pexp_while _ | Pexp_beginend _ | Pexp_parens _
          |Pexp_indexop_access _ | Pexp_list_comprehension _
-         |Pexp_array_comprehension _ | Pexp_idx _ ->
+         |Pexp_array_comprehension _ | Pexp_idx _ | Pexp_quote _ ->
             false
       in
       Exp.mem_cls cls exp
@@ -2396,6 +2408,7 @@ end = struct
       | Pexp_apply (_, args) -> continue (snd (List.last_exn args))
       | Pexp_tuple es -> continue (snd (List.last_exn es))
       | Pexp_unboxed_tuple _ -> false
+      | Pexp_splice e -> continue e
       | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
        |Pexp_constraint _
        |Pexp_construct (_, None)
@@ -2406,7 +2419,7 @@ end = struct
        |Pexp_variant (_, None)
        |Pexp_hole | Pexp_while _ | Pexp_beginend _ | Pexp_parens _
        |Pexp_list_comprehension _ | Pexp_array_comprehension _ | Pexp_idx _
-        ->
+       |Pexp_quote _ ->
           false
     in
     Hashtbl.find_or_add marked_parenzed_inner_nested_match exp

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/Exposed.ml

@@ -21,6 +21,14 @@ module Left_angle = struct
       | None, typ -> core_type typ )
     | Ptyp_object _ -> true
     | Ptyp_alias (typ, _) -> core_type typ
+    | Ptyp_quote _ -> true
+    | _ -> false
+
+  let rec expression exp =
+    match exp.pexp_desc with
+    | Pexp_apply (exp, _) -> expression exp
+    | Pexp_sequence (exp, _) -> expression exp
+    | Pexp_quote _ -> true
     | _ -> false
 end
 
@@ -37,6 +45,7 @@ module Right_angle = struct
         | Some _, _ -> false
         | None, typ -> core_type typ )
       | Ptyp_object _ -> true
+      | Ptyp_quote _ -> true
       | _ -> false )
 
   let constructor_arguments = function
@@ -150,6 +159,37 @@ module Right_angle = struct
     | PSig {psg_items; _} -> list ~elt:signature_item psg_items
     | PTyp t -> core_type t
     | PPat _ -> false
+
+  let rec expression exp =
+    match exp.pexp_desc with
+    | Pexp_let (_, exp) -> expression exp
+    | Pexp_function cases -> case (List.last_exn cases)
+    | Pexp_fun (_, exp) -> expression exp
+    | Pexp_apply (_, args) -> expression (snd (List.last_exn args))
+    | Pexp_match (_, (_ :: _ as cases)) -> case (List.last_exn cases)
+    | Pexp_try (_, (_ :: _ as cases)) -> case (List.last_exn cases)
+    | Pexp_cons elems -> expression (List.last_exn elems)
+    | Pexp_construct (_, Some exp) -> expression exp
+    | Pexp_variant (_, Some exp) -> expression exp
+    | Pexp_ifthenelse (if_branch, None) ->
+        let last = (List.last_exn if_branch).if_body in
+        expression last
+    | Pexp_ifthenelse (_, Some exp) -> expression exp
+    | Pexp_sequence (_, exp) -> expression exp
+    | Pexp_setinstvar (_, exp) -> expression exp
+    | Pexp_letmodule (_, _, _, _, exp) -> expression exp
+    | Pexp_letexception (_, exp) -> expression exp
+    | Pexp_assert exp -> expression exp
+    | Pexp_lazy exp -> expression exp
+    | Pexp_poly (exp, None) -> expression exp
+    | Pexp_newtype (_, exp) -> expression exp
+    | Pexp_open (_, exp) -> expression exp
+    | Pexp_letop {let_= _; ands= _; body} -> expression body
+    | Pexp_stack exp -> expression exp
+    | Pexp_quote _ -> true
+    | _ -> false
+
+  and case {pc_lhs= _; pc_guard= _; pc_rhs} = expression pc_rhs
 end
 
 module Right_square = struct

lib/Exposed.mli

@@ -20,6 +20,8 @@ open Extended_ast
 (** Predicates for [<] on the LHS of printed AST nodes. *)
 module Left_angle : sig
   val core_type : core_type -> bool
+
+  val expression : expression -> bool
 end
 
 module Right_angle : sig
@@ -33,6 +35,8 @@ module Right_angle : sig
 
   val payload : payload -> bool
 
+  val expression : expression -> bool
+
   val list : elt:('a -> bool) -> 'a list -> bool
   (** [list ~elt l] holds iff [elt] holds of the {i last} element in [l], and
       is [false] if [l] is empty. *)

lib/Fmt_ast.ml

@@ -1282,6 +1282,8 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
            ( fmt "type"
            $ fmt_jkind_constr ~ctx:(Typ typ) c {txt= jk; loc= typ.ptyp_loc}
            ) )
+  | Ptyp_quote t -> wrap "<[" "]>" (fmt_core_type c (sub_typ ~ctx t))
+  | Ptyp_splice t -> fmt "$" $ fmt_core_type c (sub_typ ~ctx t)
 
 and fmt_labeled_tuple_type c lbl xtyp =
   match lbl with
@@ -3389,6 +3391,19 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       pro $ fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x
   | Pexp_poly _ ->
       impossible "only used for methods, handled during method formatting"
+  | Pexp_quote expr ->
+      pro
+      $ hvbox 0
+          (wrap "<[" "]>"
+             (fmt_expression c ~box ?eol ~parens:false ~indent_wrap ?ext
+                (sub_exp ~ctx expr) ) )
+  | Pexp_splice expr ->
+      pro
+      $ Params.parens_if parens c.conf
+          ( Cmts.fmt c pexp_loc
+          @@ hvbox 2
+               (str "$" $ fmt_expression ~parens:true c (sub_exp ~ctx expr))
+          )
   | Pexp_hole -> pro $ hvbox 0 (fmt_hole () $ fmt_atrs)
   | Pexp_beginend e ->
       let wrap_beginend k =
@@ -5456,10 +5471,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
@@ -5479,6 +5506,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

test/passing/dune.inc

@@ -10642,6 +10642,42 @@
  (package ocamlformat)
  (action (diff tests/qtest.ml.js-err qtest.ml.js-stderr)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to quotations.ml.stdout
+   (with-stderr-to quotations.ml.stderr
+     (setenv TERM dumb (run %{bin:ocamlformat} --margin-check %{dep:tests/quotations.ml}))))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/quotations.ml quotations.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/quotations.ml.err quotations.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to quotations.ml.js-stdout
+   (with-stderr-to quotations.ml.js-stderr
+     (setenv TERM dumb (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/quotations.ml}))))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/quotations.ml.js-ref quotations.ml.js-stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/quotations.ml.js-err quotations.ml.js-stderr)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)