Translate Lwt_log.file

The channel is not closed in the generated code, so manual intervention
is needed. 'set_close_on_exec' is no longer called on the fd.

Author: Julow

bin/lwt_log_to_logs/main.ml

@@ -28,7 +28,15 @@ let mk_log section cmd args =
 let mk_set_level section lvl =
   mk_apply_simple [ "Logs"; "Src"; "set_level" ] [ section; lvl ]
 
-let mk_format_reporter ~state ~template ~close_mode channel =
+let mk_format_reporter_of_channel channel =
+  mk_let_var "logs_formatter"
+    (mk_apply_simple [ "Format"; "formatter_of_out_channel" ] [ channel ])
+  @@ fun fmt ->
+  mk_apply_ident
+    [ "Logs"; "format_reporter" ]
+    [ (mk_lbl "app", fmt); (mk_lbl "dst", fmt); (Nolabel, mk_unit_val) ]
+
+let mk_channel ~state ~template ~close_mode channel =
   if Option.is_some template then
     add_comment state
       "Lwt_log.channel: The [~template] argument is unsupported. Use \
@@ -39,27 +47,42 @@ let mk_format_reporter ~state ~template ~close_mode channel =
       add_comment state
         "Lwt_log.channel: The [~close_mode] argument has been dropped. The \
          behavior is always [`Keep].");
-  let fmt_ident = "logs_formatter" in
-  let fmt_val = mk_exp_var fmt_ident in
   add_comment state
     "Format.formatter_of_out_channel: Argument is a [Lwt_io.output_channel] \
      but a [out_channel] is expected.";
-  mk_let
-    (Pat.var (mk_loc fmt_ident))
-    (mk_apply_simple [ "Format"; "formatter_of_out_channel" ] [ channel ])
-    (mk_apply_ident
-       [ "Logs"; "format_reporter" ]
-       [
-         (mk_lbl "app", fmt_val); (mk_lbl "dst", fmt_val); (Nolabel, mk_unit_val);
-       ])
+  mk_format_reporter_of_channel channel
+
+let mk_file ~state ~mode ~perm ~file_name =
+  let mk_mode append_mode =
+    Exp.list
+      [
+        append_mode;
+        mk_constr_exp [ "Open_wronly" ];
+        mk_constr_exp [ "Open_creat" ];
+        mk_constr_exp [ "Open_text" ];
+      ]
+  in
+  let mode =
+    mk_let_var "append_mode"
+      (Exp.match_
+         (value_of_lblopt ~default:(mk_variant_exp "Append") mode)
+         [
+           Exp.case (mk_variant_pat "Append") (mk_constr_exp [ "Open_append" ]);
+           Exp.case (mk_variant_pat "Truncate") (mk_constr_exp [ "Open_trunc" ]);
+         ])
+      mk_mode
+  in
+  let perm = value_of_lblopt ~default:(mk_const_int "0o640") perm in
+  add_comment state "[file]: Channel is never closed.";
+  mk_format_reporter_of_channel
+    (mk_apply_simple [ "open_out_gen" ] [ mode; perm; file_name ])
 
 let mk_reporter report_f =
   let report =
     let open Mk_function in
     mk_function
