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

type 'a eval_ok = [ `Ok of 'a | `Version | `Help ]
type eval_error = [ `Parse | `Term | `Exn ]
type 'a eval_exit = [ `Ok of 'a  | `Exit of Cmdliner_def.Exit.code ]

type eval_result_error =
  [ Cmdliner_term.term_escape
  | `Exn of exn * Printexc.raw_backtrace
  | `Parse of string
  | `Std_help of Cmdliner_manpage.format
  | `Std_version ]

type 'a eval_result =
  ('a, [ eval_result_error
       | `Complete of Cmdliner_def.Complete.t * Cmdliner_def.Cline.t]) result

let err_help s = "Term error, help requested for unknown command " ^ s
let err_argv = "argv array must have at least one element"

let add_stdopts eval =
  let docs = Cmdliner_def.Cmd_info.stdopts_docs (Cmdliner_def.Eval.cmd eval) in
  let vargs, vers =
    match Cmdliner_def.Cmd_info.version (Cmdliner_def.Eval.main eval) with
    | None -> Cmdliner_def.Arg_info.Set.empty, None
    | Some _ ->
        let vers = Cmdliner_arg.stdopt_version ~docs in
        (Cmdliner_term.argset vers), Some vers
  in
  let help = Cmdliner_arg.stdopt_help ~docs in
  let args =
    Cmdliner_def.Arg_info.Set.union vargs (Cmdliner_term.argset help)
  in
  let cmd = Cmdliner_def.Cmd_info.add_args (Cmdliner_def.Eval.cmd eval) args in
  help, vers, Cmdliner_def.Eval.with_cmd eval cmd

let run_parser ~catch eval cl f =
  try (f eval cl :> ('a, eval_result_error) result) with
  | exn when catch ->
      let bt = Printexc.get_raw_backtrace () in
      Error (`Exn (exn, bt))

let try_eval_stdopts ~catch eval cline help version : 'a eval_result option =
  match run_parser ~catch eval cline (Cmdliner_term.parser help) with
  | Ok (Some fmt) -> Some (Error (`Std_help fmt))
  | Error (`Parse _) ->
      (* only [FMT] errored, there was a `--help`, show help anyways *)
      Some (Error (`Std_help `Auto))
  | Error _ as err -> (Some err :> 'a eval_result option)
  | Ok None ->
      match version with
      | None -> None
      | Some version ->
          match (run_parser ~catch eval cline (Cmdliner_term.parser version))
          with
          | Ok false -> None
          | Ok true -> Some (Error (`Std_version))
          | Error _ as err -> (Some err :> 'a eval_result option)

let do_help ~env help_ppf err_ppf eval fmt cmd_name =
  let eval = match cmd_name with
  | None (* help of main command requested *)  ->
      let env _ = assert false in
      let cmd = Cmdliner_def.Eval.main eval in
      let subcmds = Cmdliner_def.Eval.subcmds eval in
      let eval' =
        Cmdliner_def.Eval.make ~ancestors:[] ~cmd ~subcmds ~env ~err_ppf
      in
      begin match Cmdliner_def.Eval.ancestors eval with
      | [] -> (* [ei] is an evaluation of main, [cmd] has stdopts *) eval'
      | _ -> let _, _, eval' = add_stdopts eval' in eval'
      end
  | Some cmd ->
      try
        (* For now we simply keep backward compat. [cmd] should be
           a name from main's children. *)
        let main = Cmdliner_def.Eval.main eval in
        let is_cmd t = Cmdliner_def.Cmd_info.name t = cmd in
        let children = Cmdliner_def.Cmd_info.children main in
        let cmd = List.find is_cmd children in
        let _, _, eval = add_stdopts (Cmdliner_def.Eval.with_cmd eval cmd) in
        eval
      with Not_found -> invalid_arg (err_help cmd)
  in
  Cmdliner_docgen.pp_man ~env ~errs:err_ppf fmt help_ppf eval

let do_result ~env help_ppf err_ppf eval = function
| Ok v -> Ok (`Ok v)
| Error res ->
    match res with
    | `Std_help fmt ->
        Cmdliner_docgen.pp_man ~env ~errs:err_ppf fmt help_ppf eval; Ok `Help
    | `Std_version ->
        Cmdliner_msg.pp_version help_ppf eval; Ok `Version
    | `Parse err ->
        Cmdliner_msg.pp_usage_and_err err_ppf eval ~err; Error `Parse
    | `Complete (comp, cline) ->
        Cmdliner_completion.output ~out_ppf:help_ppf ~err_ppf eval comp cline;
        Ok `Help
    | `Help (fmt, cmd_name) ->
        do_help ~env help_ppf err_ppf eval fmt cmd_name; Ok `Help
    | `Exn (e, bt) ->
        Cmdliner_msg.pp_backtrace err_ppf eval e bt; (Error `Exn)
    | `Error (usage, err) ->
        (if usage
         then Cmdliner_msg.pp_usage_and_err err_ppf eval ~err
         else Cmdliner_msg.pp_err err_ppf eval ~err);
        Error `Term

let do_deprecated_msgs ~env err_ppf cl eval =
  let cmd_info = Cmdliner_def.Eval.cmd eval in
  let deprecated = Cmdliner_def.Cline.deprecated ~env cl in
  match Cmdliner_def.Cmd_info.deprecated cmd_info, deprecated with
  | None, [] -> ()
  | depr_cmd, deprs ->
      let open Cmdliner_base in
      let pp_sep ppf () =
        if Option.is_some depr_cmd && deprs <> [] then Fmt.cut ppf ();
      in
      let subst = Cmdliner_def.Eval.doclang_subst eval in
      let pp_cmd_msg ppf cmd =
        match
          Cmdliner_def.Cmd_info.styled_deprecated ~subst ~errs:err_ppf cmd
        with
        | "" -> ()
        | msg ->
            let name = Cmdliner_def.Cmd_info.name cmd in
            Fmt.pf ppf "@[%a command %a:@[ %a@]@]"
              Fmt.deprecated () Fmt.code_or_quote name Fmt.styled_text msg
      in
      let pp_deprs = Fmt.list (Cmdliner_def.Cline.pp_deprecated ~subst) in
      Fmt.pf err_ppf "@[%a @[<v>%a%a%a@]@]@."
        Cmdliner_msg.pp_exec_msg eval pp_cmd_msg cmd_info
        pp_sep () pp_deprs deprs

let find_cmd_and_parser ~legacy_prefixes ~for_completion args cmd =
  (* This finds the command to use if it's a group and [for_completion]
     is [true] whether we may need to add the subcommand names to the
     completions. *)
  let stop ~ancestors ~cmd args = match (cmd : 'a Cmdliner_cmd.t) with
  | Cmd (_, parser) -> ancestors, cmd, args, Ok parser
  | Group (_, (Some parser, _)) -> ancestors, cmd, args, Ok parser
  | Group (_, (None, children)) ->
      let dom = Cmdliner_cmd.list_names children in
      let err = Cmdliner_msg.err_cmd_missing ~dom in
      let try_stdopts = true in
      ancestors, cmd, args, Error (`Parse (try_stdopts, err))
  in
  let rec loop ~ancestors ~current_cmd = function
  | "--" :: _ | [] as args -> stop ~ancestors ~cmd:current_cmd args
  | arg :: _ as args when for_completion &&
                          Cmdliner_cline.has_complete_prefix arg ->
      begin match current_cmd with
      | Cmd _ -> (* arg completion *) stop ~ancestors ~cmd:current_cmd args
      | Group (_, (parser, _))  ->
          let is_opt = Cmdliner_cline.(is_opt (get_token_to_complete arg)) in
          if not is_opt then ancestors, current_cmd, args, Error `Complete else
          stop ~ancestors ~cmd:current_cmd args
      end
  | arg :: _ as args when Cmdliner_cline.is_opt arg ->
      stop ~ancestors ~cmd:current_cmd args
  | arg :: rest as args ->
      match current_cmd with
      | Cmd (i, parser) -> ancestors, current_cmd, args, Ok parser
      | Group (i, (_, children)) ->
          let cmd_index = Cmdliner_cmd.name_trie children in
          match Cmdliner_trie.find ~legacy_prefixes cmd_index arg with
          | Ok cmd -> loop ~ancestors:(i :: ancestors) ~current_cmd:cmd rest
          | Error `Not_found ->
              let all = Cmdliner_trie.ambiguities cmd_index "" in
              let hints = Cmdliner_base.suggest arg all in
              let dom = Cmdliner_cmd.list_names children in
              let kind = "command" in
              let err = Cmdliner_base.err_unknown ~kind ~dom ~hints arg in
              let try_stdopts =
                (* When one writes [cmd no_such_cmd --help] it's better
                   to show the unknown command error message rather
                   than get into the help of the parent command. Otherwise
                   one gets confused into thinking the command exists and/or
                   annoyed not to be reading the right man page. *)
                false
              in
              ancestors, current_cmd, args, Error (`Parse (try_stdopts, err))
          | Error `Ambiguous (* Only on legacy prefixes *)  ->
              let ambs = Cmdliner_trie.ambiguities cmd_index arg in
              let ambs = List.sort compare ambs in
              let err = Cmdliner_base.err_ambiguous ~kind:"command" arg ~ambs in
              let try_stdopts = false in
              ancestors, current_cmd, args, Error (`Parse (try_stdopts, err))
  in
  loop ~ancestors:[] ~current_cmd:cmd args

let cli_args_of_argv argv = match Array.to_list argv with
| exec :: "--__complete" :: args -> true, args
| exec :: args -> false, args
| [] -> invalid_arg err_argv

let eval_value
    ?help:(help_ppf = Format.std_formatter)
    ?err:(err_ppf = Format.err_formatter)
    ?(catch = true) ?(env = Sys.getenv_opt) ?(argv = Sys.argv) cmd
  =
  let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env in
  let for_completion, args = cli_args_of_argv argv in
  let ancestors, cmd, args, parser =
    find_cmd_and_parser ~legacy_prefixes ~for_completion args cmd
  in
  let help, version, eval =
    let subcmds = Cmdliner_cmd.get_children_infos cmd in
    let cmd = Cmdliner_cmd.get_info cmd in
    let eval = Cmdliner_def.Eval.make ~ancestors ~cmd ~subcmds ~env ~err_ppf in
    add_stdopts eval
  in
  let cline =
    let args_info = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in
    Cmdliner_cline.create ~legacy_prefixes ~for_completion args_info args
  in
  let res = match parser with
  | Error (`Parse (try_stdopts, msg)) ->
      (* Command lookup error, we may still prioritize stdargs *)
      begin match cline with
      | `Complete c -> Error (`Complete c)
      | `Error (_, cl) | `Ok cl ->
          let stdopts =
            if try_stdopts
            then try_eval_stdopts ~catch eval cl help version else None
          in
          begin match stdopts with
          | None -> Error (`Error (true, msg))
          | Some e -> e
          end
      end
  | Error `Complete ->
      begin match cline with
      | `Complete (comp, cline) ->
          let comp = Cmdliner_def.Complete.add_subcmds comp in
          Error (`Complete (comp, cline))
      | `Ok _ | `Error _ -> assert false
      end
  | Ok parser ->
      begin match cline with
      | `Complete c -> Error (`Complete c)
      | `Error (e, cl) ->
          begin match try_eval_stdopts ~catch eval cl help version with
          | Some e -> e
          | None -> Error (`Error (true, e))
          end
      | `Ok cl ->
          match try_eval_stdopts ~catch eval cl help version with
          | Some e -> e
          | None ->
              do_deprecated_msgs ~env err_ppf cl eval;
              (run_parser ~catch eval cl parser :> 'a eval_result)
      end
  in
  do_result ~env help_ppf err_ppf eval res

let eval_peek_opts
    ?(version_opt = false) ?(env = Sys.getenv_opt) ?(argv = Sys.argv) t
  : 'a option * ('a eval_ok, eval_error) result
  =
  let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env in
  let for_completion, args = cli_args_of_argv argv in
  let version = if version_opt then Some "dummy" else None in
  let cmd_info, parser =
    let args, parser = Cmdliner_term.argset t, Cmdliner_term.parser t in
    let cmd_info = Cmdliner_def.Cmd_info.make ?version "dummy" in
    Cmdliner_def.Cmd_info.add_args cmd_info args, parser
  in
  let help, version, eval =
    let err_ppf = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) in
    let ancestors = [] and cmd = cmd_info and subcmds = [] in
    let eval = Cmdliner_def.Eval.make ~ancestors ~cmd ~subcmds ~env ~err_ppf in
    add_stdopts eval
  in
  let cline =
    let arg_infos = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in
    Cmdliner_cline.create
      ~peek_opts:true ~legacy_prefixes ~for_completion arg_infos args
  in
  let v, ret = match cline with
  | `Complete comp -> None, (Error (`Complete comp))
  | `Error (e, cl) ->
      begin match try_eval_stdopts ~catch:true eval cl help version with
      | Some e -> None, e
      | None -> None, Error (`Error (true, e))
      end
  | `Ok cl ->
      let ret = run_parser ~catch:true eval cl parser in
      let v = match ret with Ok v -> Some v | Error _ -> None in
      begin match try_eval_stdopts ~catch:true eval cl help version with
      | Some e -> v, e
      | None -> v, (ret :> 'a eval_result)
      end
  in
  let ret = match ret with
  | Ok v -> Ok (`Ok v)
  | Error `Std_help _ -> Ok `Help
  | Error `Std_version -> Ok `Version
  | Error `Parse _ -> Error `Parse
  | Error `Help _ -> Ok `Help
  | Error `Complete _ -> Ok `Help
  | Error `Exn _ -> Error `Exn
  | Error `Error _ -> Error `Term
  in
  (v, ret)

let exit_status_of_result ?(term_err = Cmdliner_def.Exit.cli_error) = function
| Ok (`Ok _ | `Help | `Version) -> Cmdliner_def.Exit.ok
| Error `Term -> term_err
| Error `Parse -> Cmdliner_def.Exit.cli_error
| Error `Exn -> Cmdliner_def.Exit.internal_error

let eval_value' ?help ?err ?catch ?env ?argv ?term_err cmd =
  match eval_value ?help ?err ?catch ?env ?argv cmd with
  | Ok (`Ok _ as v) -> v
  | ret -> `Exit (exit_status_of_result ?term_err ret)

let eval ?help ?err ?catch ?env ?argv ?term_err cmd =
  exit_status_of_result ?term_err @@
  eval_value ?help ?err ?catch ?env ?argv cmd

let eval' ?help ?err ?catch ?env ?argv ?term_err cmd =
  match eval_value ?help ?err ?catch ?env ?argv cmd with
  | Ok (`Ok c) -> c
  | r -> exit_status_of_result ?term_err r

let pp_err ppf cmd ~msg =
  (* Here instead of Cmdliner_msgs to avoid circular dep *)
  let name = Cmdliner_cmd.name cmd in
  Cmdliner_base.Fmt.pf ppf "%s: @[%a@]@." name Cmdliner_base.Fmt.lines msg

let eval_result
    ?help ?(err = Format.err_formatter) ?catch ?env ?argv ?term_err cmd
  =
  match eval_value ?help ~err ?catch ?env ?argv cmd with
  | Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_def.Exit.some_error
  | r -> exit_status_of_result ?term_err r

let eval_result'
    ?help ?(err = Format.err_formatter) ?catch ?env ?argv ?term_err cmd
  =
  match eval_value ?help ~err ?catch ?env ?argv cmd with
  | Ok (`Ok (Ok c)) -> c
  | Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_def.Exit.some_error
  | r -> exit_status_of_result ?term_err r