enable --full-path, --verbose, and --quiet for all the subcomma…

…nds of `saphe`

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 =

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

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 ->

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) =

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
 

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