Source file arg_complete.ml

# 1 "./arg_complete.cppo.ml"
type complete = string -> string list
type complete_all = string list -> string list

type spec =
  | Unit of (unit -> unit)
  | Bool of (bool -> unit)
  | Set of bool ref
  | Clear of bool ref
  | String of (string -> unit) * complete
  | Set_string of string ref * complete
  | Int of (int -> unit) * complete
  | Set_int of int ref * complete
  | Float of (float -> unit) * complete
  | Set_float of float ref * complete
  | Tuple of spec list
  | Symbol of string list * (string -> unit)
  | Rest of (string -> unit) * complete
  
# 19 "./arg_complete.cppo.ml"
  | Rest_all of (string list -> unit) * complete_all
  
# 22 "./arg_complete.cppo.ml"
  | Expand of (string -> string array)

# 25 "./arg_complete.cppo.ml"
type arg_speclist = (Arg.key * Arg.spec * Arg.doc) list
type speclist = (Arg.key * spec * Arg.doc) list

let rec arg_spec: spec -> Arg.spec = function
  | Unit f -> Arg.Unit f
  | Bool f -> Arg.Bool f
  | Set r -> Arg.Set r
  | Clear r -> Arg.Clear r
  | String (f, _c) -> Arg.String f
  | Set_string (r, _c) -> Arg.Set_string r
  | Int (f, _c) -> Arg.Int f
  | Set_int (r, _c) -> Arg.Set_int r
  | Float (f, _c) -> Arg.Float f
  | Set_float (r, _c) -> Arg.Set_float r
  | Symbol (l, f) -> Arg.Symbol (l, f)
  | Tuple l -> Arg.Tuple (List.map arg_spec l)
  | Rest (f, _c) -> Arg.Rest f
  
# 43 "./arg_complete.cppo.ml"
  | Rest_all (f, _c) -> Arg.Rest_all f
  
# 46 "./arg_complete.cppo.ml"
  | Expand f -> Arg.Expand f

# 49 "./arg_complete.cppo.ml"
let arg_speclist: speclist -> arg_speclist = fun l ->
  List.map (fun (k, sc, d) -> (k, arg_spec sc, d)) l

module Util =
struct
  
# 55 "./arg_complete.cppo.ml"
  let starts_with = String.starts_with

  
# 68 "./arg_complete.cppo.ml"
  (* Copied from OCaml Stdlib.Arg *)
  let split s =
    let i = String.index s '=' in
    let len = String.length s in
    String.sub s 0 i, String.sub s (i+1) (len-(i+1))
end

let strings l s =
  List.filter (Util.starts_with ~prefix:s) l

let empty _ = []
let empty_all _ = []

type anon_complete = complete

let has_getopt_long_arg: spec -> bool = function
  | Unit _ -> false
  | Bool _ -> true
  | Set _ -> false
  | Clear _ -> false
  | String _ -> true
  | Set_string _ -> true
  | Int _ -> true
  | Set_int _ -> true
  | Float _ -> true
  | Set_float _ -> true
  | Symbol _ -> true
  | Tuple _ -> false
  | Rest _ -> false
  
# 98 "./arg_complete.cppo.ml"
  | Rest_all _ -> false
  
# 101 "./arg_complete.cppo.ml"
  | Expand _ -> true

