Commits

camlspotter  committed 4dd1703

comopt rewrite

  • Participants
  • Parent commits d6058a9

Comments (0)

Files changed (2)

File lib/comopt.ml

 (* command line argument spec *)
 
-module Switch = struct
-  type t = {
-    name : string option; (* short switch: i.e. -a -b -c w/o '-' *)
-    long : string option; (* long switch: i.e. --archive --bootstrap --compile w/o '--' *)
-    with_arg : bool; (* if true, -axxx -a xxx --archive=xxx *)
-  }
+open Base
+module Hashtbl = struct
+  include Hashtbl
+  include Xhashtbl
+end
+module List = struct
+  include List
+  include Xlist
 end
 
-module Parse : sig
-  type t = {
-    args : string array;
-    short_switches : (char, Switch.t) Hashtbl.t;
-    long_switches : (string * Switch.t) list;
-    stop_at_anon : bool (* stop parsing at the first anonymous argument *)
-  }
+type 'a opt = { 
+  short : char option;
+  long : string option;
+  arg : [ `Nullary of 'a | `Unary of (string -> 'a) ]
+}
 
-  val parse : t -> int
-    -> [> `Anon of string | `Switch of Switch.t * string option ] list
-    *  [> `Error of string | `Ok of int ]
+let nullary short long arg = 
+  match short, long with
+  | None, None -> assert false
+  |_ -> { short; long; arg = `Nullary arg }
 
-end = struct
-  type t = {
-    args : string array;
-    short_switches : (char, Switch.t) Hashtbl.t;
-    long_switches : (string * Switch.t) list;
-    stop_at_anon : bool (* stop parsing at the first anonymous argument *)
-  }
+let unary short long arg = 
+  match short, long with
+  | None, None -> assert false
+  |_ -> { short; long; arg = `Unary arg }
+
+type 'a t = {
+  shorts : (char  , 'a opt) Hashtbl.t;
+  longs  : (string * 'a opt) list;
+}
+
+let make opts =
+  let shorts = Hashtbl.create 107 in
+  List.iter (function 
+    | { short= None } -> ()
+    | ({ short= Some c } as o) ->
+        Hashtbl.alter shorts c (function
+          | Some _ -> assert false
+          | None -> Some o)) opts;
+  let longs = List.filter_map (function
+    | { long= None } -> None
+    | ({ long=Some s } as o) -> Some (s, o)) opts
+  in
+  let keys = List.map fst longs in
+  let rec check st = function
+    | [] -> ()
+    | x::_ when List.mem x st -> assert false
+    | x::xs -> check (x::st) xs
+  in
+  check [] keys;
+  { shorts; longs }
+    
 
   let string_tail s from = String.sub s from (String.length s - from)
     
-  let rec parse t st pos =
-    check_end_else t st pos ~f:(fun () ->
-      let arg = t.args.(pos) in
-      match arg with
-      | _ when String.length arg = 1 -> add_annon t st pos arg
-      | "--" -> parse_as_anon t st (pos + 1)
-      | _ ->
-          match arg.[0], arg.[1] with
-          | '-', '-' -> parse_long_switch t st (string_tail arg 2) (pos + 1)
-          | '-', _ -> parse_short_switch t st (string_tail arg 1) (pos + 1)
-          | _ -> add_annon t st pos arg)
+  let rec parse t st = function
+    | [] -> `Ok (List.rev st)
+    | arg::args -> 
+        match arg with
+        | _ when String.length arg = 1 -> parse t (`Anon arg :: st) args
+        | "--" -> `Ok (List.rev_append st (List.map (fun x -> `Anon x) args))
+        | _ ->
+            match arg.[0], arg.[1] with
+            | '\\', '-' -> parse t (`Anon (string_tail arg 1) :: st) args
+            | '-', '-' -> parse_long_switch t st (string_tail arg 2) args
+            | '-', _ -> parse_short_switch t st (string_tail arg 1) args
+            | _ -> parse t (`Anon arg :: st) args
       
