[sledge] Simplify CLI implementation using ppx_deriving_cmdliner

Summary:
[ppx_deriving_cmdliner](https://github.com/hammerlab/ppx_deriving_cmdliner)
can generate the fragile boilerplate code normally needed to use cmdliner.

Reviewed By: mbouaziz

Differential Revision: D10389477

fbshipit-source-id: a4e0ae195

sledge/dune-common.in

@@ -31,6 +31,7 @@ let flags deps =
        (pps
          ppx_compare
          ppx_custom_printf
+         ppx_deriving_cmdliner
          ppx_expect
          ppx_hash
          ppx_here

sledge/sledge.opam

@@ -15,6 +15,7 @@ depends: [
   "dune" {build > "1.4.0"}
   "llvm" {build & = "7.0.0"}
   "ppx_compare" {>= "v0.11.0"}
+  "ppx_deriving_cmdliner" {>= "0.4.2"}
   "ppx_hash" {>= "v0.11.0"}
   "zarith"
 ]

sledge/src/config.ml

@@ -7,68 +7,7 @@
 
 (** Configuration options *)
 
-(** Extension of Cmdliner supporting lighter-weight option definition *)
-module Cmdliner : sig
-  include module type of Cmdliner
-
-  val mk : default:'a -> 'a Term.t -> 'a ref
-  (** [mk ~default term] is a ref which, after [parse] is called, contains
-      the value of the command line option specified by [term]. *)
-
-  val parse : Term.info -> (unit -> unit Term.ret) -> unit
-  (** [parse info validate] parses the command line according to the options
-      declared by calls to [mk], using manual and version [info], and
-      calling [validate] to check usage constraints not expressible in the
-      [Term] language. *)
-end = struct
-  include Cmdliner
-
-  (** existential package of a Term and a setter for a ref to receive the
-      parsed value *)
-  type arg = Arg : 'a Term.t * ('a -> unit) -> arg
-
-  (** convert a list of arg packages to a term for the tuple of all the arg
-      terms, and apply it to a function that sets all the receiver refs *)
-  let tuple args =
-    let pair (Arg (trm_x, set_x)) (Arg (trm_y, set_y)) =
-      let trm_xy = Term.(const (fun a b -> (a, b)) $ trm_x $ trm_y) in
-      let set_xy (a, b) = set_x a ; set_y b in
-      Arg (trm_xy, set_xy)
-    in
-    let init = Arg (Term.const (), fun () -> ()) in
-    let (Arg (trm, set)) = List.fold_right ~f:pair args ~init in
-    Term.app (Term.const set) trm
-
-  let args : arg list ref = ref []
-
-  let mk ~default arg =
-    let var = ref default in
-    let set x = var := x in
-    args := Arg (arg, set) :: !args ;
-    var
-
-  let parse info validate =
-    match Term.eval (Term.(ret (const validate $ tuple !args)), info) with
-    | `Ok () -> ()
-    | `Error _ -> Caml.exit 1
-    | `Help | `Version -> Caml.exit 0
-end
-
-open Cmdliner
-
-let compile_only =
-  let default = false in
-  mk ~default Arg.(value & flag & info ["c"; "compile-only"])
-
-let input =
-  mk ~default:""
-    Arg.(required & pos ~rev:true 0 (some string) None & info [])
-
-let output =
-  let default = None in
-  mk ~default Arg.(value & opt (some string) default & info ["o"; "output"])
-
-let trace =
+let trace_conv =
   let default = Map.empty (module String) in
   let parse s =
     try
@@ -116,8 +55,8 @@ let trace =
           | mod_name, None, enabled ->
               Map.set m ~key:mod_name
                 ~data:{trace_mod= Some enabled; trace_funs= default} )
-      |> fun x -> `Ok x
-    with _ -> `Error ("Invalid trace spec: " ^ s)
+      |> fun x -> Ok x
+    with _ -> Error (`Msg ("Invalid trace spec: " ^ s))
   in
   let print fs c =
     let pf fmt = Format.fprintf fs fmt in
@@ -130,16 +69,36 @@ let trace =
             if fun_enabled then pf "+%s.%s" mod_name fun_name
             else pf "-%s.%s" mod_name fun_name ) )
   in
-  mk ~default Arg.(value & opt (parse, print) default & info ["t"; "trace"])
-
-let trace_all =
-  let default = false in
-  mk ~default Arg.(value & flag & info ["v"; "trace-all"])
-
-let info = Term.info "sledge" ~version:Version.version
-let validate () = `Ok ()
+  (parse, print)
+
+type t =
+  { compile_only: bool
+         [@aka ["c"]]
+        (** Do not analyze: terminate after translating input LLVM to LLAIR. *)
+  ; input: string
+         [@pos 0] [@docv "input.bc"]
+        (** LLVM bitcode file to analyze, in either binary $(b,.bc) or
+            textual $(b,.ll) form. *)
+  ; output: string option
+         [@aka ["o"]] [@docv "output.llair"]
+        (** Dump $(i,input.bc) translated to LLAIR in human-readable form to
+            $(i,output.llair), or $(b,-) for $(b,stdout). *)
+  ; trace: Trace.trace_mods_funs
+         [@aka ["t"]] [@docv "spec"] [@conv trace_conv]
+        (** Enable debug tracing according to $(i,spec), which is a sequence
+            of module and function names separated by $(b,+) or $(b,-). For
+            example, $(b,Control-Control.exec_inst) enables all tracing in
+            the $(b,Control) module except the $(b,Control.exec_inst)
+            function. *)
+  ; trace_all: bool  (** Enable all debug tracing. *) }
+[@@deriving cmdliner]
 
 let run main =
-  parse info validate ;
-  Trace.init ~config:{trace_all= !trace_all; trace_mods_funs= !trace} () ;
-  main ~input:!input ~output:!output ~compile_only:!compile_only
+  let info = Cmdliner.Term.info "sledge" ~version:Version.version in
+  Cmdliner.Term.eval (cmdliner_term (), info)
+  |> function
+  | `Error _ -> Caml.exit 1
+  | `Help | `Version -> Caml.exit 0
+  | `Ok {compile_only; input; output; trace; trace_all} ->
+      Trace.init ~config:{trace_all; trace_mods_funs= trace} () ;
+      main ~input ~output ~compile_only

sledge/src/trace/trace.ml

@@ -16,8 +16,8 @@ let flush = Format.pp_print_newline fs
 type trace_mod_funs =
   {trace_mod: bool option; trace_funs: bool Map.M(String).t}
 
-type config =
-  {trace_all: bool; trace_mods_funs: trace_mod_funs Map.M(String).t}
+type trace_mods_funs = trace_mod_funs Map.M(String).t
+type config = {trace_all: bool; trace_mods_funs: trace_mods_funs}
 
 let config : config ref =
   ref {trace_all= false; trace_mods_funs= Map.empty (module String)}

sledge/src/trace/trace.mli

@@ -14,9 +14,11 @@ type trace_mod_funs =
   ; trace_funs: bool Map.M(String).t
         (** Enable/disable tracing of individual functions *) }
 
+type trace_mods_funs = trace_mod_funs Map.M(String).t
+
 type config =
   { trace_all: bool  (** Enable all tracing *)
-  ; trace_mods_funs: trace_mod_funs Map.M(String).t
+  ; trace_mods_funs: trace_mods_funs
         (** Specify tracing of individual toplevel modules *) }
 
 val init : ?margin:int -> config:config -> unit -> unit