Initial support for metaocaml

doc/manpage_ocamlformat.mld

@@ -575,6 +575,9 @@ OPTIONS
            Emit a warning if the formatted output exceeds the margin. The
            flag is unset by default.
 
+       --metaocaml
+           Enable MetaOCaml support. The flag is unset by default.
+
        -n N, --max-iters=N
            Fail if output of formatting does not stabilize within N
            iterations. May be set in .ocamlformat. The default value is 10.
@@ -601,6 +604,9 @@ OPTIONS
        --no-margin-check
            Unset margin-check.
 
+       --no-metaocaml
+           Unset metaocaml.
+
        --no-quiet
            Unset quiet.
 

lib/Cmts.ml

@@ -360,6 +360,10 @@ let relocate_ext_cmts (t : t) src (pre, pld) ~whole_loc =
     when List.is_empty pexp_attributes
          && Source.extension_using_sugar ~name:pre ~payload:e1.pexp_loc ->
       ()
+  | PStr [{pstr_desc= Pstr_eval (_, _); pstr_loc= _}]
+    when String.is_prefix ~prefix:"metaocaml." pre.txt
+         && Location.is_none pre.loc ->
+      ()
   | PStr [{pstr_desc= Pstr_eval _; pstr_loc; _}] ->
       let kwd_loc =
         match Source.loc_of_first_token_at src whole_loc LBRACKETPERCENT with

lib/Conf.ml

@@ -263,7 +263,8 @@ let default =
       ; ocaml_version= elt Ocaml_version.Releases.v4_04_0
       ; quiet= elt false
       ; disable_conf_attrs= elt false
-      ; version_check= elt true } }
+      ; version_check= elt true
+      ; metaocaml= elt false } }
 
 module V = struct
   let v0_12 = Version.make ~major:0 ~minor:12 ~patch:None
@@ -1454,6 +1455,12 @@ module Operational = struct
       (fun conf elt -> update conf ~f:(fun f -> {f with version_check= elt}))
       (fun conf -> conf.opr_opts.version_check)
 
+  let metaocaml =
+    let doc = "Enable MetaOCaml support." in
+    Decl.flag ~default ~names:["metaocaml"] ~doc ~kind
+      (fun conf elt -> update conf ~f:(fun f -> {f with metaocaml= elt}))
+      (fun conf -> conf.opr_opts.metaocaml)
+
   let options : Store.t =
     Store.
       [ elt comment_check
@@ -1464,7 +1471,8 @@ module Operational = struct
       ; elt ocaml_version
       ; elt quiet
       ; elt disable_conf_attrs
-      ; elt version_check ]
+      ; elt version_check
+      ; elt metaocaml ]
 end
 
 let options = Operational.options @ Formatting.options @ options

lib/Conf_t.ml

@@ -130,7 +130,8 @@ type opr_opts =
   ; ocaml_version: Ocaml_version.t elt
   ; quiet: bool elt
   ; disable_conf_attrs: bool elt