-      (return report_f $ (Nolabel, "src") $ (Nolabel, "level")
-      $ (mk_lbl "over", "over")
-      $ (Nolabel, "k") $ (Nolabel, "msgf"))
+      (return report_f $ arg "src" $ arg "level" $ arg ~lbl:`Lbl "over"
+     $ arg "k" $ arg "msgf")
   in
   Exp.record [ (mk_longident [ "Logs"; "report" ], None, Some report) ] None
 
@@ -215,16 +238,19 @@ let rewrite_apply_lwt_log ~state (unit, ident) args =
           take_lbl "close_mode" @@ fun close_mode ->
           take_lbl "channel" @@ fun channel ->
           take @@ fun _unit ->
-          return
-            (Some (mk_format_reporter ~state ~template ~close_mode channel))
+          return (Some (mk_channel ~state ~template ~close_mode channel))
       | "syslog" ->
           ignore_lblarg "template" @@ take_lblopt "paths"
           @@ fun paths ->
           take_lbl "facility" @@ fun facility ->
           take @@ fun _unit -> return (Some (mk_syslog ~state ~paths ~facility))
       | "file" ->
-          add_comment state (ident ^ " is no longer supported.");
-          return None
+          ignore_lblarg "template" @@ take_lblopt "mode"
+          @@ fun mode ->
+          take_lblopt "perm" @@ fun perm ->
+          take_lbl "file_name" @@ fun file_name ->
+          take @@ fun _unit ->
+          return (Some (mk_file ~state ~mode ~perm ~file_name))
       | _ -> return None)
   | _ -> return None
 

lib/ocamlformat_utils/ast_utils.ml

@@ -29,6 +29,12 @@ let mk_longident' = function
 
 let mk_longident ident = mk_loc (mk_longident' ident)
 let mk_constr_exp ?arg cstr = Exp.construct (mk_longident cstr) arg
+
+let mk_constr_pat ?arg cstr =
+  Pat.construct (mk_longident cstr) (Option.map (fun a -> ([], a)) arg)
+
+let mk_variant_exp ?arg cstr = Exp.variant (mk_loc (mk_loc cstr)) arg
+let mk_variant_pat ?arg cstr = Pat.variant (mk_loc (mk_loc cstr)) arg
 let same_longident a b = Longident.flatten a = b
 let mk_exp_ident ident = Exp.ident (mk_longident ident)
 let mk_exp_var s = mk_exp_ident [ s ]
@@ -42,6 +48,11 @@ let mk_none_ident = mk_longident [ "None" ]
 let mk_exp_some x = Exp.construct mk_some_ident (Some x)
 let mk_exp_none = Exp.construct mk_none_ident None
 let mk_typ_constr ?(params = []) lid = Typ.constr (mk_longident lid) params
+let mk_const_int i = Exp.constant (Const.integer i)
+let mk_lbl s = Labelled (mk_loc s)
+let mk_lblopt s = Optional (mk_loc s)
+let mk_pat_some arg = mk_constr_pat ~arg [ "Some" ]
+let mk_pat_none = mk_constr_pat [ "None" ]
 
 (* Construct [let var = lhs in (rhs var)]. *)
 let mk_let_var ident lhs rhs =
@@ -56,32 +67,41 @@ module Mk_function : sig
           let open Mk_function in
           mk_function
             (return (fun a b -> Exp.tuple [ a; b ])
-             $ (Nolabel, "a") $ (Nolabel, "b"))
+             $ arg "a" $ arg "b")
         in
       ]} *)
 
   type 'a t
+  type arg
 
-  val ( $ ) : (expression -> 'a) t -> arg_label * string -> 'a t
+  val arg : ?lbl:[ `Lbl | `Opt of expression option ] -> string -> arg
+  val ( $ ) : (expression -> 'a) t -> arg -> 'a t
   val return : 'a -> 'a t
   val mk_function : ?typ:type_constraint -> expression t -> expression
 end = struct
   type 'a t = expr_function_param list * 'a
+  type arg = expr_function_param * expression
 
-  let ( $ ) (params, body) (lbl, ident) =
-    let exp = mk_exp_var ident and pat = Pat.var (mk_loc ident) in
-    let params = mk_function_param ~lbl pat :: params in
-    (params, body exp)
-
+  let ( $ ) (params, body) (param, exp) = (param :: params, body exp)
   let return f = ([], f)
 
+  let arg ?lbl name =
+    let lbl, def =
+      match lbl with
+      | Some `Lbl -> (Some (mk_lbl name), None)
+      | Some (`Opt def) -> (Some (mk_lblopt name), def)
+      | None -> (None, None)
+    in
+    let exp = mk_exp_var name and pat = Pat.var (mk_loc name) in
+    (mk_function_param ?lbl ?def pat, exp)
+
   let mk_function ?typ (params, body) =
     Exp.function_ (List.rev params) typ (Pfunction_body body)
 end
 
-let mk_fun ?(arg_lbl = Nolabel) ?(arg_name = "x") f =
+let mk_fun ?(arg_name = "x") f =
   let open Mk_function in
-  mk_function (return f $ (arg_lbl, arg_name))
+  mk_function (return f $ arg arg_name)
 
 let is_unit_val = function
   | { pexp_desc = Pexp_construct (ident, None); _ } ->
@@ -98,13 +118,24 @@ let mk_binding_op ?(loc = !default_loc) ?(is_pun = false) op pat ?(args = [])
     ?(typ = None) exp =
   Exp.binding_op op pat args typ exp is_pun loc
 
-let mk_lbl s = Labelled (mk_loc s)
-let mk_lblopt s = Optional (mk_loc s)
 let mk_apply_ident ident args = Exp.apply (mk_exp_ident ident) args
 
 let mk_apply_simple f_ident args =
   mk_apply_ident f_ident (List.map (fun x -> (Nolabel, x)) args)
 
+(** Generate an expression that read the value of a optional argument obtained
+    with [Unpack_apply.take_lblopt]. *)
+let value_of_lblopt ~default arg =
+  match arg with
+  | Some (exp, `Lbl) -> exp
+  | Some (exp, `Opt) ->
+      Exp.match_ exp
+        [
+          Exp.case (mk_pat_some (Pat.var (mk_loc "x"))) (mk_exp_var "x");
+          Exp.case mk_pat_none default;
+        ]
+  | None -> default
+
 (** Flatten a pipelines composed of [|>] and [@@] into a [Pexp_apply] node. *)
 let rec flatten_apply exp =
   let flatten callee arg =

test/lwt_log_to_logs/migrate.t/foo.ml

@@ -90,6 +90,17 @@ let () =
   let _ = Lwt_log.file in
   ()
 
+let () =
+  let _ = Lwt_log.file ~template:"" ~file_name:"" () in
+  let _ = Lwt_log.file ~mode:`Truncate ~file_name:"" () in
+  let _ = let mode = `Append in Lwt_log.file ~mode ~file_name:"" () in
+  let _ = let mode = Some `Append in Lwt_log.file ?mode ~file_name:"" () in
+  let _ = Lwt_log.file ~perm:1 ~file_name:"" () in
+  let _ = let perm = 1 in Lwt_log.file ~perm ~file_name:"" () in
+  let _ = let perm = Some 1 in Lwt_log.file ?perm ~file_name:"" () in
+  let _ = Lwt_log.file ~file_name:"" () in
+  ()
+
 let _open_files () =
   (* Extracted from ocsigenserver's [src/server/ocsigen_messages.ml]. *)
   let open Lwt.Infix in