Merge pull request #197 from ocurrent/win32-exit-status

Display Windows `NTSTATUS` exit codes in hex

Author: mtelvers

lib/os.ml

@@ -34,6 +34,12 @@ let pp_cmd f (cmd, argv) =
   let argv = if cmd = "" then argv else cmd :: argv in
   Fmt.hbox Fmt.(list ~sep:sp (quote string)) f argv
 
+let pp_exit_status f n =
+  if Sys.win32 && n < 0 then
+    Fmt.pf f "0x%08lx" (Int32.of_int n)
+  else
+    Fmt.int f n
+
 let redirection = function
   | `FD_move_safely x -> `FD_copy x.raw
   | `Dev_null -> `Dev_null
@@ -87,7 +93,7 @@ let process_result ~pp proc =
   | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x)
   >>= function
   | Ok 0 -> Lwt_result.return ()
-  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n
+  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n
   | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string])
 
 (* Overridden in unit-tests *)
@@ -97,15 +103,15 @@ let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="")
   Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
   !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
   | Ok n when is_success n -> Lwt_result.ok Lwt.return_unit
-  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n
+  | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n
   | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string])
 
 let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv =
   Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv));
   let pp f = pp_cmd f (cmd, argv) in
   !lwt_process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function
   | Ok n when is_success n -> Lwt.return_unit
-  | Ok n -> Fmt.failwith "%t failed with exit status %d" pp n
+  | Ok n -> Fmt.failwith "%t failed with exit status %a" pp pp_exit_status n
   | Error (`Msg m) -> failwith m
 
 let running_as_root = not (Sys.unix) || Unix.getuid () = 0