(*---------------------------------------------------------------------------
   Copyright (c) 2016 Daniel C. Bünzli. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open Bos_setup

let pp_exec = Fmt.(quote string)

let blacklist = [ ".so"; ".cmxs" ] (* Don't try to run these kind of files *)

let exec_match exec p =
  OS.File.exists p >>= function
  | false -> Ok false
  | true ->
      OS.Path.Mode.get p >>= fun mode ->
      if mode land 0o111 = 0 then Ok false else
      let p_base, ext = Fpath.split_ext p in
      let p_base = Fpath.to_string p_base in
      let p = Fpath.to_string p in
      Ok (not (List.mem ext blacklist) &&
          (String.is_suffix ~affix:exec p_base ||
           String.is_suffix ~affix:exec p))

let find_exec exec dir =
  let ambiguous l =
    R.error_msgf "Ambiguous matches for %a, could match any of %a"
      pp_exec exec Fmt.(list ~sep:(any ", ") Fpath.pp) l
  in
  OS.Dir.exists dir >>= function
  | false -> R.error_msgf "Build directory %a does not exist" Fpath.pp dir
  | true ->
      let elements = `Sat (exec_match exec) in
      OS.Dir.fold_contents ~elements (fun p ps -> p :: ps) [] dir
      >>= function
      | [p0] -> Ok p0
      | [p0; p1] as l ->
          let p0, ext0 = Fpath.split_ext p0 in
          let p1, ext1 = Fpath.split_ext p1 in
          if Fpath.equal p0 p1 && ext0 = ".native" || ext1 = ".native"
          then Ok (Fpath.add_ext ".native" p0)
          else ambiguous l
      | [] ->
          R.error_msgf "No matches for %a in build directory %a"
            Fmt.(quote string) exec Fpath.pp dir
      | l ->
          ambiguous l

let run () pkg_file build_dir exec args =
  let pkg = Topkg_care.Pkg.v pkg_file ?build_dir in
  begin
    Topkg_care.Pkg.build_dir pkg
    >>= fun build_dir -> find_exec exec build_dir
    >>= fun exec -> Ok Cmd.(v (p exec) %% of_list args)
    >>= fun cmd -> OS.Cmd.run_status cmd
    >>= function
    | `Exited 0 -> Ok 0
    | status ->
        Logs.err (fun m -> m "run %a %a"
                           Cmd.dump cmd OS.Cmd.pp_status status);
        Ok 1
  end
  |> Cli.handle_error

(* Command line interface *)

open Cmdliner

let args =
  let doc = "Arguments given to the executable. If options are being
             passed, needs to be specified after a -- token so that the
             command line options do not get interpreted by the $(tname)
             command itself."
  in
  Arg.(value & pos_right 0 string [] & info [] ~doc ~docv:"ARG")

let exec =
  let doc = "Executable name or path suffix, with or without its
             extension. If multiple executable match the specification
             the command errors except if two paths match and differ
             only by their .byte and .native file extension. In the latter
             case the .native path is used."
  in
  let docv = "EXEC" in
  Arg.(required & pos 0 (some string) None & info [] ~doc ~docv)

let doc = "Run built executables"
let sdocs = Manpage.s_common_options
let exits = Cmd.Exit.info 1 ~doc:"on run non-zero status exit." :: Cli.exits
let man_xrefs = [ `Main ]
let man =
  [ `S Manpage.s_synopsis;
    `P "$(mname) $(tname) [$(i,OPTION)]... $(i,EXEC) \
        [-- [$(i,ARG)]...]]";
    `S Manpage.s_description;
    `P "The $(tname) command runs executable files found
        in the build directory.";
    `P "$(b,WARNING) The way this command works is subject to change
        in the future." ]

let cmd =
  Cmd.v (Cmd.info "run" ~doc ~sdocs ~exits ~man ~man_xrefs) @@
  Term.(const run $ Cli.setup $ Cli.pkg_file $ Cli.build_dir $ exec $ args)
