add fmt command to format .wast file

src/bin/owi.ml

@@ -52,6 +52,19 @@ let shared_man =
 
 let version = "%%VERSION%%"
 
+let fmt_cmd =
+  let open Cmdliner in
+  let info =
+    let doc = "Format a .wat or .wast file" in
+    let man = [] @ shared_man in
+    Cmd.info "fmt" ~version ~doc ~sdocs ~man
+  in
+  let inplace =
+    let doc = "Format in-place, overwriting input file" in
+    Cmdliner.Arg.(value & flag & info [ "inplace"; "i" ] ~doc)
+  in
+  Cmd.v info Term.(const Cmd_fmt.cmd $ inplace $ file)
+
 let opt_cmd =
   let open Cmdliner in
   let info =
@@ -104,7 +117,7 @@ let cli =
     Cmd.info "owi" ~version ~doc ~sdocs ~man
   in
   let default = Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)) in
-  Cmd.group info ~default [ opt_cmd; run_cmd; script_cmd; sym_cmd ]
+  Cmd.group info ~default [ fmt_cmd; opt_cmd; run_cmd; script_cmd; sym_cmd ]
 
 let main () = exit @@ Cmdliner.Cmd.eval cli
 

src/cmd_fmt.ml

@@ -0,0 +1,36 @@
+(* SPDX-License-Identifier: AGPL-3.0-or-later *)
+
+open Syntax
+
+let get_printer filename =
+  if not @@ Sys.file_exists filename then
+    error_s "file `%s` doesn't exist" filename
+  else
+    let ext = Filename.extension filename in
+    match ext with
+    | ".wat" ->
+      let+ v = Parse.Module.from_file ~filename in
+      fun fmt () -> Text.pp_modul fmt v
+    | ".wast" ->
+      let+ v = Parse.Script.from_file ~filename in
+      fun fmt () -> Text.pp_script fmt v
+    | _ -> error_s "unsupported file extension"
+
+let cmd inplace (file : string) =
+  match get_printer file with
+  | Error e ->
+    Format.pp_err "%s@." e;
+    exit 1
+  | Ok pp ->
+    if inplace then
+      let chan = open_out file in
+      Fun.protect
+        ~finally:(fun () -> close_out chan)
+        (fun () ->
+          let fmt = Stdlib.Format.formatter_of_out_channel chan in
+          Format.pp fmt "%a@\n" pp () )
+    else Format.pp_std "%a@\n" pp ()
+
+let format_file_to_string (file : string) =
+  let+ pp = get_printer file in
+  Format.asprintf "%a@\n" pp ()

src/dune

@@ -5,6 +5,7 @@
   check
   choice_monad
   choice_monad_intf
+  cmd_fmt
   cmd_opt
   cmd_run
   cmd_script

src/text.ml

@@ -20,7 +20,7 @@ type global =
   }
 
 let pp_global fmt (g : global) =
-  pp fmt "(global %a %a %a)" pp_id_opt g.id pp_global_type g.typ pp_expr g.init
+  pp fmt "(global%a %a %a)" pp_id_opt g.id pp_global_type g.typ pp_expr g.init
 
 type data_mode =
   | Data_passive
@@ -38,7 +38,7 @@ type data =
   }
 
 let pp_data fmt (d : data) =
-  pp fmt {|(data %a %a %S)|} pp_id_opt d.id pp_data_mode d.mode d.init
+  pp fmt {|(data%a %a %S)|} pp_id_opt d.id pp_data_mode d.mode d.init
 
 type elem_mode =
   | Elem_passive
@@ -63,7 +63,7 @@ type elem =
 let pp_elem_expr fmt e = pp fmt "(item %a)" pp_expr e
 
 let pp_elem fmt (e : elem) =
-  pp fmt "@[<hov 2>(elem %a %a %a %a)@]" pp_id_opt e.id pp_elem_mode e.mode
+  pp fmt "@[<hov 2>(elem%a %a %a %a)@]" pp_id_opt e.id pp_elem_mode e.mode
     pp_ref_type e.typ
     (pp_list ~pp_sep:pp_newline pp_elem_expr)
     e.init
