@ -31,6 +31,9 @@ let to_arg_spec = function
| Symbol ( symbols , f ) -> Arg . Symbol ( symbols , f )
| Rest f -> Arg . Rest f
let to_arg_spec_triple ( x , spec , y ) = ( x , to_arg_spec spec , y )
let to_arg_speclist = List . map ~ f : to_arg_spec_triple
let is_env_var_set v =
Option . value ( Option . map ( Sys . getenv v ) ~ f : ( ( = ) " 1 " ) ) ~ default : false
@ -68,11 +71,37 @@ let init_work_dir, is_originator =
Unix . putenv ~ key : " INFER_CWD " ~ data : real_cwd ;
( real_cwd , true )
let strict_mode = is_env_var_set " INFER_STRICT_MODE "
let warnf =
if is_env_var_set " INFER_STRICT_MODE " then failwithf
if strict_mode then failwithf
else if not is_originator then fun fmt -> F . ifprintf F . err_formatter fmt
else F . eprintf
type section = Analysis | Clang | Driver | Java | Print [ @@ deriving compare ]
let equal_section = [ % compare . equal : section ]
let all_sections = [ Analysis ; Clang ; Driver ; Java ; Print ]
type ' a parse = Infer of ' a | Javac | NoParse [ @@ deriving compare ]
type parse_mode = section list parse [ @@ deriving compare ]
type parse_action = section parse [ @@ deriving compare ]
let equal_parse_action = [ % compare . equal : parse_action ]
type parse_tag = unit parse [ @@ deriving compare ]
let equal_parse_tag = [ % compare . equal : parse_tag ]
let all_parse_tags = [ Infer () ; Javac ; NoParse ]
let to_parse_tag = function | Infer _ -> Infer () | Javac -> Javac | NoParse -> NoParse
let accept_unknown_args = function
| Infer Print | Javac | NoParse -> true
| Infer Analysis | Infer Clang | Infer Driver | Infer Java -> false
type desc = {
long : string ; short : string ; meta : string ; doc : string ; spec : spec ;
(* * how to go from an option in the json config file to a list of command-line options *)
@ -217,26 +246,32 @@ let check_no_duplicates desc_list =
check_for_duplicates_ ( IList . sort ( fun ( x , _ , _ ) ( y , _ , _ ) -> String . compare x y ) desc_list )
let full_desc_list = ref []
let parse_tag_desc_lists = List . map ~ f : ( fun parse_tag -> ( parse_tag , ref [] ) ) all_parse_tags
let exe_desc_lists = IList . map ( fun ( _ , exe ) -> ( exe , ref [] ) ) exe s
let infer_section_desc_lists = List . map ~ f : ( fun section -> ( section , ref [] ) ) all_section s
(* * add desc to all desc_lists for the purposes of parsing, include desc in --help only for exes *)
let add exes desc =
(* * add [desc] to the one relevant parse_tag_desc_lists for the purposes of parsing, and, in the
case of Infer , include [ desc ] in - - help only for the relevant sections . * )
let add parse_mode desc =
let tag = to_parse_tag parse_mode in
let full_desc_list = List . Assoc . find_exn parse_tag_desc_lists tag in
full_desc_list := desc :: ! full_desc_list ;
IList . iter ( fun ( exe , desc_list ) ->
let desc =
if List . mem ~ equal : equal_exe exes exe then
desc
else
{ desc with meta = " " ; doc = " " } in
desc_list := desc :: ! desc_list
) exe_desc_lists
let deprecate_desc ~ long ~ short ~ deprecated desc =
let warn () =
warnf " WARNING: '-%s' is deprecated. Use '--%s'%s instead.@. "
deprecated long ( if short = " " then " " else Printf . sprintf " or '-%s' " short ) in
match parse_mode with
| Javac | NoParse -> ()
| Infer sections ->
List . iter infer_section_desc_lists ~ f : ( fun ( section , desc_list ) ->
let desc = if List . mem ~ equal : equal_section sections section then
desc
else
{ desc with meta = " " ; doc = " " } in
desc_list := desc :: ! desc_list )
let deprecate_desc parse_mode ~ long ~ short ~ deprecated desc =
let warn () = match parse_mode with
| Javac | NoParse -> ()
| Infer _ ->
warnf " WARNING: '-%s' is deprecated. Use '--%s'%s instead.@. "
deprecated long ( if short = " " then " " else Printf . sprintf " or '-%s' " short ) in
let warn_then_f f x = warn () ; f x in
let deprecated_spec = match desc . spec with
| Unit f -> Unit ( warn_then_f f )
@ -249,7 +284,7 @@ let deprecate_desc ~long ~short ~deprecated desc =
{ long = " " ; short = deprecated ; meta = " " ; doc = " " ;
spec = deprecated_spec ; decode_json = deprecated_decode_json }
let mk ? ( deprecated = [] ) ? ( exes= [] )
let mk ? ( deprecated = [] ) ? ( parse_mode= Infer [] )
~ long ? ( short = " " ) ~ default ~ meta doc ~ default_to_string ~ decode_json ~ mk_setter ~ mk_spec =
let variable = ref default in
let closure = mk_setter variable in
@ -265,16 +300,21 @@ let mk ?(deprecated=[]) ?(exes=[])
else doc ^ " (default: " ^ default_string ^ " ) " in
let desc = { long ; short ; meta ; doc ; spec ; decode_json } in
(* add desc for long option, with documentation ( which includes any short option ) for exes *)
add exes desc ;
if long < > " " then add parse_mode desc ;
(* add desc for short option only for parsing, without documentation *)
let parse_mode_no_sections = match parse_mode with
| Infer _ -> Infer []
| Javac | NoParse -> parse_mode in
if short < > " " then
add [] { desc with long = " " ; meta = " " ; doc = " " } ;
add parse_mode_no_sections { desc with long = " " ; meta = " " ; doc = " " } ;
(* add desc for deprecated options only for parsing, without documentation *)
List . iter deprecated ~ f : ( fun deprecated ->
deprecate_desc ~ long ~ short ~ deprecated desc
| > add [] ) ;
deprecate_desc parse_mode ~ long ~ short ~ deprecated desc
| > add parse_mode_no_sections ) ;
variable
(* begin parsing state *)
(* arguments passed to Arg.parse_argv_dynamic, susceptible to be modified on the fly when parsing *)
let args_to_parse : string array ref = ref ( Array . of_list [] )
@ -284,34 +324,47 @@ let arg_being_parsed : int ref = ref 0
(* list of arg specifications currently being used by Arg.parse_argv_dynamic *)
let curr_speclist : ( Arg . key * Arg . spec * Arg . doc ) list ref = ref []
let unknown_args_action = ref ` Reject
let rev_anon_args = ref []
let anon_fun arg = match ! unknown_args_action with
| ` Skip ->
()
| ` Add ->
rev_anon_args := arg :: ! rev_anon_args
| ` Reject ->
raise ( Arg . Bad ( " unexpected anonymous argument: " ^ arg ) )
(* end parsing state *)
type ' a t =
? deprecated : string list -> long : Arg . key -> ? short : Arg . key ->
? exes : exe list -> ? meta : string -> Arg . doc ->
? parse_mode: parse_mode -> ? meta : string -> Arg . doc ->
' a
let string_json_decoder ~ long json = [ dashdash long ; YBU . to_string json ]
let list_json_decoder json_decoder json = IList . flatten ( YBU . convert_each json_decoder json )
let mk_set var value ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_set var value ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
let setter () = var := value in
ignore (
mk ~ deprecated ~ long ? short ~ default : () ? exes ~ meta doc
mk ~ deprecated ~ long ? short ~ default : () ? parse_mode ~ meta doc
~ default_to_string : ( fun () -> " " )
~ decode_json : ( string_json_decoder ~ long )
~ mk_setter : ( fun _ _ -> setter () )
~ mk_spec : ( fun _ -> Unit setter ) )
let mk_option ? ( default = None ) ? ( default_to_string = fun _ -> " " ) ~ f
? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ default_to_string
~ decode_json : ( string_json_decoder ~ long )
~ mk_setter : ( fun var str -> var := f str )
~ mk_spec : ( fun set -> String set )
let mk_bool ? ( deprecated_no = [] ) ? ( default = false ) ? ( f = fun b -> b )
? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
let nolong =
let len = String . length long in
if len > 3 && String . sub long ~ pos : 0 ~ len : 3 = " no- " then
@ -340,13 +393,13 @@ let mk_bool ?(deprecated_no=[]) ?(default=false) ?(f=fun b -> b)
let default_to_string _ = " " in
let mk_spec set = Unit ( fun () -> set " " ) in
let var =
mk ~ long ? short ~ deprecated ~ default ? exes
mk ~ long ? short ~ deprecated ~ default ? parse_mode
~ meta doc ~ default_to_string ~ mk_setter : ( fun var _ -> var := f true )
~ decode_json : ( fun json ->
[ dashdash ( if YBU . to_bool json then long else nolong ) ] )
~ mk_spec in
ignore (
mk ~ long : nolong ? short : noshort ~ deprecated : deprecated_no ~ default : ( not default ) ? exes
mk ~ long : nolong ? short : noshort ~ deprecated : deprecated_no ~ default : ( not default ) ? parse_mode
~ meta nodoc ~ default_to_string ~ mk_setter : ( fun _ _ -> var := f false )
~ decode_json : ( fun json ->
[ dashdash ( if YBU . to_bool json then nolong else long ) ] )
@ -354,60 +407,61 @@ let mk_bool ?(deprecated_no=[]) ?(default=false) ?(f=fun b -> b)
var
let mk_bool_group ? ( deprecated_no = [] ) ? ( default = false )
? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc children no_children =
? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc children no_children =
let f b =
IList . iter ( fun child -> child := b ) children ;
IList . iter ( fun child -> child := not b ) no_children ;
b
in
mk_bool ~ deprecated ~ deprecated_no ~ default ~ long ? short ~ f ? exes ~ meta doc
mk_bool ~ deprecated ~ deprecated_no ~ default ~ long ? short ~ f ? parse_mode ~ meta doc
let mk_int ~ default ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
let mk_int ~ default ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ default_to_string : string_of_int
~ mk_setter : ( fun var str -> var := ( int_of_string str ) )
~ decode_json : ( string_json_decoder ~ long )
~ mk_spec : ( fun set -> String set )
let mk_int_opt ? default ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_int_opt ? default ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
let default_to_string = function Some f -> string_of_int f | None -> " " in
let f s = Some ( int_of_string s ) in
mk_option ~ deprecated ~ long ? short ~ default ~ default_to_string ~ f ? exes ~ meta doc
mk_option ~ deprecated ~ long ? short ~ default ~ default_to_string ~ f ? parse_mode ~ meta doc
let mk_float ~ default ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
let mk_float ~ default ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ default_to_string : string_of_float
~ mk_setter : ( fun var str -> var := ( float_of_string str ) )
~ decode_json : ( string_json_decoder ~ long )
~ mk_spec : ( fun set -> String set )
let mk_float_opt ? default ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_float_opt ? default ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
let default_to_string = function Some f -> string_of_float f | None -> " " in
let f s = Some ( float_of_string s ) in
mk_option ~ deprecated ~ long ? short ~ default ~ default_to_string ~ f ? exes ~ meta doc
mk_option ~ deprecated ~ long ? short ~ default ~ default_to_string ~ f ? parse_mode ~ meta doc
let mk_string ~ default ? ( f = fun s -> s ) ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
let mk_string ~ default ? ( f = fun s -> s ) ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ default_to_string : ( fun s -> s )
~ mk_setter : ( fun var str -> var := f str )
~ decode_json : ( string_json_decoder ~ long )
~ mk_spec : ( fun set -> String set )
let mk_string_opt ? default ? ( f = fun s -> s ) ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_string_opt ? default ? ( f = fun s -> s ) ? ( deprecated = [] ) ~ long ? short ? parse_mode
? ( meta = " " ) doc =
let default_to_string = function Some s -> s | None -> " " in
let f s = Some ( f s ) in
mk_option ~ deprecated ~ long ? short ~ default ~ default_to_string ~ f ? exes ~ meta doc
mk_option ~ deprecated ~ long ? short ~ default ~ default_to_string ~ f ? parse_mode ~ meta doc
let mk_string_list ? ( default = [] ) ? ( f = fun s -> s )
? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ default_to_string : ( String . concat ~ sep : " , " )
~ mk_setter : ( fun var str -> var := ( f str ) :: ! var )
~ decode_json : ( list_json_decoder ( string_json_decoder ~ long ) )
~ mk_spec : ( fun set -> String set )
let mk_path_helper ~ setter ~ default_to_string
~ default ~ deprecated ~ long ~ short ~ exes ~ meta ~ decode_json doc =
~ default ~ deprecated ~ long ~ short ~ parse_mode ~ meta ~ decode_json doc =
let normalize_path_in_args_being_parsed str =
if Filename . is_relative str then (
(* Replace relative paths with absolute ones on the fly in the args being parsed. This assumes
@ -420,59 +474,60 @@ let mk_path_helper ~setter ~default_to_string
abs_path
) else
str in
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ decode_json ~ default_to_string
~ mk_setter : ( fun var str ->
let abs_path = normalize_path_in_args_being_parsed str in
setter var abs_path )
~ mk_spec : ( fun set -> String set )
let mk_path ~ default ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " path " ) =
let mk_path ~ default ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " path " ) =
mk_path_helper
~ setter : ( fun var x -> var := x )
~ decode_json : ( string_json_decoder ~ long )
~ default_to_string : ( fun s -> s )
~ default ~ deprecated ~ long ~ short ~ exes ~ meta
~ default ~ deprecated ~ long ~ short ~ parse_mode ~ meta
let mk_path_opt ? default ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " path " ) =
let mk_path_opt ? default ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " path " ) =
mk_path_helper
~ setter : ( fun var x -> var := Some x )
~ decode_json : ( string_json_decoder ~ long )
~ default_to_string : ( function Some s -> s | None -> " " )
~ default ~ deprecated ~ long ~ short ~ exes ~ meta
~ default ~ deprecated ~ long ~ short ~ parse_mode ~ meta
let mk_path_list ? ( default = [] ) ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " path " ) =
let mk_path_list ? ( default = [] ) ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " path " ) =
mk_path_helper
~ setter : ( fun var x -> var := x :: ! var )
~ decode_json : ( list_json_decoder ( string_json_decoder ~ long ) )
~ default_to_string : ( String . concat ~ sep : " , " )
~ default ~ deprecated ~ long ~ short ~ exes ~ meta
~ default ~ deprecated ~ long ~ short ~ parse_mode ~ meta
let mk_symbol ~ default ~ symbols ~ eq ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_symbol ~ default ~ symbols ~ eq ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
let strings = IList . map fst symbols in
let sym_to_str = IList . map ( fun ( x , y ) -> ( y , x ) ) symbols in
let of_string str = IList . assoc String . equal str symbols in
let to_string sym = IList . assoc eq sym sym_to_str in
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta doc
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta doc
~ default_to_string : ( fun s -> to_string s )
~ mk_setter : ( fun var str -> var := of_string str )
~ decode_json : ( string_json_decoder ~ long )
~ mk_spec : ( fun set -> Symbol ( strings , set ) )
let mk_symbol_opt ~ symbols ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_symbol_opt ~ symbols ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " " ) doc =
let strings = IList . map fst symbols in
let of_string str = IList . assoc String . equal str symbols in
mk ~ deprecated ~ long ? short ~ default : None ? exes ~ meta doc
mk ~ deprecated ~ long ? short ~ default : None ? parse_mode ~ meta doc
~ default_to_string : ( fun _ -> " " )
~ mk_setter : ( fun var str -> var := Some ( of_string str ) )
~ decode_json : ( string_json_decoder ~ long )
~ mk_spec : ( fun set -> Symbol ( strings , set ) )
let mk_symbol_seq ? ( default = [] ) ~ symbols ~ eq ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " " ) doc =
let mk_symbol_seq ? ( default = [] ) ~ symbols ~ eq ? ( deprecated = [] ) ~ long ? short ? parse_mode
? ( meta = " " ) doc =
let sym_to_str = IList . map ( fun ( x , y ) -> ( y , x ) ) symbols in
let of_string str = IList . assoc String . equal str symbols in
let to_string sym = IList . assoc eq sym sym_to_str in
mk ~ deprecated ~ long ? short ~ default ? exes ~ meta : ( " ,-separated sequence " ^ meta ) doc
mk ~ deprecated ~ long ? short ~ default ? parse_mode ~ meta : ( " ,-separated sequence " ^ meta ) doc
~ default_to_string : ( fun syms -> String . concat ~ sep : " " ( IList . map to_string syms ) )
~ mk_setter : ( fun var str_seq ->
var := IList . map of_string ( Str . split ( Str . regexp_string " , " ) str_seq ) )
@ -482,133 +537,41 @@ let mk_symbol_seq ?(default=[]) ~symbols ~eq ?(deprecated=[]) ~long ?short ?exes
~ mk_spec : ( fun set -> String set )
let mk_set_from_json ~ default ~ default_to_string ~ f
? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " json " ) doc =
mk ~ deprecated ~ long ? short ? exes ~ meta doc
? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " json " ) doc =
mk ~ deprecated ~ long ? short ? parse_mode ~ meta doc
~ default ~ default_to_string
~ mk_setter : ( fun var json -> var := f ( Yojson . Basic . from_string json ) )
~ decode_json : ( fun json -> [ dashdash long ; Yojson . Basic . to_string json ] )
~ mk_spec : ( fun set -> String set )
let mk_json ? ( deprecated = [] ) ~ long ? short ? exes ? ( meta = " json " ) doc =
mk ~ deprecated ~ long ? short ? exes ~ meta doc
let mk_json ? ( deprecated = [] ) ~ long ? short ? parse_mode ? ( meta = " json " ) doc =
mk ~ deprecated ~ long ? short ? parse_mode ~ meta doc
~ default : ( ` List [] ) ~ default_to_string : Yojson . Basic . to_string
~ mk_setter : ( fun var json -> var := Yojson . Basic . from_string json )
~ decode_json : ( fun json -> [ dashdash long ; Yojson . Basic . to_string json ] )
~ mk_spec : ( fun set -> String set )
(* * A ref to a function used during argument parsing to process anonymous arguments. By default,
anonymous arguments are rejected . * )
let anon_fun = ref ( fun arg -> raise ( Arg . Bad ( " unexpected anonymous argument: " ^ arg ) ) )
(* * [mk_anon] always return the same ref. Anonymous arguments are only accepted if
[ parse_action_accept_unknown_args ] is true . * )
let mk_anon () = rev_anon_args
(* * Clients declare that anonymous arguments are acceptable by calling [mk_anon], which returns a
ref storing the anonymous arguments . * )
let mk_anon () =
let anon = ref [] in
anon_fun := ( fun arg -> anon := arg :: ! anon ) ;
anon
let mk_rest ? ( exes = [] ) doc =
let mk_rest ? ( parse_mode = Infer [] ) doc =
let rest = ref [] in
let spec = Rest ( fun arg -> rest := arg :: ! rest ) in
add exes { long = " -- " ; short = " " ; meta = " " ; doc ; spec ; decode_json = fun _ -> [] } ;
rest
let accept_unknown_args = ref false
let mk_subcommand ? ( exes = [] ) doc command_to_speclist =
let rest = ref [] in
let spec =
String ( fun arg ->
rest := List . rev ( Array . to_list ( Array . slice ! args_to_parse ( ! arg_being_parsed + 1 ) 0 ) ) ;
accept_unknown_args := true ;
anon_fun := ( fun _ -> () ) ;
curr_speclist := command_to_speclist arg
) in
add exes { long = " -- " ; short = " " ; meta = " " ; doc ; spec ; decode_json = fun _ -> [] } ;
add parse_mode { long = " -- " ; short = " " ; meta = " " ; doc ; spec ; decode_json = fun _ -> [] } ;
rest
let decode_inferconfig_to_argv current_exe path =
let json = match Utils . read_optional_json_file path with
| Ok json ->
json
| Error msg ->
warnf " WARNING: Could not read or parse Infer config in %s:@ \n %s@. " path msg ;
` Assoc [] in
let desc_list = ! ( IList . assoc equal_exe current_exe exe_desc_lists ) in
let json_config = YBU . to_assoc json in
let one_config_item result ( key , json_val ) =
try
let { decode_json } =
IList . find
( fun { long ; short } ->
String . equal key long
| | (* for deprecated options *) String . equal key short )
desc_list in
decode_json json_val @ result
with
| Not_found ->
warnf " WARNING: while reading config file %s:@ \n Unknown option %s@. " path key ;
result
| YBU . Type_error ( msg , json ) ->
warnf " WARNING: while reading config file %s:@ \n Ill-formed value %s for option %s: %s@. "
path ( Yojson . Basic . to_string json ) key msg ;
result in
IList . fold_left one_config_item [] json_config
(* * separator of argv elements when encoded into environment variables *)
let env_var_sep = '^'
let encode_argv_to_env argv =
String . concat ~ sep : ( String . make 1 env_var_sep )
( IList . filter ( fun arg ->
not ( String . contains arg env_var_sep )
| | (
warnf " Ignoring unsupported option containing '%c' character: %s@ \n "
env_var_sep arg ;
false
)
) argv )
let decode_env_to_argv env =
Str . split ( Str . regexp_string ( String . make 1 env_var_sep ) ) env
let prepend_to_argv args =
let cl_args = match Array . to_list Sys . argv with _ :: tl -> tl | [] -> [] in
args @ cl_args
(* * [prefix_before_rest ( prefix @ ["--" :: rest] ) ] is [prefix] where "--" is not in [prefix]. *)
let rev_prefix_before_rest args =
let rec rev_prefix_before_rest_ rev_keep = function
| [] | " -- " :: _ -> rev_keep
| keep :: args -> rev_prefix_before_rest_ ( keep :: rev_keep ) args in
rev_prefix_before_rest_ [] args
(* * environment variable use to pass arguments from parent to child processes *)
let args_env_var = " INFER_ARGS "
let extra_env_args = ref []
let extend_env_args args =
extra_env_args := List . rev_append args ! extra_env_args
let parse ? ( incomplete = false ) ? config_file current_exe exe_usage ~ should_parse_cl_args =
let full_speclist = ref []
in
let usage_msg = exe_usage current_exe
in
let convert_spec_triple ( x , spec , y ) = ( x , to_arg_spec spec , y ) in
let convert_speclist = List . map ~ f : convert_spec_triple in
let set_curr_speclist_for_parse_action ~ incomplete ~ usage parse_action =
let full_speclist = ref [] in
let curr_usage status =
prerr_endline ( String . concat_array ~ sep : " " ! args_to_parse ) ;
Arg . usage ! curr_speclist usage _msg ;
Arg . usage ! curr_speclist usage ;
exit status
and full_usage status =
Arg . usage ( convert _speclist ! full_speclist ) usage _msg ;
Arg . usage ( to_arg_speclist ! full_speclist ) usage ;
exit status
in
let parse_tag = to_parse_tag parse_action in
(* "-help" and "--help" are automatically recognized by Arg.parse, so we have to give them special
treatment * )
let add_or_suppress_help ( speclist , ( doc_width , left_width ) ) =
@ -617,7 +580,14 @@ let parse ?(incomplete=false) ?config_file current_exe exe_usage ~should_parse_c
let mk_spec ~ long ? ( short = " " ) spec doc =
pad_and_xform doc_width left_width { long ; short ; meta = " " ; spec ; doc ;
decode_json = fun _ -> raise ( Arg . Bad long ) } in
if incomplete then
if not ( equal_parse_tag parse_tag ( Infer () ) ) then
let skip opt =
( opt , Unit ( fun () -> () ) , " " ) in
speclist @ [
( skip " --help " ) ;
( skip " -help " )
]
else if incomplete then
speclist @ [
( unknown " --help " ) ;
( unknown " -help " )
@ -653,15 +623,21 @@ let parse ?(incomplete=false) ?config_file current_exe exe_usage ~should_parse_c
let sort speclist = IList . sort compare_specs speclist in
align ( sort speclist )
in
let add_to_curr_speclist ? ( add_help = false ) ? header exe =
let add_to_curr_speclist ? ( add_help = false ) ? header parse_action =
let mk_header_spec heading =
( " " , Unit ( fun () -> () ) , " \n " ^ heading ^ " \n " ) in
let exe_descs = IList . assoc equal_exe exe exe_desc_lists in
let exe_descs =
match parse_action with
| Infer section ->
List . Assoc . find_exn ~ equal : equal_section infer_section_desc_lists section
| Javac | NoParse ->
to_parse_tag parse_action
| > List . Assoc . find_exn ~ equal : equal_parse_tag parse_tag_desc_lists in
let ( exe_speclist , widths ) = normalize ! exe_descs in
let exe_speclist = if add_help
then add_or_suppress_help ( exe_speclist , widths )
else exe_speclist in
let exe_speclist = convert_speclist exe_speclist in
let exe_speclist = to_arg _speclist exe_speclist in
(* Return false if the same option appears in [speclist], unless [doc] is non-empty and the
documentation in [ speclist ] is empty . The goal is to keep only one instance of each option ,
and that instance is the one that has a non - empty docstring if there is one . * )
@ -672,7 +648,7 @@ let parse ?(incomplete=false) ?config_file current_exe exe_usage ~should_parse_c
let unique_exe_speclist = IList . filter ( is_not_dup_with_doc ! curr_speclist ) exe_speclist in
curr_speclist := IList . filter ( is_not_dup_with_doc unique_exe_speclist ) ! curr_speclist @
( match header with
| Some s -> ( convert _spec_triple ( mk_header_spec s ) ) :: unique_exe_speclist
| Some s -> ( to_arg _spec_triple ( mk_header_spec s ) ) :: unique_exe_speclist
| None -> unique_exe_speclist )
in
(* speclist includes args for current exe with docs, and all other args without docs, so
@ -680,47 +656,131 @@ let parse ?(incomplete=false) ?config_file current_exe exe_usage ~should_parse_c
current exe * )
(* reset the speclist between calls to this function *)
curr_speclist := [] ;
if equal_ exe current_exe Driver then (
add_to_curr_speclist ~ add_help : true ~ header : " Driver options " current_exe ;
add_to_curr_speclist ~ header : " Analysis (backend) options " Analyze ;
add_to_curr_speclist ~ header : " Clang frontend options " Clang
if equal_ parse_action parse_action ( Infer Driver ) then (
add_to_curr_speclist ~ add_help : true ~ header : " Driver options " ( Infer Driver ) ;
add_to_curr_speclist ~ header : " Analysis (backend) options " ( Infer Analysis ) ;
add_to_curr_speclist ~ header : " Clang frontend options " ( Infer Clang )
) else
add_to_curr_speclist ~ add_help : true current_exe
add_to_curr_speclist ~ add_help : true parse_action
;
assert ( check_no_duplicates ! curr_speclist )
;
let full_desc_list = List . Assoc . find_exn ~ equal : equal_parse_tag parse_tag_desc_lists parse_tag in
full_speclist := add_or_suppress_help ( normalize ! full_desc_list )
;
let env_args = decode_env_to_argv ( Option . value ( Sys . getenv args_env_var ) ~ default : " " ) in
curr_usage
let select_parse_action ~ incomplete ~ usage action =
let usage = set_curr_speclist_for_parse_action ~ incomplete ~ usage action in
unknown_args_action := if accept_unknown_args action then ` Add else ` Reject ;
usage
let mk_rest_actions ? ( parse_mode = Infer [] ) doc ~ usage decode_action =
let rest = ref [] in
let spec = String ( fun arg ->
rest := List . rev ( Array . to_list ( Array . slice ! args_to_parse ( ! arg_being_parsed + 1 ) 0 ) ) ;
select_parse_action ~ incomplete : false ~ usage ( decode_action arg ) | > ignore ;
(* stop accepting new anonymous arguments *)
unknown_args_action := ` Skip ) in
add parse_mode { long = " -- " ; short = " " ; meta = " " ; doc ; spec ; decode_json = fun _ -> [] } ;
rest
let decode_inferconfig_to_argv path =
let json = match Utils . read_optional_json_file path with
| Ok json ->
json
| Error msg ->
warnf " WARNING: Could not read or parse Infer config in %s:@ \n %s@. " path msg ;
` Assoc [] in
let desc_list = List . Assoc . find_exn ~ equal : equal_parse_tag parse_tag_desc_lists ( Infer () ) in
let json_config = YBU . to_assoc json in
let one_config_item result ( key , json_val ) =
try
let { decode_json } =
IList . find
( fun { long ; short } ->
String . equal key long
| | (* for deprecated options *) String . equal key short )
! desc_list in
decode_json json_val @ result
with
| Not_found ->
warnf " WARNING: while reading config file %s:@ \n Unknown option %s@. " path key ;
result
| YBU . Type_error ( msg , json ) ->
warnf " WARNING: while reading config file %s:@ \n Ill-formed value %s for option %s: %s@. "
path ( Yojson . Basic . to_string json ) key msg ;
result in
IList . fold_left one_config_item [] json_config
(* * separator of argv elements when encoded into environment variables *)
let env_var_sep = '^'
let encode_argv_to_env argv =
String . concat ~ sep : ( String . make 1 env_var_sep )
( IList . filter ( fun arg ->
not ( String . contains arg env_var_sep )
| | (
warnf " Ignoring unsupported option containing '%c' character: %s@ \n "
env_var_sep arg ;
false
)
) argv )
let decode_env_to_argv env =
Str . split ( Str . regexp_string ( String . make 1 env_var_sep ) ) env
(* * [prefix_before_rest ( prefix @ ["--" :: rest] ) ] is [prefix] where "--" is not in [prefix]. *)
let rev_prefix_before_rest args =
let rec rev_prefix_before_rest_ rev_keep = function
| [] | " -- " :: _ -> rev_keep
| keep :: args -> rev_prefix_before_rest_ ( keep :: rev_keep ) args in
rev_prefix_before_rest_ [] args
(* * environment variable use to pass arguments from parent to child processes *)
let args_env_var = " INFER_ARGS "
let extra_env_args = ref []
let extend_env_args args =
extra_env_args := List . rev_append args ! extra_env_args
let parse_args ~ incomplete ~ usage action args =
let exe_name = Sys . executable_name in
let env_cl_args =
if should_parse_cl_args then prepend_to_argv env_args
else env_args in
let all_args = match config_file with
| None -> env_cl_args
| Some path ->
let json_args = decode_inferconfig_to_argv current_exe path in
(* read .inferconfig first, as both env vars and command-line options overwrite it *)
json_args @ env_cl_args in
args_to_parse := Array . of_list ( exe_name :: all_args ) ;
args_to_parse := Array . of_list ( exe_name :: args ) ;
arg_being_parsed := 0 ;
let curr_usage = select_parse_action ~ incomplete ~ usage action in
(* tests if msg indicates an unknown option, as opposed to a known option with bad argument *)
let is_unknown msg = String . is_substring msg ~ substring : " : unknown option " in
accept_unknown_args := false ;
let rec parse_loop () =
try
Arg . parse_argv_dynamic ~ current : arg_being_parsed ! args_to_parse curr_speclist
( fun arg -> ! anon_fun arg ) usage_msg
anon_fun usage
with
| Arg . Bad _ when incomplete -> parse_loop ()
| Arg . Bad msg when ! accept_unknown_args && is_unknown msg ->
! anon_fun ! args_to_parse . ( ! arg_being_parsed ) ;
parse_loop ()
| Arg . Bad usage_msg -> Pervasives . prerr_string usage_msg ; exit 2
| Arg . Bad usage_msg ->
if ! unknown_args_action < > ` Reject && is_unknown usage_msg then (
anon_fun ! args_to_parse . ( ! arg_being_parsed ) ;
parse_loop ()
) else (
Pervasives . prerr_string usage_msg ;
exit 2
)
| Arg . Help usage_msg -> Pervasives . print_string usage_msg ; exit 0
in
parse_loop () ;
if not incomplete then (
curr_usage
let parse ? ( incomplete = false ) ? config_file ~ usage action =
let env_args = decode_env_to_argv ( Option . value ( Sys . getenv args_env_var ) ~ default : " " ) in
let inferconfig_args =
Option . map ~ f : decode_inferconfig_to_argv config_file | > Option . value ~ default : [] in
let args_to_export = ref " " in
let add_parsed_args_to_args_to_export () =
(* reread args_to_parse instead of using all_args since mk_path_helper may have modified them *)
let prog_args =
List . rev_append
@ -728,6 +788,20 @@ let parse ?(incomplete=false) ?config_file current_exe exe_usage ~should_parse_c
( List . rev ! extra_env_args ) in
(* do not include program path in args passed via env var *)
let args = Option . value ( List . tl prog_args ) ~ default : [] in
Unix . putenv ~ key : args_env_var ~ data : ( encode_argv_to_env args )
) ;
if not ( List . is_empty args ) then
let arg_string =
if String . equal ! args_to_export " " then encode_argv_to_env args
else ! args_to_export ^ String . of_char env_var_sep ^ encode_argv_to_env args in
args_to_export := arg_string in
(* read .inferconfig first, then env vars, then command-line options *)
parse_args ~ incomplete ~ usage ( Infer Driver ) inferconfig_args | > ignore ;
if not incomplete then add_parsed_args_to_args_to_export () ;
parse_args ~ incomplete ~ usage ( Infer Driver ) env_args | > ignore ;
if not incomplete then add_parsed_args_to_args_to_export () ;
let curr_usage =
let cl_args = match Array . to_list Sys . argv with _ :: tl -> tl | [] -> [] in
let curr_usage = parse_args ~ incomplete ~ usage action cl_args in
if not incomplete then add_parsed_args_to_args_to_export () ;
curr_usage in
if not incomplete then Unix . putenv ~ key : args_env_var ~ data : ! args_to_export ;
curr_usage