Improve the path custom conv to use original path when restoring args
Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
630c10edaf
commit
f9c1d56f55
44
bin/main.ml
44
bin/main.ml
|
@ -7,12 +7,36 @@ open Fiber.O
|
||||||
bootstrap, so we set this reference here *)
|
bootstrap, so we set this reference here *)
|
||||||
let () = suggest_function := Cmdliner_suggest.value
|
let () = suggest_function := Cmdliner_suggest.value
|
||||||
|
|
||||||
|
module Arg = struct
|
||||||
|
include Arg
|
||||||
|
|
||||||
|
let package_name =
|
||||||
|
Arg.conv ((fun p -> Ok (Package.Name.of_string p)), Package.Name.pp)
|
||||||
|
|
||||||
|
module Path : sig
|
||||||
|
type t
|
||||||
|
val path : t -> Path.t
|
||||||
|
val arg : t -> string
|
||||||
|
|
||||||
|
val conv : t conv
|
||||||
|
end = struct
|
||||||
|
type t = string
|
||||||
|
|
||||||
|
let path p = Path.of_filename_relative_to_initial_cwd p
|
||||||
|
let arg s = s
|
||||||
|
|
||||||
|
let conv = Arg.conv ((fun p -> Ok p), Format.pp_print_string)
|
||||||
|
end
|
||||||
|
|
||||||
|
let path = Path.conv
|
||||||
|
end
|
||||||
|
|
||||||
type common =
|
type common =
|
||||||
{ debug_dep_path : bool
|
{ debug_dep_path : bool
|
||||||
; debug_findlib : bool
|
; debug_findlib : bool
|
||||||
; debug_backtraces : bool
|
; debug_backtraces : bool
|
||||||
; profile : string option
|
; profile : string option
|
||||||
; workspace_file : Path.t option
|
; workspace_file : Arg.Path.t option
|
||||||
; root : string
|
; root : string
|
||||||
; target_prefix : string
|
; target_prefix : string
|
||||||
; only_packages : Package.Name.Set.t option
|
; only_packages : Package.Name.Set.t option
|
||||||
|
@ -83,7 +107,7 @@ module Main = struct
|
||||||
let setup ~log ?external_lib_deps_mode common =
|
let setup ~log ?external_lib_deps_mode common =
|
||||||
setup
|
setup
|
||||||
~log
|
~log
|
||||||
?workspace_file:common.workspace_file
|
?workspace_file:(Option.map ~f:Arg.Path.path common.workspace_file)
|
||||||
?only_packages:common.only_packages
|
?only_packages:common.only_packages
|
||||||
?external_lib_deps_mode
|
?external_lib_deps_mode
|
||||||
?x:common.x
|
?x:common.x
|
||||||
|
@ -185,18 +209,6 @@ let find_root () =
|
||||||
in
|
in
|
||||||
(dir, to_cwd)
|
(dir, to_cwd)
|
||||||
|
|
||||||
module Arg = struct
|
|
||||||
include Arg
|
|
||||||
|
|
||||||
let package_name =
|
|
||||||
Arg.conv ((fun p -> Ok (Package.Name.of_string p)), Package.Name.pp)
|
|
||||||
|
|
||||||
let path =
|
|
||||||
Arg.conv ((fun p -> Ok (Path.of_filename_relative_to_initial_cwd p))
|
|
||||||
, Path.pp
|
|
||||||
)
|
|
||||||
end
|
|
||||||
|
|
||||||
let common_footer =
|
let common_footer =
|
||||||
`Blocks
|
`Blocks
|
||||||
[ `S "BUGS"
|
[ `S "BUGS"
|
||||||
|
@ -263,7 +275,7 @@ let common =
|
||||||
let orig_args =
|
let orig_args =
|
||||||
List.concat
|
List.concat
|
||||||
[ dump_opt "--profile" profile
|
[ dump_opt "--profile" profile
|
||||||
; dump_opt "--workspace" (Option.map ~f:Path.to_string workspace_file)
|
; dump_opt "--workspace" (Option.map ~f:Arg.Path.arg workspace_file)
|
||||||
; orig
|
; orig
|
||||||
]
|
]
|
||||||
in
|
in
|
||||||
|
@ -490,7 +502,7 @@ let common =
|
||||||
let merge config_file no_config =
|
let merge config_file no_config =
|
||||||
match config_file, no_config with
|
match config_file, no_config with
|
||||||
| None , false -> `Ok (None , Default)
|
| None , false -> `Ok (None , Default)
|
||||||
| Some fn, false -> `Ok (Some "--config-file", This fn)
|
| Some fn, false -> `Ok (Some "--config-file", This (Arg.Path.path fn))
|
||||||
| None , true -> `Ok (Some "--no-config" , No_config)
|
| None , true -> `Ok (Some "--no-config" , No_config)
|
||||||
| Some _ , true -> incompatible "--no-config" "--config-file"
|
| Some _ , true -> incompatible "--no-config" "--config-file"
|
||||||
in
|
in
|
||||||
|
|
Loading…
Reference in New Issue