@@ -98,7 +98,7 @@ type modul =
   }
 
 let pp_modul fmt (m : modul) =
-  pp fmt "(module %a@\n  @[<v>%a@]@\n)" pp_id_opt m.id
+  pp fmt "(module%a@\n  @[<v>%a@]@\n)" pp_id_opt m.id
     (pp_list ~pp_sep:pp_newline pp_module_field)
     m.fields
 
@@ -108,7 +108,7 @@ type action =
 
 let pp_action fmt = function
   | Invoke (mod_name, name, c) ->
-    pp fmt "(invoke %a %s %a)" pp_id_opt mod_name name pp_consts c
+    pp fmt {|(invoke%a "%s" %a)|} pp_id_opt mod_name name pp_consts c
   | Get _ -> pp fmt "<action_get TODO>"
 
 type result_const =

src/types.ml

@@ -34,7 +34,7 @@ type _ indice =
 
 let pp_id fmt id = pp fmt "$%s" id
 
-let pp_id_opt fmt = function None -> () | Some i -> pp_id fmt i
+let pp_id_opt fmt = function None -> () | Some i -> pp fmt " %a" pp_id i
 
 let pp_indice (type kind) fmt : kind indice -> unit = function
   | Raw u -> pp_int fmt u
@@ -224,7 +224,7 @@ let pp_limits fmt { min; max } =
 
 type nonrec mem = string option * limits
 
-let pp_mem fmt (id, ty) = pp fmt "(memory %a %a)" pp_id_opt id pp_limits ty
+let pp_mem fmt (id, ty) = pp fmt "(memory%a %a)" pp_id_opt id pp_limits ty
 
 type nonrec final =
   | Final
@@ -294,7 +294,7 @@ let pp_val_type fmt = function
 
 type nonrec 'a param = string option * 'a val_type
 
-let pp_param fmt (id, vt) = pp fmt "(param %a %a)" pp_id_opt id pp_val_type vt
+let pp_param fmt (id, vt) = pp fmt "(param%a %a)" pp_id_opt id pp_val_type vt
 
 type nonrec 'a param_type = 'a param list
 
@@ -306,6 +306,11 @@ let pp_result_ fmt vt = pp fmt "(result %a)" pp_val_type vt
 
 let pp_result_type fmt results = pp_list ~pp_sep:pp_space pp_result_ fmt results
 
+(* wrap printer to print a space before a non empty list *)
+(* TODO or make it an optional arg of pp_list? *)
+let with_space_list printer fmt l =
+  match l with [] -> () | _l -> pp fmt " %a" printer l
+
 (* TODO: add a third case that only has (pt * rt) and is the only one used in simplified *)
 type 'a block_type =
   | Bt_ind : 'a indice -> (< with_ind_bt ; .. > as 'a) block_type
@@ -315,7 +320,12 @@ type 'a block_type =
 
 let pp_block_type (type kind) fmt : kind block_type -> unit = function
   | Bt_ind ind -> pp fmt "(type %a)" pp_indice ind
-  | Bt_raw (_ind, (pt, rt)) -> pp fmt "%a %a" pp_param_type pt pp_result_type rt
+  | Bt_raw (_ind, (pt, rt)) ->
+    pp fmt "%a%a"
+      (with_space_list pp_param_type)
+      pt
+      (with_space_list pp_result_type)
+      rt
 
 let pp_block_type_opt fmt = function
   | None -> ()
@@ -324,7 +334,11 @@ let pp_block_type_opt fmt = function
 type nonrec 'a func_type = 'a param_type * 'a result_type
 
 let pp_func_type fmt (params, results) =
-  pp fmt "(func %a %a)" pp_param_type params pp_result_type results
+  pp fmt "(func%a%a)"
+    (with_space_list pp_param_type)
+    params
+    (with_space_list pp_result_type)
+    results
 
 type nonrec 'a table_type = limits * 'a ref_type
 
