l4/pkg/ocaml/ocaml/contrib/camlp4/Camlp4/Options.ml

   1 (****************************************************************************)
   2 (*                                                                          *)
   3 (*                              Objective Caml                              *)
   4 (*                                                                          *)
   5 (*                            INRIA Rocquencourt                            *)
   6 (*                                                                          *)
   7 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
   9 (*  the terms of the GNU Library General Public License, with the special   *)
  10 (*  exception on linking described in LICENSE at the top of the Objective   *)
  11 (*  Caml source tree.                                                       *)
  12 (*                                                                          *)
  13 (****************************************************************************)
  14
  15 (* Authors:
  16  * - Daniel de Rauglaudre: initial version
  17  * - Nicolas Pouillard: refactoring
  18  *)
  19 type spec_list = list (string * Arg.spec * string);
  20 open Format;
  21
  22 value rec action_arg s sl =
  23   fun
  24   [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None
  25   | Arg.Bool f ->
  26       if s = "" then
  27         match sl with
  28         [ [s :: sl] ->
  29             try do { f (bool_of_string s); Some sl } with
  30             [ Invalid_argument "bool_of_string" -> None ]
  31         | [] -> None ]
  32       else
  33         try do { f (bool_of_string s); Some sl } with
  34         [ Invalid_argument "bool_of_string" -> None ]
  35   | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None
  36   | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None
  37   | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] }
  38   | Arg.String f ->
  39       if s = "" then
  40         match sl with
  41         [ [s :: sl] -> do { f s; Some sl }
  42         | [] -> None ]
  43       else do { f s; Some sl }
  44   | Arg.Set_string r ->
  45       if s = "" then
  46         match sl with
  47         [ [s :: sl] -> do { r.val := s; Some sl }
  48         | [] -> None ]
  49       else do { r.val := s; Some sl }
  50   | Arg.Int f ->
  51       if s = "" then
  52         match sl with
  53         [ [s :: sl] ->
  54             try do { f (int_of_string s); Some sl } with
  55             [ Failure "int_of_string" -> None ]
  56         | [] -> None ]
  57       else
  58         try do { f (int_of_string s); Some sl } with
  59         [ Failure "int_of_string" -> None ]
  60   | Arg.Set_int r ->
  61       if s = "" then
  62         match sl with
  63         [ [s :: sl] ->
  64             try do { r.val := (int_of_string s); Some sl } with
  65             [ Failure "int_of_string" -> None ]
  66         | [] -> None ]
  67       else
  68         try do { r.val := (int_of_string s); Some sl } with
  69         [ Failure "int_of_string" -> None ]
  70   | Arg.Float f ->
  71       if s = "" then
  72         match sl with
  73         [ [s :: sl] -> do { f (float_of_string s); Some sl }
  74         | [] -> None ]
  75       else do { f (float_of_string s); Some sl }
  76   | Arg.Set_float r ->
  77       if s = "" then
  78         match sl with
  79         [ [s :: sl] -> do { r.val := (float_of_string s); Some sl }
  80         | [] -> None ]
  81       else do { r.val := (float_of_string s); Some sl }
  82   | Arg.Tuple specs ->
  83       let rec action_args s sl =
  84         fun
  85         [ [] -> Some sl
  86         | [spec :: spec_list] ->
  87              match action_arg s sl spec with
  88              [ None -> action_args "" [] spec_list
  89              | Some [s :: sl] -> action_args s sl spec_list
  90              | Some sl -> action_args "" sl spec_list
  91              ]
  92         ] in
  93       action_args s sl specs
  94   | Arg.Symbol syms f ->
  95       match (if s = "" then sl else [s :: sl]) with
  96       [ [s :: sl] when List.mem s syms -> do { f s; Some sl }
  97       | _ -> None ]
  98   ];
  99
 100 value common_start s1 s2 =
 101   loop 0 where rec loop i =
 102     if i == String.length s1 || i == String.length s2 then i
 103     else if s1.[i] == s2.[i] then loop (i + 1)
 104     else i;
 105
 106 value parse_arg fold s sl =
 107   fold
 108     (fun (name, action, _) acu ->
 109       let i = common_start s name in
 110       if i == String.length name then
 111         try action_arg (String.sub s i (String.length s - i)) sl action with
 112         [ Arg.Bad _ -> acu ]
 113       else acu) None;
 114
 115 value rec parse_aux fold anon_fun =
 116   fun
 117   [ [] -> []
 118   | [s :: sl] ->
 119       if String.length s > 1 && s.[0] = '-' then
 120         match parse_arg fold s sl with
 121         [ Some sl -> parse_aux fold anon_fun sl
 122         | None -> [s :: parse_aux fold anon_fun sl] ]
 123       else do { (anon_fun s : unit); parse_aux fold anon_fun sl } ];
 124
 125 value align_doc key s =
 126   let s =
 127     loop 0 where rec loop i =
 128       if i = String.length s then ""
 129       else if s.[i] = ' ' then loop (i + 1)
 130      else String.sub s i (String.length s - i)
 131   in
 132   let (p, s) =
 133     if String.length s > 0 then
 134       if s.[0] = '<' then
 135         loop 0 where rec loop i =
 136           if i = String.length s then ("", s)
 137           else if s.[i] <> '>' then loop (i + 1)
 138           else
 139             let p = String.sub s 0 (i + 1) in
 140             loop (i + 1) where rec loop i =
 141               if i >= String.length s then (p, "")
 142               else if s.[i] = ' ' then loop (i + 1)
 143               else (p, String.sub s i (String.length s - i))
 144       else ("", s)
 145     else ("", "")
 146   in
 147   let tab =
 148     String.make (max 1 (16 - String.length key - String.length p)) ' '
 149   in
 150   p ^ tab  ^ s;
 151
 152 value make_symlist l =
 153   match l with
 154   [ [] -> "<none>"
 155   | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ];
 156
 157 value print_usage_list l =
 158   List.iter
 159     (fun (key, spec, doc) ->
 160       match spec with
 161       [ Arg.Symbol symbs _ ->
 162           let s = make_symlist symbs in
 163           let synt = key ^ " " ^ s in
 164           eprintf "  %s %s\n" synt (align_doc synt doc)
 165       | _ -> eprintf "  %s %s\n" key (align_doc key doc) ] )
 166     l;
 167
 168 value remaining_args argv =
 169   let rec loop l i =
 170     if i == Array.length argv then l else loop [argv.(i) :: l] (i + 1)
 171   in
 172   List.rev (loop [] (Arg.current.val + 1));
 173
 174 value init_spec_list = ref [];
 175 value ext_spec_list = ref [];
 176
 177 value init spec_list = init_spec_list.val := spec_list;
 178
 179 value add name spec descr =
 180   ext_spec_list.val := [(name, spec, descr) :: ext_spec_list.val];
 181
 182 value fold f init =
 183   let spec_list = init_spec_list.val @ ext_spec_list.val in
 184   let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list in
 185   List.fold_right f specs init;
 186
 187 value parse anon_fun argv =
 188   let remaining_args = remaining_args argv in
 189   parse_aux fold anon_fun remaining_args;
 190
 191 value ext_spec_list () = ext_spec_list.val;