Add a top-level Arguments mechanism

bin/sasArg.ml

+(* Time-stamp: <modified the 07/03/2019 (at 10:35) by Erwan> *)
+
+
+type t = {
+  mutable topo: string;
+  mutable length: int;
+  mutable verbose: int;
+  mutable demon: Demon.t;
+
+  mutable _args : (string * Arg.spec * string) list;
+  mutable _user_man  : (string * string list) list; 
+  mutable _hidden_man: (string * string list) list; 
+
+  mutable _others : string list;
+  mutable _margin : int;
+}
+
+let usage_msg = ("usage: " ^Sys.argv.(0) ^ " [<option>] [<topology>.dot file]
+use --help to see the available options.
+" )
+let print_usage () = Printf.printf "%s\n" usage_msg; flush stdout
+
+
+let (make_args : unit -> t) = 
+  fun () -> 
+    {
+      topo = "";
+      length = 100;
+      verbose = 0;
+      demon = Demon.Distributed;
+      _args = [];        
+      _user_man  = [];   
+      _hidden_man  = []; 
+      _others = [];
+      _margin =12;
+    }
+
+let (args : t) = make_args ()
+
+let pspec os  (c, ml) = (
+  let (m1, oth) = match ml with
+	 |	h::t -> (h,t)
+	 |	_ -> ("",[])
+  in
+  let t2 = String.make args._margin ' ' in
+  let cl = String.length c in
+  let t1 = if (cl < args._margin ) then
+	 String.make (args._margin - cl) ' '
+  else
+	 "\n"^t2
+  in
+	 Printf.fprintf os "%s%s%s" c t1 m1;
+	 List.iter (function x -> Printf.fprintf os "\n%s%s" t2 x) oth ;
+	 Printf.fprintf os "\n" ;
+)
+
+let options oc = (
+	let l = List.rev args._user_man in
+	List.iter (pspec oc) l
+)
+let more_options oc = (
+	let l = List.rev (args._hidden_man) in
+	List.iter (pspec oc) l
+)
+let (mkopt : t -> string list -> ?hide:bool -> ?arg:string -> Arg.spec ->
+     string list -> unit) =
+  fun opt ol ?(hide=false) ?(arg="") se ml ->
+    let treto o = opt._args <- (o, se, "")::opt._args in
+	   List.iter treto ol ;
+	   let col1 = (String.concat ", " ol)^arg in
+	     if hide 
+        then opt._hidden_man <- (col1, ml)::opt._hidden_man
+	     else opt._user_man   <- (col1, ml)::opt._user_man
+
+let myexit i = exit i
+
+(*** User Options Tab **)
+let (mkoptab : t -> unit) = 
+  fun opt ->  
+  let _nl = "\n"^(String.make args._margin ' ') in
+    (
+    mkopt opt  ["--synchronous-demon";"-sd"]
+      (Arg.Unit(fun () -> args.demon <- Demon.Synchronous))
+      ["Use a Synchronous deamon"];
+
+    mkopt opt  ["--central-demon";"-cd"]
+      (Arg.Unit(fun () -> args.demon <- Demon.Synchronous))
+      ["Use a Central deamon (selects exactly one action)"];
+    
+    mkopt opt  ["--locally-central-demon";"-lcd"]
+      (Arg.Unit(fun () -> args.demon <- Demon.Synchronous))
+      ["Use a Locally Central deamon (never activates two neighbor";
+       "actions in the same step)"];
+    mkopt opt  ["--distributed-demon";"-dd"]
+      (Arg.Unit(fun () -> args.demon <- Demon.Synchronous))
+      ["Use a Distributed deamon (select at least one action)"];
+    
+    mkopt opt  ["--custom-demon";"-custd"]
+      (Arg.Unit(fun () -> args.demon <- Demon.Synchronous))
+      ["Use a Custom deamon"];
+
+    mkopt opt ["--length";"-l"] ~arg:" <int>"
+      (Arg.Int (fun i -> args.length <- i))
+      ["Maximum number of steps to be done (" ^ (string_of_int args.length) ^ " by default).\n"];
+
+    mkopt opt ~hide:true ["--ocaml-version"]
+      (Arg.Unit (fun _ -> (print_string (Sys.ocaml_version) ; flush stdout; exit 0)))
+      ["Display the version ocaml version sasa was compiled with and exit."];
+
+    mkopt opt  ["--verbose";"-vl"] ~arg:" <int>"
+      (Arg.Int (fun i -> args.verbose <- i))   ["Set the verbose level"];
+
+    mkopt opt ["--help";"-help"; "-h"]
+      (Arg.Unit (fun _ -> print_usage();options stdout; exit 0))
+      ["Display main options"];
+
+    mkopt opt ["--more";"-m"] (Arg.Unit (fun () -> more_options stdout; exit 0)) 
+      ["Display more options"]
+
+  )
+
+(* all unrecognized options are accumulated *)
+let (add_other : t -> string -> unit) =
+  fun opt s -> 
+    opt._others <- s::opt._others
+
+let current = ref 0;;
+let first_line b = (
+	try (
+		let f = String.index b '\n' in
+		String.sub b 0 f
+	) with Not_found -> b
+)
+let file_notfound f = (
+	prerr_string ("File not found: \""^f^"\"");
+	prerr_newline ();
+	myexit 1
+)
+let unexpected s = (
+	prerr_string ("unexpected argument \""^s^"\"");
+	prerr_newline ();
+	myexit 1
+)
+
+let parse argv = (
+  let save_current = !current in
+  try (
+    mkoptab args;
+	 Arg.parse_argv ~current:current argv args._args (add_other args) usage_msg;
+    (List.iter 
+       (fun f -> 
+         if (String.sub f 0 1 = "-") then
+           unexpected f 
+         else if not (Sys.file_exists f) then
+           file_notfound f
+         else ()
+       ) 
+       args._others);
+    current := save_current;
+    args.topo <- (match args._others with
+          [] -> 
+          Printf.fprintf stderr "*** The topology file is missing in '%s'\n%s\n"
+            (Sys.argv.(0)) usage_msg;
+          exit 2; 
+        | x::_ -> x
+      )
+  )
+  with
+	   (* only 1rst line is interesting ! *)
+  | Arg.Bad msg ->
+    Printf.fprintf stderr "*** Error when calling '%s': %s\n%s\n" (Sys.argv.(0))
+      (first_line msg) usage_msg; exit 2; 
+  | Arg.Help msg -> 
+    Printf.fprintf stdout "%s\n%s\n" msg usage_msg; 
+    options stdout; exit 0
+)

bin/sasa.ml

-(* Time-stamp: <modified the 07/03/2019 (at 09:43) by Erwan> *)
+(* Time-stamp: <modified the 07/03/2019 (at 10:29) by Erwan> *)
 
 (* XXX Je pourrais utiliser Lwt pour rendre step non-bloquant, ce qui
    permettrait d'accelerer la simu sur les machines qui ont plusieurs
@@ -63,7 +63,8 @@ let (update_env: Env.t -> Process.t * Algo.local_env -> Env.t) =
       p.variables
 
 open Process
-
+open SasArg
+    
 let (to_algo_neighbor: Env.t -> Topology.neighbor -> Algo.neighbor) =
   fun e n ->
     { 
@@ -86,7 +87,7 @@ let rec (simu: int -> int -> Process.t list ->
         [] pl_n
     in
     assert (all <> []);
-    let al = Demon.f Demon.Distributed all in
+    let al = Demon.f args.demon all in
 
     (* Do the steps *)
     let lenv_list =
@@ -109,12 +110,25 @@ let rec (simu: int -> int -> Process.t list ->
     | _ ->  if i > 0 then simu n (i-1) pl pl_n ne else ()
 
 let () =
-  let dot_file = Sys.argv.(1) in
+  ( try SasArg.parse Sys.argv;
+	 with
+	     Failure(e) ->
+	       output_string stdout e;
+	       flush stdout ;
+	       exit 2
+	   | e ->
+	     output_string stdout (Printexc.to_string e);
+	     flush stdout;
+	     exit 2
+  );
+
+
+  let dot_file = SasArg.args.topo in
   let nl = Topology.read dot_file in
   let nstrl = List.map (fun n -> n.Topology.id) nl in
   let nstr = String.concat "," nstrl in
   try
-    Algo.verbose_level :=1;
+    Algo.verbose_level := SasArg.args.verbose;
     Random.self_init();
     Printf.printf "nodes: %s\nedges:\n" nstr;
     let e = Env.init () in
@@ -123,6 +137,6 @@ let () =
     let neighors = List.map get_neighors pl in
     let pl_n = List.combine pl neighors in
     List.iter dump_process pl_n;
-    let n = (int_of_string Sys.argv.(2)) in
+    let n = SasArg.args.length in
     simu n n pl pl_n e
   with Dynlink.Error e -> Printf.printf "E: %s\n"(Dynlink.error_message e)

test/dijkstra-ring/Makefile

@@ -13,7 +13,7 @@ MLI=-I $(DIR)/lib/algo
 	ocamlopt -shared $(MLI) $^ -o $@
 
 test: ring.cmxs ringroot.cmxs
-	$(sasa) ring.dot 150
+	$(sasa) ring.dot 
 
 clean:
 	rm -f *.cmxs sasa *.cmi *.o *.cmx *.pdf