Support for runtime metaprogramming (#121)

Author: Dreian

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,7 @@ module Left_angle = struct
       | None, typ -> core_type typ )
     | Ptyp_object _ -> true
     | Ptyp_alias (typ, _) -> core_type typ
+    | Ptyp_quote _ -> true
     | _ -> false
 end
 
@@ -37,6 +38,7 @@ module Right_angle = struct
         | Some _, _ -> false
         | None, typ -> core_type typ )
       | Ptyp_object _ -> true
+      | Ptyp_quote _ -> true
       | _ -> false )
 
   let constructor_arguments = function

lib/Fmt_ast.ml

@@ -1282,6 +1282,11 @@ 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_fits_breaks c.conf "<[" "]>" (fmt_core_type c (sub_typ ~ctx t))
+  | Ptyp_splice t ->
+      fmt "$"
+      $ wrap_fits_breaks c.conf "(" ")" (fmt_core_type c (sub_typ ~ctx t))
 
 and fmt_labeled_tuple_type c lbl xtyp =
   match lbl with
@@ -3389,6 +3394,23 @@ 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
+          (Params.Exp.wrap c.conf ~parens
+             ( wrap_fits_breaks ~space:true c.conf "<[" "]>"
+                 (fmt_expression c ~box ?eol ~parens:false ~indent_wrap ?ext
+                    (sub_exp ~ctx expr) )
+             $ fmt_atrs ) )
+  | Pexp_splice expr ->
+      pro
+      $ hvbox 0
+          ( Params.Exp.wrap c.conf ~parens
+              ( Cmts.fmt c pexp_loc
+              @@ hvbox 2
+                   ( str "$"
+                   $ fmt_expression ~parens:true c (sub_exp ~ctx expr) ) )
+          $ fmt_atrs )
   | Pexp_hole -> pro $ hvbox 0 (fmt_hole () $ fmt_atrs)
   | Pexp_beginend e ->
       let wrap_beginend k =
@@ -5456,10 +5478,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 +5513,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 --max-iters=5 --profile=janestreet %{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)

test/passing/tests/quotations.err

@@ -0,0 +1,125 @@
+#syntax quotations on
+
+let simple_number = <[123]>
+
+let npower x_quoted n =
+  let rec loop m = if m = 0 then <[1]> else <[$x_quoted * $(loop (m - 1))]> in
+  loop n
+;;
+
+let example_function n = <[fun x -> $(npower <[x]> n)]>
+
+let longer_example m n =
+  let first_quote = <[fun x -> $(npower <[x]> m)]> in
+  let second_quote = <[fun y -> $(npower <[y]> n)]> in
+  let combined_quote = <[fun x -> $second_quote ($first_quote x)]> in
+  <[$combined_quote, $combined_quote]>
+;;
+
+let even_longer m n =
+  <[ fun x y ->
+     let xm = $(npower <[x]> m) in
+     let yn = $(npower <[y]> n) in
+     let z = xm + yn in
+     $(npower <[z]> (m + n)) ]>
+;;
+
+type s = <[int]>
+type t = s expr
+
+let f (x : t) : <[$(s) * $(s)]> expr = <[$x, $x + 1]>
+
+let double =
+  <[ let x = <[42]> in
+     <[123 + $x]> ]>
+;;
+
+(* Long lines and breaks *)
+
+let _ =
+  <[ let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = 1 in
+     [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+     ; aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+     ; aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+     ] ]>
+;;
+
+let _ =
+  <[ fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+       yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy
+       zzzzzzzzzzzzzzzzzzzzzzz ->
+     $( <[ xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+           + yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy ]>
+      , <[zzzzzzzzzzzzzzzzzzzzzzz]> ) ]>
+;;
+
+let _ =
+  let xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =
+    <[fun aaaaaaaaaaaaaaaaaaaaa -> aaaaaaaaaaaaaaaaaaaaa, aaaaaaaaaaaaaaaaaaaaa]>
+  in
+  <[ ( $xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+     , $xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+         (fun bbbbbbbbbbbbbbbbbbbbb -> bbbbbbbbbbbbbbbbbbbbb) ) ]>
+;;
+
+let _ =
+  fun xxxxxxxxxxxxxxxxxxxx ->
+  <[ fun zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz ->
+     $((fun yyyyyyyyyyyyyyyyyyyy -> <[zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz + 42]>)
+         xxxxxxxxxxxxxxxxxxxx) ]>
+;;
+
+(* Comments *)
+
+(* let q = <[fun xxxxxxxxxx -> (xxxxxxxxxx, xxxxxxxxxx, xxxxxxxxxx)]> in let f a =
+   <[$q $a + $q $a + $q $a]> in f <[111111111111111111]> *)
+
+let _ =
+  <[ 2222222222222222222222222222222222
+     + 555555555555555555555555555555
+     + 44444444444444444444
+     - 3333333333333333333333333333
+     (* these comments are meant to be completely ignored in the formatting and should be
+        processed correctly *)
+     + 987654321
+     - 654987987321654 ]>
+;;
+
+let _ =
+  <[ (* a *)
+     1
+     (* b *) + 2
+     + 3
+     + (* c *) 4
+     + (* dd *)
+       (* e *) 5
+     (* f *) + 6
+     (* ggg *)
+     (* h *) + 7 (* ii *) ]>
+;;
+
+let _ =
+  (* 1 *)
+  <[ (* 2 *)
+     fun (* 3 *) x (* 4 *) ->
+     (* 5 *)
+     $((* 6 *)
+         (fun (* 7 *)
+              (* 8 *) y (* 9 *) -> (* 10 *) y (* 11 *))
+         (* 12 *) <[(* 13 *) x (* 14 *)]> (* 15 *))
+     (* 16 *) ]>
+;;
+
+(* 17 *)
+
+type 'a t = <[int (* 1 *) -> $('a (* 2 *) -> 'a (* 3 *) -> <[int]> (* 4 *)) (* 5 *)]>
+(* 6 *)
+
+(* Attributes *)
+
+let _ =
+  <[ (fun xxxxxxxxxxxxx -> (555555 + xxxxxxxxxxxxx) [@nontail]) 1111333333777777 [@inlined]
+  ]>
+;;
+
+let _ = <[fun x -> $((fun y -> y) (<[x]> [@nontail])) [@inlined]]> [@boxed]

test/passing/tests/quotations.ml

@@ -0,0 +1 @@
+Warning: tests/quotations.ml:120 exceeds the margin