Source file cmdliner_arg.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2011 The cmdliner programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

let rev_compare n0 n1 = compare n1 n0

(* Invalid_argument strings **)

let err_not_opt = "Option argument without name"
let err_not_pos = "Positional argument with a name"

(* Documentation formatting helpers *)

let strf = Printf.sprintf
let doc_quote = Cmdliner_base.quote
let doc_alts = Cmdliner_base.alts_str
let doc_alts_enum ?quoted enum = doc_alts ?quoted (List.map fst enum)

let str_of_pp pp v = pp Format.str_formatter v; Format.flush_str_formatter ()

(* Argument converters *)

type 'a parser = string -> [ `Ok of 'a | `Error of string ]
type 'a printer = Format.formatter -> 'a -> unit

type 'a conv = 'a parser * 'a printer
type 'a converter = 'a conv

let default_docv = "VALUE"
let conv ?docv (parse, print) =
  let parse s = match parse s with Ok v -> `Ok v | Error (`Msg e) -> `Error e in
  parse, print

let conv' ?docv (parse, print) =
  let parse s = match parse s with Ok v -> `Ok v | Error e -> `Error e in
  parse, print

let pconv ?docv conv = conv

let conv_parser (parse, _) =
  fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e)

let conv_printer (_, print) = print
let conv_docv _ = default_docv

let err_invalid s kind = `Msg (strf "invalid value '%s', expected %s" s kind)
let parser_of_kind_of_string ~kind k_of_string =
  fun s -> match k_of_string s with
  | None -> Error (err_invalid s kind)
  | Some v -> Ok v

let some = Cmdliner_base.some
let some' = Cmdliner_base.some'

(* Argument information *)

type env = Cmdliner_info.Env.info
let env_var = Cmdliner_info.Env.info

type 'a t = 'a Cmdliner_term.t
type info = Cmdliner_info.Arg.t
let info = Cmdliner_info.Arg.v

(* Arguments *)

let ( & ) f x = f x

let err e = Error (`Parse e)

