stdlib/arg.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id$ *)
  15
  16 type key = string
  17 type doc = string
  18 type usage_msg = string
  19 type anon_fun = (string -> unit)
  20
  21 type spec =
  22   | Unit of (unit -> unit)     (* Call the function with unit argument *)
  23   | Bool of (bool -> unit)     (* Call the function with a bool argument *)
  24   | Set of bool ref            (* Set the reference to true *)
  25   | Clear of bool ref          (* Set the reference to false *)
  26   | String of (string -> unit) (* Call the function with a string argument *)
  27   | Set_string of string ref   (* Set the reference to the string argument *)
  28   | Int of (int -> unit)       (* Call the function with an int argument *)
  29   | Set_int of int ref         (* Set the reference to the int argument *)
  30   | Float of (float -> unit)   (* Call the function with a float argument *)
  31   | Set_float of float ref     (* Set the reference to the float argument *)
  32   | Tuple of spec list         (* Take several arguments according to the
  33                                   spec list *)
  34   | Symbol of string list * (string -> unit)
  35                                (* Take one of the symbols as argument and
  36                                   call the function with the symbol. *)
  37   | Rest of (string -> unit)   (* Stop interpreting keywords and call the
  38                                   function with each remaining argument *)
  39
  40 exception Bad of string
  41 exception Help of string
  42
  43 type error =
  44   | Unknown of string
  45   | Wrong of string * string * string  (* option, actual, expected *)
  46   | Missing of string
  47   | Message of string
  48
  49 exception Stop of error;; (* used internally *)
  50
  51 open Printf
  52
  53 let rec assoc3 x l =
  54   match l with
  55   | [] -> raise Not_found
  56   | (y1, y2, y3) :: t when y1 = x -> y2
  57   | _ :: t -> assoc3 x t
  58 ;;
  59
  60 let make_symlist prefix sep suffix l =
  61   match l with
  62   | [] -> "<none>"
  63   | h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
  64 ;;
  65
  66 let print_spec buf (key, spec, doc) =
  67   match spec with
  68   | Symbol (l, _) -> bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l)
  69                              doc
  70   | _ -> bprintf buf "  %s %s\n" key doc
  71 ;;
  72
  73 let help_action () = raise (Stop (Unknown "-help"));;
  74
  75 let add_help speclist =
  76   let add1 =
  77     try ignore (assoc3 "-help" speclist); []
  78     with Not_found ->
  79             ["-help", Unit help_action, " Display this list of options"]
  80   and add2 =
  81     try ignore (assoc3 "--help" speclist); []
  82     with Not_found ->
  83             ["--help", Unit help_action, " Display this list of options"]
  84   in
  85   speclist @ (add1 @ add2)
  86 ;;
  87
  88 let usage_b buf speclist errmsg =
  89   bprintf buf "%s\n" errmsg;
  90   List.iter (print_spec buf) (add_help speclist);
  91 ;;
  92
  93 let usage speclist errmsg =
  94   let b = Buffer.create 200 in
  95   usage_b b speclist errmsg;
  96   eprintf "%s" (Buffer.contents b);
  97 ;;
  98
  99 let current = ref 0;;
 100
 101 let parse_argv ?(current=current) argv speclist anonfun errmsg =
 102   let l = Array.length argv in
 103   let b = Buffer.create 200 in
 104   let initpos = !current in
 105   let stop error =
 106     let progname = if initpos < l then argv.(initpos) else "(?)" in
 107     begin match error with
 108       | Unknown "-help" -> ()
 109       | Unknown "--help" -> ()
 110       | Unknown s ->
 111           bprintf b "%s: unknown option `%s'.\n" progname s
 112       | Missing s ->
 113           bprintf b "%s: option `%s' needs an argument.\n" progname s
 114       | Wrong (opt, arg, expected) ->
 115           bprintf b "%s: wrong argument `%s'; option `%s' expects %s.\n"
 116                   progname arg opt expected
 117       | Message s ->
 118           bprintf b "%s: %s.\n" progname s
 119     end;
 120     usage_b b speclist errmsg;
 121     if error = Unknown "-help" || error = Unknown "--help"
 122     then raise (Help (Buffer.contents b))
 123     else raise (Bad (Buffer.contents b))
 124   in
 125   incr current;
 126   while !current < l do
 127     let s = argv.(!current) in
 128     if String.length s >= 1 && String.get s 0 = '-' then begin
 129       let action =
 130         try assoc3 s speclist
 131         with Not_found -> stop (Unknown s)
 132       in
 133       begin try
 134         let rec treat_action = function
 135         | Unit f -> f ();
 136         | Bool f when !current + 1 < l ->
 137             let arg = argv.(!current + 1) in
 138             begin try f (bool_of_string arg)
 139             with Invalid_argument "bool_of_string" ->
 140                    raise (Stop (Wrong (s, arg, "a boolean")))
 141             end;
 142             incr current;
 143         | Set r -> r := true;
 144         | Clear r -> r := false;
 145         | String f when !current + 1 < l ->
 146             f argv.(!current + 1);
 147             incr current;
 148         | Symbol (symb, f) when !current + 1 < l ->
 149             let arg = argv.(!current + 1) in
 150             if List.mem arg symb then begin
 151               f argv.(!current + 1);
 152               incr current;
 153             end else begin
 154               raise (Stop (Wrong (s, arg, "one of: "
 155                                           ^ (make_symlist "" " " "" symb))))
 156             end
 157         | Set_string r when !current + 1 < l ->
 158             r := argv.(!current + 1);
 159             incr current;
 160         | Int f when !current + 1 < l ->
 161             let arg = argv.(!current + 1) in
 162             begin try f (int_of_string arg)
 163             with Failure "int_of_string" ->
 164                    raise (Stop (Wrong (s, arg, "an integer")))
 165             end;
 166             incr current;
 167         | Set_int r when !current + 1 < l ->
 168             let arg = argv.(!current + 1) in
 169             begin try r := (int_of_string arg)
 170             with Failure "int_of_string" ->
 171                    raise (Stop (Wrong (s, arg, "an integer")))
 172             end;
 173             incr current;
 174         | Float f when !current + 1 < l ->
 175             let arg = argv.(!current + 1) in
 176             begin try f (float_of_string arg);
 177             with Failure "float_of_string" ->
 178                    raise (Stop (Wrong (s, arg, "a float")))
 179             end;
 180             incr current;
 181         | Set_float r when !current + 1 < l ->
 182             let arg = argv.(!current + 1) in
 183             begin try r := (float_of_string arg);
 184             with Failure "float_of_string" ->
 185                    raise (Stop (Wrong (s, arg, "a float")))
 186             end;
 187             incr current;
 188         | Tuple specs ->
 189             List.iter treat_action specs;
 190         | Rest f ->
 191             while !current < l - 1 do
 192               f argv.(!current + 1);
 193               incr current;
 194             done;
 195         | _ -> raise (Stop (Missing s))
 196         in
 197         treat_action action
 198       with Bad m -> stop (Message m);
 199          | Stop e -> stop e;
 200       end;
 201       incr current;
 202     end else begin
 203       (try anonfun s with Bad m -> stop (Message m));
 204       incr current;
 205     end;
 206   done;
 207 ;;
 208
 209 let parse l f msg =
 210   try
 211     parse_argv Sys.argv l f msg;
 212   with
 213   | Bad msg -> eprintf "%s" msg; exit 2;
 214   | Help msg -> printf "%s" msg; exit 0;
 215 ;;
 216
 217 let rec second_word s =
 218   let len = String.length s in
 219   let rec loop n =
 220     if n >= len then len
 221     else if s.[n] = ' ' then loop (n+1)
 222     else n
 223   in
 224   try loop (String.index s ' ')
 225   with Not_found -> len
 226 ;;
 227
 228 let max_arg_len cur (kwd, spec, doc) =
 229   match spec with
 230   | Symbol _ -> max cur (String.length kwd)
 231   | _ -> max cur (String.length kwd + second_word doc)
 232 ;;
 233
 234 let add_padding len ksd =
 235   match ksd with
 236   | (kwd, (Symbol (l, _) as spec), msg) ->
 237       let cutcol = second_word msg in
 238       let spaces = String.make (len - cutcol + 3) ' ' in
 239       (kwd, spec, "\n" ^ spaces ^ msg)
 240   | (kwd, spec, msg) ->
 241       let cutcol = second_word msg in
 242       let spaces = String.make (len - String.length kwd - cutcol) ' ' in
 243       let prefix = String.sub msg 0 cutcol in
 244       let suffix = String.sub msg cutcol (String.length msg - cutcol) in
 245       (kwd, spec, prefix ^ spaces ^ suffix)
 246 ;;
 247
 248 let align speclist =
 249   let completed = add_help speclist in
 250   let len = List.fold_left max_arg_len 0 completed in
 251   List.map (add_padding len) completed
 252 ;;