1 (****************************************************************************)
5 (* INRIA Rocquencourt *)
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. *)
13 (****************************************************************************)
16 * - Daniel de Rauglaudre: initial version
17 * - Nicolas Pouillard: refactoring
19 type spec_list
= list
(string * Arg.spec
* string);
22 value rec action_arg s sl
=
24 [ Arg.Unit f
-> if s
= "" then do { f
(); Some sl
} else None
29 try do { f
(bool_of_string s
); Some sl
} with
30 [ Invalid_argument
"bool_of_string" -> None
]
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
[] }
41 [ [s
:: sl
] -> do { f s
; Some sl
}
43 else do { f s
; Some sl
}
47 [ [s
:: sl
] -> do { r
.val := s
; Some sl
}
49 else do { r
.val := s
; Some sl
}
54 try do { f
(int_of_string s
); Some sl
} with
55 [ Failure
"int_of_string" -> None
]
58 try do { f
(int_of_string s
); Some sl
} with
59 [ Failure
"int_of_string" -> None
]
64 try do { r
.val := (int_of_string s
); Some sl
} with
65 [ Failure
"int_of_string" -> None
]
68 try do { r
.val := (int_of_string s
); Some sl
} with
69 [ Failure
"int_of_string" -> None
]
73 [ [s
:: sl
] -> do { f
(float_of_string s
); Some sl
}
75 else do { f
(float_of_string s
); Some sl
}
79 [ [s
:: sl
] -> do { r
.val := (float_of_string s
); Some sl
}
81 else do { r
.val := (float_of_string s
); Some sl
}
83 let rec action_args s 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
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
}
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)
106 value parse_arg fold s sl
=
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
115 value rec parse_aux fold anon_fun
=
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
} ];
125 value align_doc key 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)
133 if String.length
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)
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))
148 String.make
(max
1 (16 - String.length key
- String.length
p)) ' '
152 value make_symlist l
=
155 | [h
::t
] -> (List.fold_left
(fun x y
-> x ^
"|" ^ y
) ("{" ^ h
) t
) ^
"}" ];
157 value print_usage_list l
=
159 (fun (key
, spec
, doc
) ->
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
) ] )
168 value remaining_args argv
=
170 if i == Array.length argv
then l
else loop [argv
.(i) :: l
] (i + 1)
172 List.rev
(loop [] (Arg.current
.val + 1));
174 value init_spec_list
= ref [];
175 value ext_spec_list
= ref [];
177 value init spec_list
= init_spec_list
.val := spec_list
;
179 value add name spec descr
=
180 ext_spec_list
.val := [(name
, spec
, descr
) :: ext_spec_list
.val];
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
;
187 value parse anon_fun argv
=
188 let remaining_args = remaining_args argv
in
189 parse_aux fold anon_fun
remaining_args;
191 value ext_spec_list
() = ext_spec_list
.val;