let parse_to_list parser s = match parser s with
| `Ok v -> `Ok [v]
| `Error _ as e -> e

let report_deprecated_env ei e = match Cmdliner_info.Env.info_deprecated e with
| None -> ()
| Some msg ->
    let var = Cmdliner_info.Env.info_var e in
    let msg = String.concat "" ["environment variable "; var; ": "; msg ] in
    let err_fmt = Cmdliner_info.Eval.err_ppf ei in
    Cmdliner_msg.pp_err err_fmt ei ~err:msg

let try_env ei a parse ~absent = match Cmdliner_info.Arg.env a with
| None -> Ok absent
| Some env ->
    let var = Cmdliner_info.Env.info_var env in
    match Cmdliner_info.Eval.env_var ei var with
    | None -> Ok absent
    | Some v ->
        match parse v with
        | `Error e -> err (Cmdliner_msg.err_env_parse env ~err:e)
        | `Ok v -> report_deprecated_env ei env; Ok v

let arg_to_args = Cmdliner_info.Arg.Set.singleton
let list_to_args f l =
  let add acc v = Cmdliner_info.Arg.Set.add (f v) acc in
  List.fold_left add Cmdliner_info.Arg.Set.empty l

let flag a =
  if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else
  let convert ei cl = match Cmdliner_cline.opt_arg cl a with
  | [] -> try_env ei a Cmdliner_base.env_bool_parse ~absent:false
  | [_, _, None] -> Ok true
  | [_, f, Some v] -> err (Cmdliner_msg.err_flag_value f v)
  | (_, f, _) :: (_ ,g, _) :: _  -> err (Cmdliner_msg.err_opt_repeated f g)
  in
  arg_to_args a, convert

let flag_all a =
  if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else
  let a = Cmdliner_info.Arg.make_all_opts a in
  let convert ei cl = match Cmdliner_cline.opt_arg cl a with
  | [] ->
      try_env ei a (parse_to_list Cmdliner_base.env_bool_parse) ~absent:[]
  | l ->
      try
        let truth (_, f, v) = match v with
        | None -> true
        | Some v -> failwith (Cmdliner_msg.err_flag_value f v)
        in
        Ok (List.rev_map truth l)
      with Failure e -> err e
  in
  arg_to_args a, convert

let vflag v l =
  let convert _ cl =
    let rec aux fv = function
    | (v, a) :: rest ->
        begin match Cmdliner_cline.opt_arg cl a with
        | [] -> aux fv rest
        | [_, f, None] ->
            begin match fv with
            | None -> aux (Some (f, v)) rest
            | Some (g, _) -> failwith (Cmdliner_msg.err_opt_repeated g f)
            end
        | [_, f, Some v] -> failwith (Cmdliner_msg.err_flag_value f v)
        | (_, f, _) :: (_, g, _) :: _ ->
            failwith (Cmdliner_msg.err_opt_repeated g f)
        end
    | [] -> match fv with None -> v | Some (_, v) -> v
    in
    try Ok (aux None l) with Failure e -> err e
  in
  let flag (_, a) =
    if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else a
  in
  list_to_args flag l, convert

let vflag_all v l =
  let convert _ cl =
    let rec aux acc = function
    | (fv, a) :: rest ->
        begin match Cmdliner_cline.opt_arg cl a with
        | [] -> aux acc rest
        | l ->
            let fval (k, f, v) = match v with
            | None -> (k, fv)
            | Some v -> failwith (Cmdliner_msg.err_flag_value f v)
            in
            aux (List.rev_append (List.rev_map fval l) acc) rest
        end
    | [] ->
        if acc = [] then v else List.rev_map snd (List.sort rev_compare acc)
    in
    try Ok (aux [] l) with Failure e -> err e
  in
  let flag (_, a) =
    if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else
    Cmdliner_info.Arg.make_all_opts a
  in
  list_to_args flag l, convert

let parse_opt_value parse f v = match parse v with
| `Ok v -> v
| `Error err -> failwith (Cmdliner_msg.err_opt_parse f ~err)

let opt ?vopt (parse, print) v a =
  if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else
  let absent = match Cmdliner_info.Arg.absent a with
  | Cmdliner_info.Arg.Doc d as a when d <> "" -> a
  | _ -> Cmdliner_info.Arg.Val (lazy (str_of_pp print v))
  in
  let kind = match vopt with
  | None -> Cmdliner_info.Arg.Opt
  | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv)
  in
  let a = Cmdliner_info.Arg.make_opt ~absent ~kind a in
  let convert ei cl = match Cmdliner_cline.opt_arg cl a with
  | [] -> try_env ei a parse ~absent:v
  | [_, f, Some v] ->
      (try Ok (parse_opt_value parse f v) with Failure e -> err e)
  | [_, f, None] ->
      begin match vopt with
      | None -> err (Cmdliner_msg.err_opt_value_missing f)
      | Some optv -> Ok optv
      end
  | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f)
  in
  arg_to_args a, convert

let opt_all ?vopt (parse, print) v a =
  if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else
  let absent = match Cmdliner_info.Arg.absent a with
  | Cmdliner_info.Arg.Doc d as a when d <> "" -> a
  | _ -> Cmdliner_info.Arg.Val (lazy "")
  in
  let kind = match vopt with
  | None -> Cmdliner_info.Arg.Opt
  | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv)
  in
  let a = Cmdliner_info.Arg.make_opt_all ~absent ~kind a in
  let convert ei cl = match Cmdliner_cline.opt_arg cl a with
  | [] -> try_env ei a (parse_to_list parse) ~absent:v
  | l ->
      let parse (k, f, v) = match v with
      | Some v -> (k, parse_opt_value parse f v)
      | None -> match vopt with
      | None -> failwith (Cmdliner_msg.err_opt_value_missing f)
      | Some dv -> (k, dv)
      in
      try Ok (List.rev_map snd
                (List.sort rev_compare (List.rev_map parse l))) with
      | Failure e -> err e
  in
  arg_to_args a, convert

(* Positional arguments *)

let parse_pos_value parse a v = match parse v with
| `Ok v -> v
| `Error err -> failwith (Cmdliner_msg.err_pos_parse a ~err)

let pos ?(rev = false) k (parse, print) v a =
  if Cmdliner_info.Arg.is_opt a then invalid_arg err_not_pos else
  let absent = match Cmdliner_info.Arg.absent a with
  | Cmdliner_info.Arg.Doc d as a when d <> "" -> a
  | _ -> Cmdliner_info.Arg.Val (lazy (str_of_pp print v))
  in
  let pos = Cmdliner_info.Arg.pos ~rev ~start:k ~len:(Some 1) in
  let a = Cmdliner_info.Arg.make_pos_abs ~absent ~pos a in
  let convert ei cl = match Cmdliner_cline.pos_arg cl a with
  | [] -> try_env ei a parse ~absent:v
  | [v] ->
      (try Ok (parse_pos_value parse a v) with Failure e -> err e)
  | _ -> assert false
  in
  arg_to_args a, convert

let pos_list pos (parse, _) v a =
  if Cmdliner_info.Arg.is_opt a then invalid_arg err_not_pos else
  let a = Cmdliner_info.Arg.make_pos ~pos a in
  let convert ei cl = match Cmdliner_cline.pos_arg cl a with
  | [] -> try_env ei a (parse_to_list parse) ~absent:v
  | l ->
      try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with
      | Failure e -> err e
  in
  arg_to_args a, convert

let all = Cmdliner_info.Arg.pos ~rev:false ~start:0 ~len:None
let pos_all c v a = pos_list all c v a

let pos_left ?(rev = false) k =
  let start = if rev then k + 1 else 0 in
  let len = if rev then None else Some k in
  pos_list (Cmdliner_info.Arg.pos ~rev ~start ~len)

let pos_right ?(rev = false) k =
  let start = if rev then 0 else k + 1 in
  let len = if rev then Some k else None in
  pos_list (Cmdliner_info.Arg.pos ~rev ~start ~len)

(* Arguments as terms *)

let absent_error args =
  let make_req a acc =
    let req_a = Cmdliner_info.Arg.make_req a in
    Cmdliner_info.Arg.Set.add req_a acc
  in
  Cmdliner_info.Arg.Set.fold make_req args Cmdliner_info.Arg.Set.empty

let value a = a

let err_arg_missing args =
  err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Arg.Set.choose args)

let required (args, convert) =
  let args = absent_error args in
  let convert ei cl = match convert ei cl with
  | Ok (Some v) -> Ok v
  | Ok None -> err_arg_missing args
  | Error _ as e -> e
  in
  args, convert

let non_empty (al, convert) =
  let args = absent_error al in
  let convert ei cl = match convert ei cl with
  | Ok [] -> err_arg_missing args
  | Ok l -> Ok l
  | Error _ as e -> e
  in
  args, convert

let last (args, convert) =
  let convert ei cl = match convert ei cl with
  | Ok [] -> err_arg_missing args
  | Ok l -> Ok (List.hd (List.rev l))
  | Error _ as e -> e
  in
  args, convert

(* Predefined arguments *)

let man_fmts =
  ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain]

let man_fmt_docv = "FMT"
let man_fmts_enum = Cmdliner_base.enum man_fmts
let man_fmts_alts = doc_alts_enum man_fmts
let man_fmts_doc kind =
  strf "Show %s in format $(docv). The value $(docv) must be %s. \
        With $(b,auto), the format is $(b,pager) or $(b,plain) whenever \
        the $(b,TERM) env var is $(b,dumb) or undefined."
    kind man_fmts_alts

let man_format =
  let doc = man_fmts_doc "output" in
  let docv = man_fmt_docv in
  value & opt man_fmts_enum `Pager & info ["man-format"] ~docv ~doc

let stdopt_version ~docs =
  value & flag & info ["version"] ~docs ~doc:"Show version information."

let stdopt_help ~docs =
  let doc = man_fmts_doc "this help" in
  let docv = man_fmt_docv in
  value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None &
  info ["help"] ~docv ~docs ~doc

(* Predefined converters. *)

let bool = Cmdliner_base.bool
let char = Cmdliner_base.char
let int = Cmdliner_base.int
let nativeint = Cmdliner_base.nativeint
let int32 = Cmdliner_base.int32
let int64 = Cmdliner_base.int64
let float = Cmdliner_base.float
let string = Cmdliner_base.string
let enum = Cmdliner_base.enum
let file = Cmdliner_base.file
let dir = Cmdliner_base.dir
let non_dir_file = Cmdliner_base.non_dir_file
let list = Cmdliner_base.list
let array = Cmdliner_base.array
let pair = Cmdliner_base.pair
let t2 = Cmdliner_base.t2
let t3 = Cmdliner_base.t3
let t4 = Cmdliner_base.t4