style adjustment, make touch return an integer, dune file update

Author: Lucccyo

src/sys/dune

@@ -1,22 +1,10 @@
 ;; Test of the Sys library
 
-;; this prevents the tests from running on a default build
-
-(alias
- (name default)
- (package multicoretests)
- (deps stm_tests.exe))
-
-(executable
+(test
  (name stm_tests)
  (modules stm_tests)
- (libraries qcheck-stm.sequential qcheck-stm.domain)
- (preprocess
-  (pps ppx_deriving.show)))
-
-(rule
- (alias runtest)
  (package multicoretests)
- (deps stm_tests.exe)
- (action
-  (run ./%{deps} --verbose)))
+ (libraries qcheck-stm.sequential qcheck-stm.domain)
+ (preprocess (pps ppx_deriving.show))
+ (action (run %{test} --verbose))
+)

src/sys/stm_tests.ml

@@ -1,5 +1,5 @@
 open QCheck
-open STM_base
+open STM
 
 module SConf =
 struct
@@ -28,66 +28,66 @@ struct
   let arb_cmd _s  =
     let name_gen = Gen.(oneofl ["aaa" ; "bbb" ; "ccc" ; "ddd" ; "eee"]) in
     let path_gen = Gen.map (fun path -> path) (Gen.list_size (Gen.int_bound 5) name_gen) in (* can be empty *)
-    let perm_gen = Gen.(oneofl [0o777]) in
+    let perm_gen = Gen.return 0o777 in
     QCheck.make ~print:show_cmd
       Gen.(oneof
             [
-                map (fun path -> File_exists (path)) path_gen ;
+                map (fun path -> File_exists path) path_gen ;
                 map3 (fun path new_dir_name perm -> Mkdir (path, new_dir_name, perm)) path_gen name_gen perm_gen;
                 map2 (fun path delete_dir_name -> Rmdir (path, delete_dir_name)) path_gen name_gen;
-                map (fun path -> Readdir (path)) path_gen;
+                map (fun path -> Readdir path) path_gen;
                 map3 (fun path new_file_name perm -> Touch (path, new_file_name, perm)) path_gen name_gen perm_gen;
             ])
 
   let static_path = Sys.getcwd ()
 
   let init_state  = Directory {perm = 0o777; fs_map = Map_names.empty}
 
-  let rec find_opt fs path =
+  let rec find_opt_model fs path =
     match fs with
     | File f ->
       if path = []
       then Some (File f)
       else None
     | Directory d ->
-        (match path with
-        | []       -> Some (Directory d)
-        | hd :: tl ->
-          (match Map_names.find_opt hd d.fs_map with
-          | None    -> None
-          | Some fs -> find_opt fs tl))
+      (match path with
+      | []       -> Some (Directory d)
+      | hd :: tl ->
+        (match Map_names.find_opt hd d.fs_map with
+        | None    -> None
+        | Some fs -> find_opt_model fs tl))
 
-  let mem fs path = find_opt fs path <> None
+  let mem_model fs path = find_opt_model fs path <> None
 
-  let rec mkdir fs path new_dir_name perm =
+  let rec mkdir_model fs path new_dir_name perm =
     match fs with
-    | File _      -> fs
+    | File _ -> fs
     | Directory d ->
       (match path with
       | [] ->
         let new_dir = Directory {perm; fs_map = Map_names.empty} in
         Directory {d with fs_map = Map_names.add new_dir_name new_dir d.fs_map}
       | next_in_path :: tl_path ->
         (match Map_names.find_opt next_in_path d.fs_map with
-        | None        -> fs
+        | None -> fs
         | Some sub_fs ->
-          let nfs = mkdir sub_fs tl_path new_dir_name perm in
+          let nfs = mkdir_model sub_fs tl_path new_dir_name perm in
           if nfs = sub_fs
           then fs
           else
             let new_map = Map_names.remove next_in_path d.fs_map in
             let new_map = Map_names.add next_in_path nfs new_map in
             Directory {d with fs_map = new_map}))
 
-  let readdir fs path =
-    match find_opt fs path with
+  let readdir_model fs path =
+    match find_opt_model fs path with
     | None    -> None
     | Some fs ->
-      match fs with
+      (match fs with
       | File _ -> None
-      | Directory d -> Some (Map_names.fold (fun k _ l -> l @ [k]) d.fs_map [])
+      | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map []))
 
-  let rec rmdir fs path delete_dir_name =
+  let rec rmdir_model fs path delete_dir_name =
     match fs with
     | File _      -> fs
     | Directory d ->