-  ; version_check: bool elt }
+  ; version_check: bool elt
+  ; metaocaml: bool elt }
 
 type t =
   { fmt_opts: fmt_opts

lib/Conf_t.mli

@@ -133,7 +133,8 @@ type opr_opts =
         (** Version of OCaml syntax of the output. *)
   ; quiet: bool elt
   ; disable_conf_attrs: bool elt
-  ; version_check: bool elt }
+  ; version_check: bool elt
+  ; metaocaml: bool elt }
 
 type t =
   { fmt_opts: fmt_opts

lib/Extended_ast.ml

@@ -237,8 +237,8 @@ module Parse = struct
     in
     Ast_mapper.{default_mapper with expr; pat; binding_op}
 
-  let ast (type a) (fg : a t) ~ocaml_version ~preserve_beginend ~input_name
-      str : a =
+  let ast (type a) (fg : a t) ~ocaml_version ~metaocaml ~preserve_beginend
+      ~input_name str : a =
     map fg (normalize_mapper ~ocaml_version ~preserve_beginend)
     @@
     let lexbuf = Lexing.from_string str in
@@ -247,13 +247,13 @@ module Parse = struct
     in
     Location.init_info lexbuf input_name ;
     match fg with
-    | Structure -> Parse.implementation ~ocaml_version lexbuf
-    | Signature -> Parse.interface ~ocaml_version lexbuf
-    | Use_file -> Parse.use_file ~ocaml_version lexbuf
-    | Core_type -> Parse.core_type ~ocaml_version lexbuf
-    | Module_type -> Parse.module_type ~ocaml_version lexbuf
-    | Expression -> Parse.expression ~ocaml_version lexbuf
-    | Repl_file -> Toplevel_lexer.repl_file ~ocaml_version lexbuf
+    | Structure -> Parse.implementation ~ocaml_version ~metaocaml lexbuf
+    | Signature -> Parse.interface ~ocaml_version ~metaocaml lexbuf
+    | Use_file -> Parse.use_file ~ocaml_version ~metaocaml lexbuf
+    | Core_type -> Parse.core_type ~ocaml_version ~metaocaml lexbuf
+    | Module_type -> Parse.module_type ~ocaml_version ~metaocaml lexbuf
+    | Expression -> Parse.expression ~ocaml_version ~metaocaml lexbuf
+    | Repl_file -> Toplevel_lexer.repl_file ~ocaml_version ~metaocaml lexbuf
     | Documentation ->
         let pos = (Location.curr lexbuf).loc_start in
         let pos = {pos with pos_fname= input_name} in

lib/Extended_ast.mli

@@ -35,6 +35,7 @@ module Parse : sig
   val ast :
        'a t
     -> ocaml_version:Ocaml_version.t
+    -> metaocaml:bool
     -> preserve_beginend:bool
     -> input_name:string
     -> string

lib/Fmt_ast.ml

@@ -613,7 +613,7 @@ let rec fmt_extension_aux c ctx ~key (ext, pld) =
   | _, PPat (({ppat_loc; _} as pat), _), (Pld _ | Top)
     when Source.extension_using_sugar ~name:ext ~payload:ppat_loc ->
       fmt_pattern c ~ext (sub_pat ~ctx pat)
-  | _ ->
+  | _ -> (
       let box =
         if c.conf.fmt_opts.ocp_indent_compat.v then
           match pld with
@@ -623,12 +623,40 @@ let rec fmt_extension_aux c ctx ~key (ext, pld) =
               hvbox c.conf.fmt_opts.stritem_extension_indent.v
         else Fn.id
       in
-      box
-        (wrap (str "[") (str "]")
-           ( str (Ext.Key.to_string key)
-           $ fmt_str_loc c ext
-           $ fmt_payload c (Pld pld) pld
-           $ fmt_if (Exposed.Right.payload pld) (str " ") ) )
+      let is_metaocaml_sugar =
+        if
+          String.is_prefix ~prefix:"metaocaml." ext.txt
+          && Location.is_none ext.loc
+        then
+          match pld with
+          | PStr [({pstr_desc= Pstr_eval (e, []); _} as pstr)] ->
+              let node =
+                match ext.txt with
+                | "metaocaml.escape" -> `Escape
+                | "metaocaml.bracket" -> `Bracket
+                | _ -> assert false
+              in
+              Some (node, e, Str pstr)
+          | _ -> assert false
+        else None
+      in
+      match is_metaocaml_sugar with
+      | Some (`Escape, e, ctx) ->
+          let parens =
+            match e.pexp_desc with Pexp_ident _ -> false | _ -> true
+          in
+          box (str ".~" $ fmt_expression c ~parens (sub_exp ~ctx e))
+      | Some (`Bracket, e, ctx) ->
+          box
+            (wrap (str ".< ") (str " >.")
+               (fmt_expression c (sub_exp ~ctx e)) )
+      | None ->
+          box
+            (wrap (str "[") (str "]")
+               ( str (Ext.Key.to_string key)
+               $ fmt_str_loc c ext
+               $ fmt_payload c (Pld pld) pld
+               $ fmt_if (Exposed.Right.payload pld) (str " ") ) ) )
 
 and fmt_extension = fmt_extension_aux ~key:Ext.Key.Regular
 
@@ -2974,7 +3002,8 @@ and fmt_class_signature c ~ctx ~pro ~epi ?ext self_ fields =
   in
   let ast x = Ctf x in
   let cmts_within =
-    if List.is_empty fields then (* Side effect order is important. *)
+    if List.is_empty fields then
+      (* Side effect order is important. *)
       Cmts.fmt_within ~pro:noop c (Ast.location ctx)
     else noop
   in

lib/Parse_with_comments.ml

@@ -85,7 +85,10 @@ let parse ?(disable_w50 = false) ?(disable_deprecated = false) parse fragment
         else not conf.opr_opts.quiet.v )
       ~f:(fun () ->
         let ocaml_version = conf.opr_opts.ocaml_version.v in
-        let ast = parse fragment ~ocaml_version ~input_name source in
+        let metaocaml = conf.opr_opts.metaocaml.v in
+        let ast =
+          parse fragment ~ocaml_version ~metaocaml ~input_name source
+        in
         Warnings.check_fatal () ;
         let comments =
           let mk_cmt = function
@@ -103,9 +106,10 @@ let parse ?(disable_w50 = false) ?(disable_deprecated = false) parse fragment
   in
   match List.rev !w50 with [] -> t | w50 -> raise (Warning50 w50)
 
-let parse_ast (conf : Conf.t) fg ~ocaml_version ~input_name s =
+let parse_ast (conf : Conf.t) fg ~ocaml_version ~metaocaml ~input_name s =
   let preserve_beginend = Poly.(conf.fmt_opts.exp_grouping.v = `Preserve) in
-  Extended_ast.Parse.ast fg ~ocaml_version ~preserve_beginend ~input_name s
+  Extended_ast.Parse.ast fg ~ocaml_version ~metaocaml ~preserve_beginend
+    ~input_name s
 
 (** [is_repl_block x] returns whether [x] is a list of REPL phrases and
     outputs of the form:

lib/Parse_with_comments.mli

@@ -31,6 +31,7 @@ val parse :
   -> ?disable_deprecated:bool
   -> (   'b
       -> ocaml_version:Ocaml_version.t
+      -> metaocaml:bool
       -> input_name:string
       -> string
       -> 'a )
@@ -57,6 +58,7 @@ val parse_ast :
      Conf.t
   -> 'a Extended_ast.t
   -> ocaml_version:Ocaml_version.t
+  -> metaocaml:bool
   -> input_name:string
   -> string
   -> 'a

lib/Std_ast.ml

@@ -56,19 +56,19 @@ let map (type a) (x : a t) (m : Ast_mapper.mapper) : a -> a =
   | Documentation -> Fn.id
 
 module Parse = struct
-  let ast (type a) (fg : a t) ~ocaml_version ~input_name str : a =
+  let ast (type a) (fg : a t) ~ocaml_version ~metaocaml ~input_name str : a =
     let lexbuf = Lexing.from_string str in
     let ocaml_version =
       Some Ocaml_version.(major ocaml_version, minor ocaml_version)
     in
     Location.init_info lexbuf input_name ;
     match fg with
-    | Structure -> Parse.implementation ~ocaml_version lexbuf
-    | Signature -> Parse.interface ~ocaml_version lexbuf
-    | Use_file -> Parse.use_file ~ocaml_version lexbuf
-    | Core_type -> Parse.core_type ~ocaml_version lexbuf
-    | Module_type -> Parse.module_type ~ocaml_version lexbuf
-    | Expression -> Parse.expression ~ocaml_version lexbuf
+    | Structure -> Parse.implementation ~ocaml_version ~metaocaml lexbuf
+    | Signature -> Parse.interface ~ocaml_version ~metaocaml lexbuf
+    | Use_file -> Parse.use_file ~ocaml_version ~metaocaml lexbuf
+    | Core_type -> Parse.core_type ~ocaml_version ~metaocaml lexbuf
+    | Module_type -> Parse.module_type ~ocaml_version ~metaocaml lexbuf
+    | Expression -> Parse.expression ~ocaml_version ~metaocaml lexbuf
     | Repl_file -> ()
     | Documentation -> ()
 end

lib/Std_ast.mli

@@ -36,6 +36,7 @@ module Parse : sig
   val ast :
        'a t
     -> ocaml_version:Ocaml_version.t
+    -> metaocaml:bool
     -> input_name:string
     -> string
     -> 'a

lib/Toplevel_lexer.mli

@@ -11,5 +11,6 @@
 
 val repl_file :
      ocaml_version:(int * int) option
+  -> metaocaml:bool
   -> Lexing.lexbuf
   -> Parsetree.repl_phrase list

lib/Toplevel_lexer.mll

@@ -52,7 +52,7 @@ and phrase buf = parse
   | _ as c   { Buffer.add_char buf c; phrase buf lexbuf }
 
 {
-let repl_file ~ocaml_version lx =
+let repl_file ~ocaml_version ~metaocaml lx =
   let x = token lx in
   let open Ocamlformat_parser_extended.Parsetree in
   List.fold_left (fun acc -> function
@@ -61,7 +61,7 @@ let repl_file ~ocaml_version lx =
           let filename = (Location.curr lx).loc_start.pos_fname in
           Lexing.set_filename cmd_lexbuf filename ;
           Lexing.set_position cmd_lexbuf pos_start ;
-          { prepl_phrase= Parse.toplevel_phrase ~ocaml_version cmd_lexbuf
+          { prepl_phrase= Parse.toplevel_phrase ~ocaml_version ~metaocaml cmd_lexbuf
           ; prepl_output= "" }
           :: acc
       | `Output ("", _) -> acc

test/cli/print_config.t

@@ -22,6 +22,7 @@ No redundant values:
   quiet=false
   disable-conf-attrs=false
   version-check=true
+  metaocaml=false
   assignment-operator=end-line (profile conventional (file .ocamlformat:1))
   break-before-in=fit-or-vertical (profile conventional (file .ocamlformat:1))
   break-cases=fit (profile conventional (file .ocamlformat:1))
@@ -101,6 +102,7 @@ Redundant values from the conventional profile:
   quiet=false
   disable-conf-attrs=false
   version-check=true
+  metaocaml=false
   assignment-operator=end-line (profile conventional (file .ocamlformat:1))
   break-before-in=fit-or-vertical (profile conventional (file .ocamlformat:1))
   break-cases=fit (profile conventional (file .ocamlformat:1))
@@ -180,6 +182,7 @@ Redundant values from the ocamlformat profile:
   quiet=false
   disable-conf-attrs=false
   version-check=true
+  metaocaml=false
   assignment-operator=end-line (profile ocamlformat (file .ocamlformat:1))
   break-before-in=fit-or-vertical (profile ocamlformat (file .ocamlformat:1))
   break-cases=nested (profile ocamlformat (file .ocamlformat:1))

tools/printast/printast.ml

@@ -3,21 +3,26 @@ open Ocamlformat_lib
 
 let ocaml_version = Ocaml_version.sys_version
 
-let extended_ast ppf syntax ~input_name content =
+let extended_ast ppf syntax ~input_name ~metaocaml content =
   let open Extended_ast in
   let (Any kind) = of_syntax syntax in
-  Parse.ast kind ~ocaml_version ~preserve_beginend:true ~input_name content
+  Parse.ast kind ~ocaml_version ~metaocaml ~preserve_beginend:true
+    ~input_name content
   |> Printast.ast kind ppf
 
-let std_ast ppf syntax ~input_name content =
+let std_ast ppf syntax ~input_name ~metaocaml content =
   let open Std_ast in
   let (Any kind) = of_syntax syntax in
-  Parse.ast kind ~ocaml_version ~input_name content |> Printast.ast kind ppf
+  Parse.ast kind ~ocaml_version ~metaocaml ~input_name content
+  |> Printast.ast kind ppf
 
 let get_arg () =
-  let std = ref false and input = ref None in
-  let opts = [("-std", Arg.Set std, "Use the standard parser")] in
-  let usage = "printast [-std] <file>" in
+  let std = ref false and input = ref None and metaocaml = ref false in
+  let opts =
+    [ ("-std", Arg.Set std, "Use the standard parser")
+    ; ("-metaocaml", Arg.Set metaocaml, "Enable metaocaml syntax") ]
+  in
+  let usage = "printast [-std] [-metaocaml] <file>" in
   Arg.parse opts (fun inp -> input := Some inp) usage ;
   let input =
     match !input with
@@ -26,13 +31,14 @@ let get_arg () =
         Printf.eprintf "Not enough argument\n" ;
         exit 2
   and parse_and_print = if !std then std_ast else extended_ast in
-  (parse_and_print, input)
+  (parse_and_print, input, !metaocaml)
 
 let () =
-  let parse_and_print, inputf = get_arg () in
+  let parse_and_print, inputf, metaocaml = get_arg () in
   let syntax =
     Option.value ~default:Syntax.Use_file (Syntax.of_fname inputf)
   in
   Printf.printf "Reading %S\n" inputf ;
   let content = In_channel.read_all inputf in
-  parse_and_print Format.std_formatter syntax ~input_name:inputf content
+  parse_and_print Format.std_formatter syntax ~input_name:inputf ~metaocaml
+    content