Skip to content

Commit 6077dc1

Browse files
jmidjmid
committed
Move Model module up front
1 parent 1fdd2a4 commit 6077dc1

File tree

1 file changed

+91
-90
lines changed

1 file changed

+91
-90
lines changed

‎src/sys/stm_tests.ml‎

Lines changed: 91 additions & 90 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,99 @@
11
open QCheck
22
open STM
33

4+
module Model =
5+
struct
6+
module Map_names = Map.Make (String)
7+
8+
type filesys =
9+
| Directory of {fs_map: filesys Map_names.t}
10+
| File
11+
12+
let rec find_opt fs path =
13+
match fs with
14+
| File ->
15+
if path = []
16+
then Some fs
17+
else None
18+
| Directory d ->
19+
(match path with
20+
| [] -> Some (Directory d)
21+
| hd :: tl ->
22+
(match Map_names.find_opt hd d.fs_map with
23+
| None -> None
24+
| Some fs -> find_opt fs tl))
25+
26+
let mem fs path = find_opt fs path <> None
27+
28+
(* generic removal function *)
29+
let rec remove fs path file_name =
30+
match fs with
31+
| File -> fs
32+
| Directory d ->
33+
(match path with
34+
| [] ->
35+
(match Map_names.find_opt file_name d.fs_map with
36+
| None
37+
| Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map })
38+
| dir::dirs ->
39+
Directory
40+
{ fs_map = Map_names.update dir (function
41+
| None -> None
42+
| Some File -> Some File
43+
| Some (Directory _ as d') -> Some (remove d' dirs file_name)) d.fs_map
44+
})
45+
46+
let readdir fs path =
47+
match find_opt fs path with
48+
| None -> None
49+
| Some fs ->
50+
(match fs with
51+
| File -> None
52+
| Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map []))
53+
54+
let update_map_name map_name k v = Map_names.update k (fun _ -> Some v) map_name
55+
56+
(* generic insertion function *)
57+
let rec insert fs path new_file_name sub_tree =
58+
match fs with
59+
| File -> fs
60+
| Directory d ->
61+
(match path with
62+
| [] ->
63+
Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map}
64+
| next_in_path :: tl_path ->
65+
(match Map_names.find_opt next_in_path d.fs_map with
66+
| None -> fs
67+
| Some sub_fs ->
68+
let nfs = insert sub_fs tl_path new_file_name sub_tree in
69+
if nfs = sub_fs
70+
then fs
71+
else Directory {fs_map = update_map_name d.fs_map next_in_path nfs}))
72+
73+
let separate_path path =
74+
match List.rev path with
75+
| [] -> None
76+
| name::rev_path -> Some (List.rev rev_path, name)
77+
78+
let rename fs old_path new_path =
79+
match separate_path old_path, separate_path new_path with
80+
| None, _
81+
| _, None -> fs
82+
| Some (old_path_pref, old_name), Some (new_path_pref, new_name) ->
83+
(match find_opt fs new_path_pref with
84+
| None
85+
| Some File -> fs
86+
| Some (Directory _) ->
87+
(match find_opt fs old_path with
88+
| None -> fs
89+
| Some sub_fs ->
90+
let fs' = remove fs old_path_pref old_name in
91+
insert fs' new_path_pref new_name sub_fs))
92+
end
93+
494
module SConf =
595
struct
96+
include Model
697
type path = string list
798

899
type cmd =
@@ -30,20 +121,12 @@ struct
30121

31122
let show_cmd = Util.Pp.to_show pp_cmd
32123

33-
module Map_names = Map.Make (String)
34-
35-
type filesys =
36-
| Directory of {fs_map: filesys Map_names.t}
37-
| File
38-
39124
type state = filesys
40125

41126
type sut = unit
42127

43128
let (/) = Filename.concat
44129

45-
let update_map_name map_name k v = Map_names.update k (fun _ -> Some v) map_name
46-
47130
(* var gen_existing_path : filesys -> path Gen.t *)
48131
let rec gen_existing_path fs =
49132
match fs with
@@ -102,88 +185,6 @@ struct
102185

103186
let init_state = Directory {fs_map = Map_names.empty}
104187

105-
module Model =
106-
struct
107-
let rec find_opt fs path =
108-
match fs with
109-
| File ->
110-
if path = []
111-
then Some fs
112-
else None
113-
| Directory d ->
114-
(match path with
115-
| [] -> Some (Directory d)
116-
| hd :: tl ->
117-
(match Map_names.find_opt hd d.fs_map with
118-
| None -> None
119-
| Some fs -> find_opt fs tl))
120-
121-
let mem fs path = find_opt fs path <> None
122-
123-
(* generic removal function *)
124-
let rec remove fs path file_name =
125-
match fs with
126-
| File -> fs
127-
| Directory d ->
128-
(match path with
129-
| [] ->
130-
(match Map_names.find_opt file_name d.fs_map with
131-
| None
132-
| Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map })
133-
| dir::dirs ->
134-
Directory
135-
{ fs_map = Map_names.update dir (function
136-
| None -> None
137-
| Some File -> Some File
138-
| Some (Directory _ as d') -> Some (remove d' dirs file_name)) d.fs_map
139-
})
140-
141-
let readdir fs path =
142-
match find_opt fs path with
143-
| None -> None
144-
| Some fs ->
145-
(match fs with
146-
| File -> None
147-
| Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map []))
148-
149-
(* generic insertion function *)
150-
let rec insert fs path new_file_name sub_tree =
151-
match fs with
152-
| File -> fs
153-
| Directory d ->
154-
(match path with
155-
| [] ->
156-
Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map}
157-
| next_in_path :: tl_path ->
158-
(match Map_names.find_opt next_in_path d.fs_map with
159-
| None -> fs
160-
| Some sub_fs ->
161-
let nfs = insert sub_fs tl_path new_file_name sub_tree in
162-
if nfs = sub_fs
163-
then fs
164-
else Directory {fs_map = update_map_name d.fs_map next_in_path nfs}))
165-
166-
let separate_path path =
167-
match List.rev path with
168-
| [] -> None
169-
| name::rev_path -> Some (List.rev rev_path, name)
170-
171-
let rename fs old_path new_path =
172-
match separate_path old_path, separate_path new_path with
173-
| None, _
174-
| _, None -> fs
175-
| Some (old_path_pref, old_name), Some (new_path_pref, new_name) ->
176-
(match find_opt fs new_path_pref with
177-
| None
178-
| Some File -> fs
179-
| Some (Directory _) ->
180-
(match find_opt fs old_path with
181-
| None -> fs
182-
| Some sub_fs ->
183-
let fs' = remove fs old_path_pref old_name in
184-
insert fs' new_path_pref new_name sub_fs))
185-
end
186-
187188
let path_is_a_dir fs path =
188189
match Model.find_opt fs path with
189190
| None

0 commit comments

Comments
 (0)