Commits

Sebastien Mondet committed 5012443

System: add *_to_string functions

Comments (0)

Files changed (1)

       (string * string * [ `Exited of int | `Signaled of int | `Stopped of int ],
        [> `Shell of string * [> `Exn of exn ]]) t
 
+    val status_to_string:
+      [< `Exited of int | `Exn of exn | `Signaled of int | `Stopped of int ] ->
+      string
+    (** Convert a status (or an error) to a human-readable string *)
+
   end
 
   (** Execute a function [f] with a timeout (in seconds). If [f] throws
     | `Fifo
     | `Socket]
 
+  val file_info_to_string: file_info -> string
+  (** Convert file information to a string *)
+
   (** Get information about a path (whether it exists, its size, or
       sym-link destination). If [follow_symlink] is [false]
       (default) use [lstat] (so the result can be [`Symlink _]), if [true]
   val remove: string ->
     (unit,
      [> `System of [> `File_info of string
-                   | `IO of [> `File_exists of string | `Wrong_path of string ]
                    | `Remove of string
-                   | `List_directory of string ] * [> `Exn of exn ] ]) t
+                   | `List_directory of string ] * 
+            [>  `Exn of exn ] ]) t
 
   (** Make a symbolic link [link_path] pointing at
       [target]. [make_symlink] fails if the file [link_path] already
                      | `List_directory of string ] *
                        [> `Exn of exn
                        | `File_not_found of string] ]) t
+
+  val error_to_string:
+    [< `Shell of string *
+           [< `Exited of int | `Exn of exn | `Signaled of int | `Stopped of int ]
+    | `System of
+         [< `Copy of string 
+         | `File_info of string 
+         | `File_tree of string 
+         | `List_directory of string 
+         | `Make_directory of string 
+         | `Make_symlink of string * string 
+         | `Move of string 
+         | `Remove of string ]
+         * [< `Already_exists 
+           | `Exn of exn 
+           | `File_exists of string 
+           | `File_not_found of string 
+           | `IO of [< `Exn of exn 
+                    | `File_exists of string 
+                    | `Read_file_exn of string * exn 
+                    | `Write_file_exn of string * exn 
+                    | `Wrong_path of string ] 
+           | `Not_a_directory of string 
+           | `Wrong_access_rights of int 
+           | `Wrong_file_kind of string * file_info
+           | `Wrong_path of string ] 
+    ] -> string
+  (** Make a human-readable string for any error in this module. *)
+
 end
 
 
       | Lwt_unix.WSTOPPED n -> fail (`Shell (s, `Stopped n))
     end
 
-  let do_or_fail s =
-    wrap_deferred  Lwt_io.(fun () -> Lwt_unix.system s)
-      ~on_exn:(fun e -> `Shell (s, `Exn e))
-    >>= fun ret ->
-    discriminate_process_status s ret
+    let status_to_string = function
+    | `Exited i -> sprintf "Exited with %d" i
+    | `Exn e -> sprintf "Exception %s" (exn e)
+    | `Signaled i -> sprintf "Signaled (%d)" i
+    | `Stopped i -> sprintf "Stopped (%d)" i
 
+    let do_or_fail s =
+      wrap_deferred  Lwt_io.(fun () -> Lwt_unix.system s)
+        ~on_exn:(fun e -> `Shell (s, `Exn e))
+      >>= fun ret ->
+      discriminate_process_status s ret
 
-  let execute s =
-    wrap_deferred ~on_exn:(fun e -> `Shell (s, `Exn e))
-      Lwt.(fun () ->
+
+    let execute s =
+      wrap_deferred ~on_exn:(fun e -> `Shell (s, `Exn e))
+        Lwt.(fun () ->
           let inprocess = Lwt_process.(open_process_full (shell s)) in
           Lwt_list.map_p Lwt_io.read
             [inprocess#stdout; inprocess#stderr; ]
           >>= fun output ->
           inprocess#status >>= fun status ->
           return (status, output))
-    >>= fun (ret, output) ->
-    let code =
-      match ret with
-      | Lwt_unix.WEXITED n ->   (`Exited n)
-      | Lwt_unix.WSIGNALED n -> (`Signaled n)
-      | Lwt_unix.WSTOPPED n ->  (`Stopped n)
-    in
-    begin match output with
-    | [out; err] -> return (out, err, code)
-    | _ -> assert false
-    end
+      >>= fun (ret, output) ->
+      let code =
+        match ret with
+        | Lwt_unix.WEXITED n ->   (`Exited n)
+        | Lwt_unix.WSIGNALED n -> (`Signaled n)
+        | Lwt_unix.WSTOPPED n ->  (`Stopped n)
+      in
+      begin match output with
+      | [out; err] -> return (out, err, code)
+      | _ -> assert false
+      end
 
   end
 
        | `System e -> fail (`System e)
        end)
 
+  let file_info_to_string = function
+  | `Absent -> "Absent"
+  | `Regular_file i -> sprintf "Regular file (size %d B)" i
+  | `Symlink s -> sprintf "Sym-link to %S" s
+  | `Block_device -> "Block device"
+  | `Character_device -> "Character device"
+  | `Directory -> "Directory"
+  | `Fifo -> "FIFO"
+  | `Socket -> "Socket"
+
 
+  let error_to_string = function
+  | `System (where, what) ->
+    sprintf "System error while %s: %s"
+      begin match where with
+      | `File_info s -> sprintf "getting info on %S" s
+      | `Make_directory s -> sprintf "making directory %S" s
+         (* | `IO of [ `File_exists of string | `Wrong_path of string ] *)
+      | `File_tree s -> sprintf "getting file tree from %S" s
+      | `Move s -> sprintf "moving %S" s
+      | `Copy s -> sprintf "copying %S" s
+      | `Make_symlink (s1, s2) -> sprintf "Making symlink from target %S to %s" s1 s2
+      | `Remove s -> sprintf "removing %S" s
+      | `List_directory s -> sprintf "listing directory %S" s
+      end
+      begin match what with
+      | `Already_exists -> "Already exists"
+      | `IO _ as e -> sprintf "I/O Error %S" (IO.error_to_string e)
+      | `File_not_found s -> sprintf "File not found (%S)" s
+      | `Not_a_directory s -> sprintf "Not a directory (%S)" s
+      | `File_exists s -> sprintf "File exists (%S)" s
+      | `Wrong_path s -> sprintf "Wrong path (%S)" s
+      | `Wrong_file_kind (s, k) ->
+        sprintf "Wrong kind of file (%S: %s)" s (file_info_to_string k)
+      | `Exn e -> sprintf "Exception %s" (exn e)
+      | `Wrong_access_rights o -> sprintf "wrong access rights: 0o%o" o
+      end
+  | `Shell (cmd, err) ->
+    sprintf "Shell command %S failed: %s" cmd
+      (Shell.status_to_string err)
 
 end