@@ -101,13 +101,12 @@ struct
         (match Map_names.find_opt next_in_path d.fs_map with
         | None        -> fs
         | Some sub_fs ->
-          let nfs = rmdir sub_fs tl_path delete_dir_name in
+          let nfs = rmdir_model sub_fs tl_path delete_dir_name in
           if nfs = sub_fs
           then fs
-          else
-            Directory {d with fs_map = (update_map_name d.fs_map next_in_path nfs)}))
+          else Directory {d with fs_map = (update_map_name d.fs_map next_in_path nfs)}))
 
-  let rec touch fs path new_file_name perm =
+  let rec touch_model fs path new_file_name perm =
     match fs with
     | File _      -> fs
     | Directory d ->
@@ -119,36 +118,32 @@ struct
         (match Map_names.find_opt next_in_path d.fs_map with
         | None        -> fs
         | Some sub_fs ->
-          let nfs = touch sub_fs tl_path new_file_name perm in
+          let nfs = touch_model sub_fs tl_path new_file_name perm in
           if nfs = sub_fs
           then fs
-          else
-            Directory {d with fs_map = update_map_name d.fs_map next_in_path nfs}))
+          else Directory {d with fs_map = update_map_name d.fs_map next_in_path nfs}))
 
   let next_state c fs =
     match c with
-    | File_exists (_path) -> fs
+    | File_exists _path -> fs
     | Mkdir (path, new_dir_name, perm) ->
-      if mem fs (path @ [new_dir_name])
+      if mem_model fs (path @ [new_dir_name])
       then fs
-      else mkdir fs path new_dir_name perm
+      else mkdir_model fs path new_dir_name perm
     | Rmdir (path,delete_dir_name) ->
-      if mem fs (path @ [delete_dir_name])
-      then rmdir fs path delete_dir_name
+      if mem_model fs (path @ [delete_dir_name])
+      then rmdir_model fs path delete_dir_name
       else fs
     | Readdir _path -> fs
     | Touch (path, new_file_name, perm) ->
-      if mem fs (path @ [new_file_name])
+      if mem_model fs (path @ [new_file_name])
       then fs
-      else touch fs path new_file_name perm
+      else touch_model fs path new_file_name perm
 
   let init_sut () =
     match Sys.os_type with