# 104 "./arg_complete.cppo.ml"
let complete_argv ?(prefer_getopt_long: bool = false) (argv: string list) (speclist: speclist) (anon_complete: complete): string list =
  let speclist =
    speclist @ [
        ("-help", Unit (fun _ -> assert false), "");
        ("--help", Unit (fun _ -> assert false), "");
      ]
  in
  let rec complete_arg (argv: string list) =
    match argv with
    | [] -> []
    | [arg] when Util.starts_with ~prefix:"-" arg ->
      begin match Util.split arg with
        | arg, arg' ->
          begin
            try
              let (_, spec, _) = List.find (fun (key, _, _) -> arg = key) speclist in
              complete_spec spec [arg']
              |> List.map (fun s -> arg ^ "=" ^ s)
            with Not_found ->
              []
          end
        | exception Not_found ->
          (* List.filter_map for OCaml < 4.08 *)
          speclist
          |> List.fold_left (fun acc (key, spec, _doc) ->
              if Util.starts_with ~prefix:arg key then (
                if prefer_getopt_long && has_getopt_long_arg spec then (
                  match complete_spec spec [""] with
                  | [] -> (key ^ "=") :: acc
                  | completions ->
                    completions
                    |> List.rev_map (fun s -> key ^ "=" ^ s)
                    |> (fun keyvals -> keyvals @ acc) (* Fun.flip List.append acc but for OCaml < 4.08 *)
                )
                else
                  key :: acc
              )
              else
                acc
            ) []
          |> List.rev
      end
    | arg :: argv' when Util.starts_with ~prefix:"-" arg ->
      begin
        try
          let (_, spec, _) = List.find (fun (key, _, _) -> arg = key) speclist in
          complete_spec spec argv'
        with Not_found ->
          (* No need to handle = here: only argument of such option (whatever it is) is skipped over by proceeding with argv'. *)
          complete_arg argv'
      end
    | [arg] ->
      anon_complete arg
    | _ :: argv' ->
      complete_arg argv'

  and complete_spec spec argv' =
    match spec, argv' with
    | Unit _f, argv' -> complete_arg argv'
    | Bool _f, [arg'] -> strings ["false"; "true"] arg'
    | Bool _f, _ :: argv' -> complete_arg argv'
    | Set _r, argv' -> complete_arg argv'
    | Clear _r, argv' -> complete_arg argv'
    | String (_f, c), [arg'] -> c arg'
    | String (_f, c), arg' :: argv' -> ignore (c arg'); complete_arg argv'
    | Set_string (_r, c), [arg'] -> c arg'
    | Set_string (_r, c), arg' :: argv' -> ignore (c arg'); complete_arg argv'
    | Int (_f, c), [arg'] -> c arg'
    | Int (_f, c), arg' :: argv' -> ignore (c arg'); complete_arg argv'
    | Set_int (_r, c), [arg'] -> c arg'
    | Set_int (_r, c), arg' :: argv' -> ignore (c arg'); complete_arg argv'
    | Float (_f, c), [arg'] -> c arg'
    | Float (_f, c), arg' :: argv' -> ignore (c arg'); complete_arg argv'
    | Set_float (_r, c), [arg'] -> c arg'
    | Set_float (_r, c), arg' :: argv' -> ignore (c arg'); complete_arg argv'
    | Tuple l, argv' ->
      let rec complete_tuple l argv' = match l, argv' with
        | s :: _, [arg'] -> complete_spec s [arg']
        | s :: l', arg' :: argv' -> ignore (complete_spec s [arg']); complete_tuple l' argv'
        | [], argv' -> complete_arg argv'
        | _, _ -> failwith "cannot complete tuple"
      in
      complete_tuple l argv'
    | Symbol (l, _f), [arg'] -> strings l arg'
    | Symbol (_l, _f), _ :: argv' -> complete_arg argv'
    | Rest (_f, c), argv' ->
      let rec complete_rest = function
        | [arg] -> c arg
        | arg :: argv' -> ignore (c arg); complete_rest argv'
        | _ -> failwith "cannot complete rest"
      in
      complete_rest argv'
    
# 197 "./arg_complete.cppo.ml"
    | Rest_all (_f, c), argv' -> c argv'
    
# 200 "./arg_complete.cppo.ml"
    | Expand f, arg' :: argv' -> complete_arg (Array.to_list (f arg') @ argv')
    
# 202 "./arg_complete.cppo.ml"
    | _, _ -> failwith "cannot complete"
  in
  complete_arg argv


module Rest_all_compat =
struct
  
# 210 "./arg_complete.cppo.ml"
  type t = {
    parse: string list -> unit;
    complete: complete_all;
  }

  let create parse complete = {parse; complete}

  let spec {parse; complete; _} =
    Rest_all (parse, complete)

  let finish _ = ()
# 247 "./arg_complete.cppo.ml"
end