-  and parse_as_anon t st pos =
-    check_end_else t st pos ~f:(fun () ->
-      add_annon t st pos t.args.(pos))
-
-  and add_annon t st pos arg =
-    let st = `Anon arg :: st in
-    let pos = pos + 1 in
-    if t.stop_at_anon then st, `Ok pos
-    else parse t st pos
-
-  and check_end_else ~f t st pos = 
-    if Array.length t.args <= pos then st, `Ok (pos + 1) else f ()
-
-  and parse_short_switch t st sw arg_pos (* for next arg *) =
+  and parse_short_switch t st sw args =
     let len = String.length sw in
     let rec parse_sw st char_pos =
-      if len <= char_pos then parse t st arg_pos
+      if len <= char_pos then parse t st args
       else
         let sw_char = sw.[char_pos] in
         try
-          let switch = Hashtbl.find t.short_switches sw_char in
-          if switch.Switch.with_arg then
-            if len = char_pos + 1 then (* parmeter is in t.arg.(arg_pos) *)
-              get_parameter t st switch (Printf.sprintf "-%c" sw_char) arg_pos            
-            else (* parameter should be concatenated *)
-              parse t (`Switch (switch, Some (string_tail sw char_pos)) :: st) arg_pos
-          else parse_sw (`Switch (switch, None) :: st) (char_pos + 1)
+          let switch = Hashtbl.find t.shorts sw_char in
+          match switch.arg with
+          | `Unary f when len = char_pos + 1 ->
+              get_parameter t st f (!% "-%c" sw_char) args
+          | `Unary _ -> assert false
+          | `Nullary v -> parse_sw (v :: st) (char_pos+1)
         with
-        | Not_found -> st, `Error (Printf.sprintf "unknown option -%c" sw_char)
+        | Not_found -> `Error (!% "unknown option -%c" sw_char)
     in
     parse_sw st 0
       
-  and parse_long_switch t st sw arg_pos =
+  and parse_long_switch t st sw args =
     let sw, param =
       try
         let pos = String.index sw '=' in
     let rec find found = function
       | [] ->
           begin match found with
-          | None -> st, `Error (Printf.sprintf "unknown option --%s" sw)
+          | None -> `Error (Printf.sprintf "unknown option --%s" sw)
           | Some switch ->
-              if switch.Switch.with_arg then
-                match param with
-                | Some s -> parse t (`Switch (switch, Some s) :: st) arg_pos
-                | None -> get_parameter t st switch (Printf.sprintf "--%s" sw) arg_pos
-              else
-                match param with
-                | Some _ -> st, `Error (Printf.sprintf "option --%s must not have a parameter" sw)
-                | None -> parse t (`Switch (switch, None) :: st) arg_pos
+              match switch.arg, param with
+              | `Unary f, Some param -> parse t (f param :: st) args
+              | `Nullary v, None -> parse t (v :: st) args
+              | _ -> assert false
           end
       | (k,switch) :: kss ->
           match
           with
           | Some k' when k = k' ->
               if found = None then find (Some switch) kss
-              else st, `Error (Printf.sprintf "ambiguous option --%s" sw)
+              else `Error (Printf.sprintf "ambiguous option --%s" sw)
           | Some _ | None -> find found kss
     in
-    find None t.long_switches
+    find None t.longs
 
-  and get_parameter t st switch name pos =
-    if Array.length t.args = pos then
-      st, `Error (Printf.sprintf "option %s requires an argument" name)
-    else
-      parse t (`Switch (switch, Some t.args.(pos)) :: st) (pos + 1)
+  and get_parameter t st f name = function
+    | [] -> `Error (!% "option %s requires an argument" name)
+    | arg::args -> parse t (f arg :: st) args
 
-  let parse t pos =
-    let st, result = parse t [] pos in
-    List.rev st, result
-end
+  let parse opts args = parse (make opts) [] args
+

File lib/comopt.mli

-(** Command line option parsing. Never used or tested seriously yet *)
+type 'a opt
 
-module Switch : sig
-  type t = { name : string option; long : string option; with_arg : bool; }
-end
+val nullary : char option -> string option -> 'a -> 'a opt
 
-module Parse : sig
-  type t = {
-    args : string array;
-    short_switches : (char, Switch.t) Hashtbl.t;
-    long_switches : (string * Switch.t) list;
-    stop_at_anon : bool;
-  }
-  
-  val parse : t 
-    -> int 
-    -> [> `Anon of string | `Switch of Switch.t * string option ] list 
-       * [> `Error of string | `Ok of int ]
-end
+val unary : char option -> string option -> (string -> 'a) -> 'a opt
+
+type 'a t
+
+val parse : 
+  ([> `Anon of string ] as 'a) opt list 
+  -> string list 
+  -> [> `Error of string | `Ok of 'a list ]