@@ -537,22 +551,19 @@ let rec pp_instr fmt = function
   | Nop -> pp fmt "nop"
   | Unreachable -> pp fmt "unreachable"
   | Block (id, bt, e) ->
-    pp fmt "(block %a %a@\n  @[<v>%a@])" pp_id_opt id pp_block_type_opt bt
-      pp_expr e
+    pp fmt "(block%a%a@\n  @[<v>%a@])" pp_id_opt id pp_block_type_opt bt pp_expr
+      e
   | Loop (id, bt, e) ->
-    pp fmt "(loop %a %a@\n  @[<v>%a@])" pp_id_opt id pp_block_type_opt bt
-      pp_expr e
+    pp fmt "(loop%a%a@\n  @[<v>%a@])" pp_id_opt id pp_block_type_opt bt pp_expr
+      e
   | If_else (id, bt, e1, e2) ->
-    pp fmt
-      "(if %a %a@\n\
-      \  @[<v>(then@\n\
-      \  @[<v>%a@]@\n\
-       )@\n\
-       (else@\n\
-      \  @[<v>%a@]@\n\
-       )@]@\n\
-       )"
-      pp_id_opt id pp_block_type_opt bt pp_expr e1 pp_expr e2
+    let pp_else fmt e =
+      match e with
+      | [] -> ()
+      | e -> pp fmt "@\n(else@\n  @[<v>%a@]@\n)" pp_expr e
+    in
+    pp fmt "(if%a%a@\n  @[<v>(then@\n  @[<v>%a@]@\n)%a@]@\n)" pp_id_opt id
+      pp_block_type_opt bt pp_expr e1 pp_else e2
   | Br id -> pp fmt "br %a" pp_indice id
   | Br_if id -> pp fmt "br_if %a" pp_indice id
   | Br_table (ids, id) ->
@@ -613,15 +624,16 @@ type 'a func =
   ; id : string option
   }
 
-let pp_local fmt (id, t) = pp fmt "(local %a %a)" pp_id_opt id pp_val_type t
+let pp_local fmt (id, t) = pp fmt "(local%a %a)" pp_id_opt id pp_val_type t
 
 let pp_locals fmt locals = pp_list ~pp_sep:pp_space pp_local fmt locals
 
 let pp_func : type kind. formatter -> kind func -> unit =
  fun fmt f ->
   (* TODO: typeuse ? *)
