From 5a73fb9d0688f2c23adb7ac678bc0922f1500d16 Mon Sep 17 00:00:00 2001 From: Takashi Suwa Date: Mon, 9 Sep 2024 00:24:34 +0900 Subject: [PATCH] enable `--full-path`, `--verbose`, and `--quiet` for all the subcommands of `saphe` --- bin-saphe/saphe.ml | 65 +++++++++++++++++++++++++++++++-------- src-saphe/lockFetcher.ml | 10 +++--- src-saphe/lockFetcher.mli | 2 ++ src-saphe/logging.ml | 44 +++++++++++++++----------- src-saphe/logging.mli | 8 ++--- src-saphe/sapheMain.ml | 60 ++++++++++++++++++++---------------- src-saphe/sapheMain.mli | 23 +++++++++++--- 7 files changed, 144 insertions(+), 68 deletions(-) diff --git a/bin-saphe/saphe.ml b/bin-saphe/saphe.ml index baa4b4a92..6415248f9 100644 --- a/bin-saphe/saphe.ml +++ b/bin-saphe/saphe.ml @@ -2,20 +2,46 @@ open LoggingUtil -let init_document fpath_in = - SapheMain.init_document ~fpath_in +let init_document + fpath_in + show_full_path + verbosity += + SapheMain.init_document + ~fpath_in + ~show_full_path + ~verbosity -let init_library fpath_in = - SapheMain.init_library ~fpath_in +let init_library + fpath_in + show_full_path + verbosity += + SapheMain.init_library + ~fpath_in + ~show_full_path + ~verbosity -let cache_list () = - SapheMain.cache_list () +let cache_list + show_full_path + verbosity += + SapheMain.cache_list + ~show_full_path + ~verbosity -let update fpath_in = - SapheMain.update ~fpath_in +let update + fpath_in + show_full_path + verbosity += + SapheMain.update + ~fpath_in + ~show_full_path + ~verbosity let solve @@ -172,13 +198,21 @@ let flag_bytecomp = let command_init_document : unit Cmdliner.Cmd.t = let open Cmdliner in Cmd.v (Cmd.info "document") - Term.(const init_document $ arg_in_to_create) + Term.(const init_document + $ arg_in_to_create + $ flag_full_path + $ flag_verbosity + ) let command_init_library : unit Cmdliner.Cmd.t = let open Cmdliner in Cmd.v (Cmd.info "library") - Term.(const init_library $ arg_in_to_create) + Term.(const init_library + $ arg_in_to_create + $ flag_full_path + $ flag_verbosity + ) let command_init : unit Cmdliner.Cmd.t = @@ -192,7 +226,11 @@ let command_init : unit Cmdliner.Cmd.t = let command_update : unit Cmdliner.Cmd.t = let open Cmdliner in Cmd.v (Cmd.info "update") - Term.(const update $ arg_in) + Term.(const update + $ arg_in + $ flag_full_path + $ flag_verbosity + ) let command_solve : unit Cmdliner.Cmd.t = @@ -240,7 +278,10 @@ let command_test : unit Cmdliner.Cmd.t = let command_cache_list : unit Cmdliner.Cmd.t = let open Cmdliner in Cmd.v (Cmd.info "list") - Term.(const cache_list $ const ()) + Term.(const cache_list + $ flag_full_path + $ flag_verbosity + ) let command_cache : unit Cmdliner.Cmd.t = diff --git a/src-saphe/lockFetcher.ml b/src-saphe/lockFetcher.ml index b9628310f..183ed92d6 100644 --- a/src-saphe/lockFetcher.ml +++ b/src-saphe/lockFetcher.ml @@ -1,5 +1,6 @@ open MyUtil +open LoggingUtil open PackageSystemBase open ConfigError @@ -49,7 +50,7 @@ let extract_external_zip ~(unzip_command : string) ~(zip : abs_path) ~(output_co err @@ FailedToExtractExternalZip{ exit_status; command } -let fetch_registered_lock ~(wget_command : string) ~(tar_command : string) ~store_root:(absdir_store_root : abs_path) (reglock : RegisteredLock.t) (source : implementation_source) : unit ok = +let fetch_registered_lock (logging_spec : logging_spec) ~(wget_command : string) ~(tar_command : string) ~store_root:(absdir_store_root : abs_path) (reglock : RegisteredLock.t) (source : implementation_source) : unit ok = let open ResultMonad in let RegisteredLock.{ registered_package_id; locked_version } = reglock in let RegisteredPackageId.{ registry_hash_value; package_name } = registered_package_id in @@ -68,7 +69,7 @@ let fetch_registered_lock ~(wget_command : string) ~(tar_command : string) ~stor let abspath_config = Constant.library_package_config_path ~dir:absdir_lock in if AbsPathIo.file_exists abspath_config then begin (* If the lock has already been fetched: *) - Logging.lock_already_installed lock_tarball_name absdir_lock; + Logging.lock_already_installed logging_spec lock_tarball_name absdir_lock; return () end else match source with @@ -83,7 +84,7 @@ let fetch_registered_lock ~(wget_command : string) ~(tar_command : string) ~stor in let* () = if AbsPathIo.file_exists abspath_tarball then begin - Logging.lock_cache_exists lock_tarball_name abspath_tarball; + Logging.lock_cache_exists logging_spec lock_tarball_name abspath_tarball; return () end else begin Logging.downloading_lock lock_tarball_name abspath_tarball; @@ -238,13 +239,14 @@ let fetch_external_resources ~(wget_command : string) ~(unzip_command : string) return () -let main ~(wget_command : string) ~(tar_command : string) ~(unzip_command : string) ~(store_root : abs_path) (impl_spec : implementation_spec) : unit ok = +let main (logging_spec : logging_spec) ~(wget_command : string) ~(tar_command : string) ~(unzip_command : string) ~(store_root : abs_path) (impl_spec : implementation_spec) : unit ok = let open ResultMonad in let ImplSpec{ lock; source } = impl_spec in match lock with | Lock.Registered(reglock) -> let* () = fetch_registered_lock + logging_spec ~wget_command ~tar_command ~store_root diff --git a/src-saphe/lockFetcher.mli b/src-saphe/lockFetcher.mli index 0f5f7213e..40b02a6ef 100644 --- a/src-saphe/lockFetcher.mli +++ b/src-saphe/lockFetcher.mli @@ -1,9 +1,11 @@ open MyUtil +open LoggingUtil open PackageSystemBase open ConfigError val main : + logging_spec -> wget_command:string -> tar_command:string -> unzip_command:string -> diff --git a/src-saphe/logging.ml b/src-saphe/logging.ml index d20fb1d2c..e8af01cd7 100644 --- a/src-saphe/logging.ml +++ b/src-saphe/logging.ml @@ -71,30 +71,38 @@ let end_deps_config_output (spec : logging_spec) (abspath_deps_config : abs_path end -let lock_already_installed (lock_name : lock_name) (absdir : abs_path) = - Printf.printf " '%s': already installed at '%s'\n" - lock_name - (AbsPath.to_string absdir) +let lock_already_installed (spec : logging_spec) (lock_name : lock_name) (absdir : abs_path) = + if is_not_quiet spec then begin + Printf.printf " '%s': already installed at '%s'\n" + lock_name + (AbsPath.to_string absdir) + end -let lock_cache_exists (lock_name : lock_name) (abspath_tarball : abs_path) = - Printf.printf " cache for '%s' exists at '%s'\n" - lock_name - (AbsPath.to_string abspath_tarball) +let lock_cache_exists (spec : logging_spec) (lock_name : lock_name) (abspath_tarball : abs_path) = + if is_not_quiet spec then begin + Printf.printf " cache for '%s' exists at '%s'\n" + lock_name + (AbsPath.to_string abspath_tarball) + end -let store_root_config_updated ~(created : bool) (abspath_store_root_config : abs_path) = - let verb = if created then "created" else "updated" in - Printf.printf " %s the store root config '%s'\n" - verb - (AbsPath.to_string abspath_store_root_config) +let store_root_config_updated (spec : logging_spec) ~(created : bool) (abspath_store_root_config : abs_path) = + if is_not_quiet spec then begin + let verb = if created then "created" else "updated" in + Printf.printf " %s the store root config '%s'\n" + verb + (AbsPath.to_string abspath_store_root_config) + end -let package_registry_updated ~(created : bool) (absdir_registry_repo : abs_path) = - let verb = if created then "fetched" else "updated" in - Printf.printf " %s the package registry '%s'\n" - verb - (AbsPath.to_string absdir_registry_repo) +let package_registry_updated (spec : logging_spec) ~(created : bool) (absdir_registry_repo : abs_path) = + if is_not_quiet spec then begin + let verb = if created then "fetched" else "updated" in + Printf.printf " %s the package registry '%s'\n" + verb + (AbsPath.to_string absdir_registry_repo) + end let initialize_file (spec : logging_spec) (abspath_doc : abs_path) = diff --git a/src-saphe/logging.mli b/src-saphe/logging.mli index 50c78a029..3e8408f8f 100644 --- a/src-saphe/logging.mli +++ b/src-saphe/logging.mli @@ -13,13 +13,13 @@ val end_envelope_config_output : logging_spec -> abs_path -> unit val end_deps_config_output : logging_spec -> abs_path -> unit -val lock_already_installed : lock_name -> abs_path -> unit +val lock_already_installed : logging_spec -> lock_name -> abs_path -> unit -val lock_cache_exists : lock_name -> abs_path -> unit +val lock_cache_exists : logging_spec -> lock_name -> abs_path -> unit -val store_root_config_updated : created:bool -> abs_path -> unit +val store_root_config_updated : logging_spec -> created:bool -> abs_path -> unit -val package_registry_updated : created:bool -> abs_path -> unit +val package_registry_updated : logging_spec -> created:bool -> abs_path -> unit val initialize_file : logging_spec -> abs_path -> unit diff --git a/src-saphe/sapheMain.ml b/src-saphe/sapheMain.ml index 1ad7b0432..6b704c55a 100644 --- a/src-saphe/sapheMain.ml +++ b/src-saphe/sapheMain.ml @@ -197,17 +197,16 @@ let assert_nonexistence (abspath : abs_path) = return () -let init_document ~(fpath_in : string) = +let init_document + ~(fpath_in : string) + ~(show_full_path : bool) + ~(verbosity : verbosity) += let res = let open ResultMonad in let absdir_current = AbsPathIo.getcwd () in - let logging_spec = - make_logging_spec - ~show_full_path:true (* TODO: make this changeable *) - ~verbosity:Verbose - ~current_dir:absdir_current - in + let logging_spec = make_logging_spec ~show_full_path ~verbosity ~current_dir:absdir_current in (* Constructs the input: *) let abspath_doc = AbsPath.make_absolute_if_relative ~origin:absdir_current fpath_in in @@ -238,17 +237,16 @@ let init_document ~(fpath_in : string) = | Error(e) -> ErrorReporting.report_config_error e; exit 1 -let init_library ~(fpath_in : string) = +let init_library + ~(fpath_in : string) + ~(show_full_path : bool) + ~(verbosity : verbosity) += let res = let open ResultMonad in let absdir_current = AbsPathIo.getcwd () in - let logging_spec = - make_logging_spec - ~show_full_path:true (* TODO: make this changeable *) - ~verbosity:Verbose - ~current_dir:absdir_current - in + let logging_spec = make_logging_spec ~show_full_path ~verbosity ~current_dir:absdir_current in (* Constructs the input: *) let absdir_package = AbsPath.make_absolute_if_relative ~origin:absdir_current fpath_in in @@ -411,7 +409,7 @@ let solve ShellCommand.mkdir_p absdir_store_root; let* (store_root_config, created) = StoreRootConfig.load_or_initialize abspath_store_root_config in begin - if created then Logging.store_root_config_updated ~created:true abspath_store_root_config + if created then Logging.store_root_config_updated logging_spec ~created:true abspath_store_root_config end; (* Constructs a map that associates a package with its implementations: *) @@ -440,7 +438,7 @@ let solve |> Result.map_error (fun e -> PackageRegistryFetcherError(e)) in begin - if created then Logging.package_registry_updated ~created:true absdir_registry_repo + if created then Logging.package_registry_updated logging_spec ~created:true absdir_registry_repo end; (* Loads the registry config: *) @@ -500,7 +498,7 @@ let solve let unzip_command = "unzip" in (* TODO: make this changeable *) let* () = impl_specs |> foldM (fun () impl_spec -> - LockFetcher.main + LockFetcher.main logging_spec ~wget_command ~tar_command ~unzip_command ~store_root:absdir_store_root impl_spec ) () in @@ -514,15 +512,19 @@ let solve | Error(e) -> ErrorReporting.report_config_error e; exit 1 -let update ~(fpath_in : string) = +let update + ~(fpath_in : string) + ~(show_full_path : bool) + ~(verbosity : verbosity) += let res = let open ResultMonad in + let absdir_current = AbsPathIo.getcwd () in + let logging_spec = make_logging_spec ~show_full_path ~verbosity ~current_dir:absdir_current in + (* Constructs the input: *) - let solve_input = - let absdir_current = AbsPathIo.getcwd () in - make_solve_input ~current_dir:absdir_current ~fpath_in - in + let solve_input = make_solve_input ~current_dir:absdir_current ~fpath_in in let* registry_remotes = match solve_input with @@ -542,7 +544,7 @@ let update ~(fpath_in : string) = let abspath_store_root_config = Constant.store_root_config_path ~store_root:absdir_store_root in ShellCommand.mkdir_p absdir_store_root; let* (store_root_config, created) = StoreRootConfig.load_or_initialize abspath_store_root_config in - Logging.store_root_config_updated ~created abspath_store_root_config; + Logging.store_root_config_updated logging_spec ~created abspath_store_root_config; PackageRegistryArranger.main ~err:(fun e -> CanonicalRegistryUrlError(e)) @@ -567,7 +569,7 @@ let update ~(fpath_in : string) = PackageRegistryFetcher.main ~do_update:true ~git_command absdir_registry_repo registry_remote |> Result.map_error (fun e -> PackageRegistryFetcherError(e)) in - Logging.package_registry_updated ~created absdir_registry_repo; + Logging.package_registry_updated logging_spec ~created absdir_registry_repo; return ([], ()) ) @@ -921,16 +923,22 @@ let continue_if_ok res f = | Error(_) -> () -let cache_list () = +let cache_list + ~(show_full_path : bool) + ~(verbosity : verbosity) += let res = let open ResultMonad in + let absdir_current = AbsPathIo.getcwd () in + let logging_spec = make_logging_spec ~show_full_path ~verbosity ~current_dir:absdir_current in + (* Loads the store root config: *) let* absdir_store_root = get_store_root () in let abspath_store_root_config = Constant.store_root_config_path ~store_root:absdir_store_root in let* (store_root_config, created) = StoreRootConfig.load_or_initialize abspath_store_root_config in begin - if created then Logging.store_root_config_updated ~created:true abspath_store_root_config + if created then Logging.store_root_config_updated logging_spec ~created:true abspath_store_root_config end; let StoreRootConfig.{ registries } = store_root_config in diff --git a/src-saphe/sapheMain.mli b/src-saphe/sapheMain.mli index 9f504bf1a..ff8289e12 100644 --- a/src-saphe/sapheMain.mli +++ b/src-saphe/sapheMain.mli @@ -3,9 +3,17 @@ open LoggingUtil val version : string -val init_document : fpath_in:string -> unit +val init_document : + fpath_in:string -> + show_full_path:bool -> + verbosity:verbosity -> + unit -val init_library : fpath_in:string -> unit +val init_library : + fpath_in:string -> + show_full_path:bool -> + verbosity:verbosity -> + unit val solve : fpath_in:string -> @@ -13,7 +21,11 @@ val solve : verbosity:verbosity -> unit -val update : fpath_in:string -> unit +val update : + fpath_in:string -> + show_full_path:bool -> + verbosity:verbosity -> + unit val build : fpath_in:string -> @@ -39,4 +51,7 @@ val test : verbosity:verbosity -> unit -val cache_list : unit -> unit +val cache_list : + show_full_path:bool -> + verbosity:verbosity -> + unit