Source file ThunkGetopt.ml

(* https://github.com/scemama/ocaml-getopt/blob/8855ac892c57920c9c537109caca9bb579c0b061/lib/getopt.ml *)
(* 
Copyright (c) 2004 by Alain Frisch

The package "getopt" is copyright by Alain Frisch.

Permission is hereby granted, free of charge, to any person obtaining
a copy of the "getopt" software (the "Software"), to deal in the
Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or
sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.

The Software is provided ``as is'', without warranty of any kind, express
or implied, including but not limited to the warranties of
merchantability, fitness for a particular purpose and noninfringement.
In no event shall Alain Frisch be liable for any claim, damages or
other liability, whether in an action of contract, tort or otherwise,
arising from, out of or in connection with the Software or the use or
other dealings in the software.
*)

(* Module [Getopt]: parsing of command line arguments *)
(* Alain Frisch *)

let noshort = '\000'
let nolong = ""

type 'a opt =
  char
  * string
  * ('a -> (unit, string) result) option
  * ('a -> 'a -> string -> (unit, 'a * string) result) option

let index_option s c = try Some (String.index s c) with Not_found -> None

let parse : type a.
    a opt list ->
    (a -> string -> (unit, a * string) result) ->
    (a * string) array ->
    int ->
    int ->
    (unit, a option * string) result =
  let extract_arg_handle :
      a ->
      string ->
      char
      * string
      * (a -> (unit, string) result) option
      * (a -> a -> string -> (unit, a * string) result) option ->
      (a -> a -> string -> (unit, a * string) result, a option * string) result
      =
   fun a opt -> function
     | _, _, _, Some handle -> Ok handle
     | _ ->
         Error (Some a, Printf.sprintf "Option %s does not accept argument" opt)
  in
  let extract_handle :
      a ->
      string ->
      char
      * string
      * (a -> (unit, string) result) option
      * (a -> a -> string -> (unit, a * string) result) option ->
      (a -> (unit, string) result, a option * string) result =
   fun a opt -> function
     | _, _, Some handle, _ -> Ok handle
     | _ -> Error (Some a, Printf.sprintf "Option %s must have an argument" opt)
  in
  fun opts others args first last ->
    let ( let* ) = Result.bind in
    let argl = Array.length args in
    let* () =
      if argl > 0 then Ok () else Error (None, "No arguments provided")
    in
    let* () =
      if first < 0 || first < argl then Ok ()
      else
        Error
          ( None,
            Printf.sprintf
              "The first index (%d) is outside of the arguments (max %d)" first
              (argl - 1) )
    in
    let* () =
      if last < 0 || last < argl then Ok ()
      else
        Error
          ( None,
            Printf.sprintf
              "The last index (%d) is outside of the arguments (max %d)" last
              (argl - 1) )
    in
    let lift_some_fst = Result.map_error (fun (a, s) -> (Some a, s)) in
    let find_long opt =
      try Ok (List.find (fun (_, l, _, _) -> opt = l) opts)
      with Not_found -> Error (None, Printf.sprintf "Unknown option --%s" opt)
    in
    let find_short opt =
      try Ok (List.find (fun (l, _, _, _) -> opt = l) opts)
      with Not_found -> Error (None, Printf.sprintf "Unknown option -%c" opt)
    in

    (* Anonymous arguments after -- *)
    let rec skip no =
      if no <= last then
        let* () = lift_some_fst @@ others (fst args.(no)) (snd args.(no)) in
        skip (succ no)
      else Ok ()
    in

    let rec aux no : (unit, a option * string) result =
      if no <= last then
        let a, s = args.(no) in
        let lift_a result = Result.map_error (fun x -> (Some a, x)) result in
        let l = String.length s in
        if l = 0 then
          let* () = lift_some_fst @@ others a s in
          aux (succ no)
        else if s.[0] = '-' then
          if l >= 2 && s.[1] = '-' then
            if l = 2 then skip (succ no) (* -- *)
            else
              match index_option s '=' with
              | Some i ->
                  (* long option with argument *)
                  let opt = String.sub s 2 (i - 2) in
                  let arg = String.sub s (i + 1) (l - i - 1) in
                  let* long_opt = find_long opt in
                  let* handle = extract_arg_handle a ("--" ^ opt) long_opt in
                  let* () = lift_some_fst @@ handle a a arg in
                  aux (succ no)
              | None -> (
                  (* long option with no argument *)
                  let opt = String.sub s 2 (l - 2) in
                  let* long_opt = find_long opt in
                  match long_opt with
                  | _, _, Some handle_noarg, None ->
                      (* no argument allowed *)
                      let* () = lift_a @@ handle_noarg a in
                      aux (succ no)
                  | (_, _, _, Some handle_arg) as o ->
                      (* argument allowed or mandatory *)
                      if no + 1 <= last then
                        let* () =
                          let a_plus1 = fst args.(no + 1) in
                          lift_some_fst
                          @@ handle_arg a a_plus1 (snd args.(no + 1))
                        in
                        aux (no + 2)
                      else (* no argument possible *)
                        let* handle = extract_handle a s o in
                        let* () = lift_a @@ handle a in
                        aux (succ no)
                  | _ ->
                      Error
                        ( None,
                          "Getopt.parse. [(action. handler)] must not both be \
                           None." ))
          else if l = 1 then
            let* () = lift_some_fst @@ others a s in
            aux (succ no) (* - *)
          else (* short option *)
            let opt = s.[1] in
            let* short_opt = find_short opt in
            match short_opt with
            | _, _, Some handle, None ->
                (* no argument allowed; next chars are options *)
                let* () = lift_a @@ handle a in
                (* for i = 2 to l - 1 do *)
                let rec loop2_l1 i =
                  if i >= l then Ok ()
                  else
                    let* short_opt = find_short s.[i] in
                    let* () =
                      match short_opt with
                      | _, _, Some handle_noarg, None ->
                          lift_a @@ handle_noarg a
                      | _ ->
                          Error
                            ( Some a,
                              Printf.sprintf
                                "Only non-argument short-options can be \
                                 concatenated (error with option %c in %s)"
                                s.[i] s )
                    in
                    loop2_l1 (succ i)
                in
                let* () = loop2_l1 2 in
                aux (succ no)
            | (_, _, _, Some handle_arg) as o ->
                (* argument allowed or mandatory *)
                if l > 2 then (* immediate argument *)
                  let* () =
                    lift_some_fst @@ handle_arg a a (String.sub s 2 (l - 2))
                  in
                  aux (succ no)
                else if no + 1 <= last && (snd args.(no + 1)).[0] <> '-' then
                  (* non-immediate argument *)
                  let* () =
                    let a_plus1 = fst args.(no + 1) in
                    lift_some_fst @@ handle_arg a a_plus1 (snd args.(no + 1))
                  in
                  aux (no + 2)
                else
                  (* no argument *)
                  let* handle = extract_handle a s o in
                  let* () = lift_a @@ handle a in
                  aux (succ no)
            | _ ->
                Error
                  ( None,
                    "Getopt.parse. [(action. handler)] must not both be None."
                  )
        else
          let* () = lift_some_fst @@ others a s in
          aux (succ no)
      else Ok ()
    in
    aux first

let parse_cmdline opts others =
  let annotated_argv =
    Array.init (Array.length Sys.argv) (fun i -> (i, Sys.argv.(i)))
  in
  parse opts others annotated_argv 1 (Array.length Sys.argv - 1)

(* useful actions and handlers *)

let set var value = Some (fun () -> var := value)
let append lst = Some (fun x -> lst := !lst @ [ x ])
let incr var = Some (fun () -> Stdlib.incr var)

let atmost_once var exc =
  Some (fun x -> if !var = "" then var := x else raise exc)