-  pp fmt "(func %a %a %a@\n  @[<v>%a@]@\n)" pp_id_opt f.id pp_block_type
-    f.type_f pp_locals f.locals pp_expr f.body
+  pp fmt "(func%a%a%a@\n  @[<v>%a@]@\n)" pp_id_opt f.id pp_block_type f.type_f
+    (with_space_list pp_locals)
+    f.locals pp_expr f.body
 
 let pp_funcs fmt (funcs : 'a func list) =
   pp_list ~pp_sep:pp_newline pp_func fmt funcs
@@ -630,7 +642,7 @@ let pp_funcs fmt (funcs : 'a func list) =
 
 type 'a table = string option * 'a table_type
 
-let pp_table fmt (id, ty) = pp fmt "(table %a %a)" pp_id_opt id pp_table_type ty
+let pp_table fmt (id, ty) = pp fmt "(table%a %a)" pp_id_opt id pp_table_type ty
 
 (* Modules *)
 
@@ -641,11 +653,11 @@ type 'a import_desc =
   | Import_global of string option * 'a global_type
 
 let import_desc fmt : 'a import_desc -> Unit.t = function
-  | Import_func (id, t) -> pp fmt "(func %a %a)" pp_id_opt id pp_block_type t
-  | Import_table (id, t) -> pp fmt "(table %a %a)" pp_id_opt id pp_table_type t
-  | Import_mem (id, t) -> pp fmt "(memory %a %a)" pp_id_opt id pp_limits t
+  | Import_func (id, t) -> pp fmt "(func%a %a)" pp_id_opt id pp_block_type t
+  | Import_table (id, t) -> pp fmt "(table%a %a)" pp_id_opt id pp_table_type t
+  | Import_mem (id, t) -> pp fmt "(memory%a %a)" pp_id_opt id pp_limits t
   | Import_global (id, t) ->
-    pp fmt "(global %a %a)" pp_id_opt id pp_global_type t
+    pp fmt "(global%a %a)" pp_id_opt id pp_global_type t
 
 type 'a import =
   { modul : string
@@ -675,7 +687,7 @@ type 'a export =
   }
 
 let pp_export fmt (e : text export) =
-  pp fmt "(export %a %a)" pp_string e.name pp_export_desc e.desc
+  pp fmt {|(export "%s" %a)|} e.name pp_export_desc e.desc
 
 type 'a storage_type =
   | Val_storage_t of 'a val_type
@@ -697,7 +709,7 @@ type 'a struct_field = string option * 'a field_type list
 let pp_fields fmt = pp_list ~pp_sep:pp_space pp_field_type fmt
 
 let pp_struct_field fmt ((n : string option), f) =
-  pp fmt "@\n  @[<v>(field %a%a)@]" pp_id_opt n pp_fields f
+  pp fmt "@\n  @[<v>(field%a%a)@]" pp_id_opt n pp_fields f
 
 type 'a struct_type = 'a struct_field list
 
@@ -724,7 +736,7 @@ let pp_sub_type fmt (f, ids, t) =
 type 'a type_def = string option * 'a sub_type
 
 let pp_type_def fmt (id, t) =
-  pp fmt "@\n  @[<v>(type %a %a)@]" pp_id_opt id pp_sub_type t
+  pp fmt "@\n  @[<v>(type%a %a)@]" pp_id_opt id pp_sub_type t
 
 type 'a rec_type = 'a type_def list
 
@@ -749,18 +761,21 @@ type 'a const =
   | Const_i31
   | Const_struct
 
-let pp_const fmt = function
-  | Const_I32 i -> pp fmt "i32.const %ld" i
-  | Const_I64 i -> pp fmt "i64.const %Ld" i
-  | Const_F32 f -> pp fmt "f32.const %a" Float32.pp f
-  | Const_F64 f -> pp fmt "f64.const %a" Float64.pp f
-  | Const_null rt -> pp fmt "ref.null %a" pp_heap_type rt
-  | Const_host i -> pp fmt "ref.host %d" i
-  | Const_extern i -> pp fmt "ref.extern %d" i
-  | Const_array -> pp fmt "ref.array"
-  | Const_eq -> pp fmt "ref.eq"
-  | Const_i31 -> pp fmt "ref.i31"
-  | Const_struct -> pp fmt "ref.struct"
-
-let pp_consts fmt c =
-  pp_list ~pp_sep:pp_space (fun fmt c -> pp fmt "(%a)" pp_const c) fmt c
+let pp_const fmt c =
+  pp fmt "(%a)"
+    (fun fmt c ->
+      match c with
+      | Const_I32 i -> pp fmt "i32.const %ld" i
+      | Const_I64 i -> pp fmt "i64.const %Ld" i
+      | Const_F32 f -> pp fmt "f32.const %a" Float32.pp f
+      | Const_F64 f -> pp fmt "f64.const %a" Float64.pp f
+      | Const_null rt -> pp fmt "ref.null %a" pp_heap_type rt
+      | Const_host i -> pp fmt "ref.host %d" i
+      | Const_extern i -> pp fmt "ref.extern %d" i
+      | Const_array -> pp fmt "ref.array"
+      | Const_eq -> pp fmt "ref.eq"
+      | Const_i31 -> pp fmt "ref.i31"
+      | Const_struct -> pp fmt "ref.struct" )
+    c
+
+let pp_consts fmt c = pp_list ~pp_sep:pp_space pp_const fmt c