-    | "Unix" -> ignore (Sys.command ("rm -rf " ^ (static_path / "sandbox_root") ^ " && mkdir " ^ (static_path / "sandbox_root")))
-    | "Win32" ->
-      ignore (Sys.command (
-      "powershell -Command \"Remove-Item -Path " ^ (static_path / "sandbox_root") ^ " -Recurse -Force -ErrorAction Ignore \"
-       & mkdir " ^ (static_path / "sandbox_root")))
+    | "Unix" -> ignore (Sys.command ("mkdir " ^ (static_path / "sandbox_root")))
+    | "Win32" -> ignore (Sys.command ("mkdir " ^ (static_path / "sandbox_root")))
     | v -> failwith ("Sys tests not working with " ^ v)
 
   let cleanup _ =
@@ -163,71 +158,73 @@ struct
 
   let run c _file_name =
     match c with
-    | File_exists (path) -> Res (bool, Sys.file_exists (p path))
+    | File_exists path -> Res (bool, Sys.file_exists (p path))
     | Mkdir (path, new_dir_name, perm) ->
       Res (result unit exn, protect (Sys.mkdir ((p path) / new_dir_name)) perm)
     | Rmdir (path, delete_dir_name) ->
       Res (result unit exn, protect (Sys.rmdir) ((p path) / delete_dir_name))
-    | Readdir (path) ->
+    | Readdir path ->
       Res (result (array string) exn, protect (Sys.readdir) (p path))
     | Touch (path, new_file_name, _perm) ->
-        (match Sys.os_type with
-        | "Unix" -> Res (unit, ignore(Sys.command ("touch " ^ (p path) / new_file_name ^ " 2>/dev/null")))
-        | "Win32" -> Res (unit, ignore(Sys.command ("type nul >> \"" ^ (p path / new_file_name) ^ "\"")))
-        | v -> failwith ("Sys tests not working with " ^ v))
+      (match Sys.os_type with
+      | "Unix" -> Res (int, Sys.command ("touch " ^ (p path) / new_file_name ^ " 2>/dev/null"))
+      | "Win32" -> Res (int, Sys.command ("type nul >> \"" ^ (p path / new_file_name) ^ "\""))
+      | v -> failwith ("Sys tests not working with " ^ v))
 
   let fs_is_a_dir fs = match fs with | Directory _ -> true | File _ -> false
 
   let path_is_a_dir fs path =
-    match find_opt fs path with
+    match find_opt_model fs path with
     | None -> false
     | Some target_fs -> fs_is_a_dir target_fs
 
   let postcond c (fs: filesys) res =
     match c, res with
-    | File_exists (path), Res ((Bool,_),b) -> b = mem fs path
+    | File_exists path, Res ((Bool,_),b) -> b = mem_model fs path
     | Mkdir (path, new_dir_name, _perm), Res ((Result (Unit,Exn),_), res) ->
       let complete_path = (path @ [new_dir_name]) in
       (match res with
-       | Error err ->
-         (match err with
-           | Sys_error s ->
-             (s = (p complete_path) ^ ": Permission denied") ||
-             (s = (p complete_path) ^ ": File exists" && mem fs complete_path) ||
-             (s = (p complete_path) ^ ": No such file or directory" && not (mem fs path)) ||
-             (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs complete_path))
-           | _ -> false)
-        | Ok () -> not (mem fs complete_path) && mem fs path && path_is_a_dir fs path)
+      | Error err ->
+        (match err with
+        | Sys_error s ->
+          (s = (p complete_path) ^ ": Permission denied") ||
+          (s = (p complete_path) ^ ": File exists" && mem_model fs complete_path) ||
+          (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs path)) ||
+          (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs complete_path))
+          | _ -> false)
+        | Ok () -> mem_model fs path && path_is_a_dir fs path && not (mem_model fs complete_path))
     | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) ->
       let complete_path = (path @ [delete_dir_name]) in
       (match res with
-       | Error err ->
-         (match err with
-           | Sys_error s ->
-             (s = (p complete_path) ^ ": Directory not empty" && not (readdir fs complete_path = Some [])) ||
-             (s = (p complete_path) ^ ": No such file or directory" && not (mem fs complete_path)) ||
-             (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs complete_path))
-           | _ -> false)
-        | Ok () ->
-          let is_empty = readdir fs complete_path = Some [] in
-          mem fs complete_path && is_empty && path_is_a_dir fs complete_path)
-    | Readdir (path), Res ((Result (Array String,Exn),_), res) ->
+      | Error err ->
+        (match err with
+          | Sys_error s ->
+            (s = (p complete_path) ^ ": Directory not empty" && not (readdir_model fs complete_path = Some [])) ||
+            (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) ||
+            (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs complete_path))
+          | _ -> false)
+      | Ok () ->
+          mem_model fs complete_path && path_is_a_dir fs complete_path && readdir_model fs complete_path = Some [])
+    | Readdir path, Res ((Result (Array String,Exn),_), res) ->
       (match res with
-       | Error err ->
-         (match err with
-           | Sys_error s ->
-             (s = (p path) ^ ": Permission denied") ||
-             (s = (p path) ^ ": No such file or directory" && not (mem fs path)) ||
-             (s = (p path) ^ ": Not a directory" && not (path_is_a_dir fs path))
-           | _ -> false)
-        | Ok array_of_subdir ->
-          let sut = List.sort (fun a b -> -(String.compare a b)) (Array.to_list array_of_subdir) in
-          let same_result =
-            (match readdir fs path with
-            | None   -> false
-            | Some l -> List.sort (fun a b -> -(String.compare a b)) l = sut) in
-          same_result && mem fs path && path_is_a_dir fs path)
-    | Touch (_path, _new_dir_name, _perm), Res ((Unit,_),_) -> true
+      | Error err ->
+        (match err with
+          | Sys_error s ->
+            (s = (p path) ^ ": Permission denied") ||
+            (s = (p path) ^ ": No such file or directory" && not (mem_model fs path)) ||
+            (s = (p path) ^ ": Not a directory" && not (path_is_a_dir fs path))
+          | _ -> false)
+      | Ok array_of_subdir ->
+        mem_model fs path && path_is_a_dir fs path &&
+        (match readdir_model fs path with
+        | None   -> false
+        | Some l ->
+          List.sort String.compare l
+          = List.sort String.compare (Array.to_list array_of_subdir)))
+    | Touch (path, _new_file_name, _perm), Res ((Int,_),n) ->
+      if n = 0
+      then (mem_model fs path && path_is_a_dir fs path)
+      else (not (mem_model fs path) || not (path_is_a_dir fs path))
     | _,_ -> false
 end
 
@@ -236,6 +233,6 @@ module Sys_dom = STM_domain.Make(SConf)
 
 ;;
 QCheck_base_runner.run_tests_main [
-    Sys_seq.agree_test     ~count:1000 ~name:"STM Sys test sequential";
-    Sys_dom.agree_test_par ~count:100  ~name:"STM Sys test parallel"
+    Sys_seq.agree_test     ~count:1000  ~name:"STM Sys test sequential";
+    Sys_dom.agree_test_par ~count:200   ~name:"STM Sys test parallel"
   ]