24
24
25
25
let flag_concat flag xs =
26
26
String. concat Ext_string. single_space
27
- (Ext_list. flat_map xs (fun x -> [ flag; x ]))
27
+ (Ext_list. flat_map xs (fun x -> [flag; x]))
28
28
29
29
let ( // ) = Ext_path. combine
30
30
@@ -42,11 +42,11 @@ let pp_flag (xs : string) = "-pp " ^ Ext_filename.maybe_quote xs
42
42
43
43
let include_dirs dirs =
44
44
String. concat Ext_string. single_space
45
- (Ext_list. flat_map dirs (fun x -> [ " -I" ; Ext_filename. maybe_quote x ]))
45
+ (Ext_list. flat_map dirs (fun x -> [" -I" ; Ext_filename. maybe_quote x]))
46
46
47
47
let include_dirs_by dirs fn =
48
48
String. concat Ext_string. single_space
49
- (Ext_list. flat_map dirs (fun x -> [ " -I" ; Ext_filename. maybe_quote (fn x) ]))
49
+ (Ext_list. flat_map dirs (fun x -> [" -I" ; Ext_filename. maybe_quote (fn x)]))
50
50
51
51
(* we use lazy $src_root_dir *)
52
52
@@ -64,7 +64,7 @@ let convert_and_resolve_path : string -> string -> string =
64
64
else failwith (" Unknown OS :" ^ Sys. os_type)
65
65
(* we only need convert the path in the beginning *)
66
66
67
- type result = { path : string ; checked : bool }
67
+ type result = {path : string ; checked : bool }
68
68
69
69
(* Magic path resolution:
70
70
foo => foo
@@ -78,7 +78,7 @@ let resolve_bsb_magic_file ~cwd ~desc p : result =
78
78
let no_slash = Ext_string. no_slash_idx p in
79
79
if no_slash < 0 then
80
80
(* Single file FIXME: better error message for "" input *)
81
- { path = p; checked = false }
81
+ {path = p; checked = false }
82
82
else
83
83
let first_char = String. unsafe_get p 0 in
84
84
if Filename. is_relative p && first_char <> '.' then
@@ -91,13 +91,13 @@ let resolve_bsb_magic_file ~cwd ~desc p : result =
91
91
(* let p = if Ext_sys.is_windows_or_cygwin then Ext_string.replace_slash_backward p else p in *)
92
92
let package_dir = Bsb_pkg. resolve_bs_package ~cwd package_name in
93
93
let path = package_dir // relative_path in
94
- if Sys. file_exists path then { path; checked = true }
94
+ if Sys. file_exists path then {path; checked = true }
95
95
else (
96
96
Bsb_log. error " @{<error>Could not resolve @} %s in %s@." p cwd;
97
97
failwith (p ^ " not found when resolving " ^ desc))
98
98
else
99
99
(* relative path [./x/y]*)
100
- { path = convert_and_resolve_path cwd p; checked = true }
100
+ {path = convert_and_resolve_path cwd p; checked = true }
101
101
102
102
(* * converting a file from Linux path format to Windows *)
103
103
@@ -121,7 +121,9 @@ let rec mkp dir =
121
121
122
122
let get_list_string_acc (s : Ext_json_types.t array ) acc =
123
123
Ext_array. to_list_map_acc s acc (fun x ->
124
- match x with Str x -> Some x.str | _ -> None )
124
+ match x with
125
+ | Str x -> Some x.str
126
+ | _ -> None )
125
127
126
128
let get_list_string s = get_list_string_acc s []
127
129
@@ -130,7 +132,7 @@ let ( |? ) m (key, cb) = m |> Ext_json.test key cb
130
132
131
133
type top = Expect_none | Expect_name of string
132
134
133
- type package_context = { proj_dir : string ; top : top ; is_pinned : bool }
135
+ type package_context = {proj_dir : string ; top : top ; is_pinned : bool }
134
136
135
137
(* *
136
138
TODO: check duplicate package name
@@ -146,79 +148,82 @@ type package_context = { proj_dir : string; top : top; is_pinned: bool }
146
148
let pp_packages_rev ppf lst =
147
149
Ext_list. rev_iter lst (fun s -> Format. fprintf ppf " %s " s)
148
150
149
- let extract_pinned_dependencies (map : Ext_json_types.t Map_string.t ) : Set_string.t =
151
+ let extract_pinned_dependencies (map : Ext_json_types.t Map_string.t ) :
152
+ Set_string. t =
150
153
match Map_string. find_opt map Bsb_build_schemas. pinned_dependencies with
151
154
| None -> Set_string. empty
152
- | Some (Arr { content } ) ->
153
- Set_string. of_list (get_list_string content)
155
+ | Some (Arr {content} ) -> Set_string. of_list (get_list_string content)
154
156
| Some config -> Bsb_exception. config_error config " expect an array of string"
155
157
156
158
let rec walk_all_deps_aux (visited : string Hash_string.t ) (paths : string list )
157
159
~(top : top ) (dir : string ) (queue : _ Queue.t ) ~pinned_dependencies =
158
- match Bsb_config_load. load_json ~per_proj_dir: dir ~warn_legacy_config: false with
159
- | _ , Obj { map; loc } ->
160
- let cur_package_name =
161
- match Map_string. find_opt map Bsb_build_schemas. name with
162
- | Some (Str { str; loc } ) ->
163
- (match top with
164
- | Expect_none -> ()
165
- | Expect_name s ->
166
- if s <> str then
167
- Bsb_exception. errorf ~loc
168
- " package name is expected to be %s but got %s" s str);
169
- str
170
- | Some _ | None ->
171
- Bsb_exception. errorf ~loc " package name missing in %s/bsconfig.json"
172
- dir
160
+ match
161
+ Bsb_config_load. load_json ~per_proj_dir: dir ~warn_legacy_config: false
162
+ with
163
+ | _ , Obj {map; loc} ->
164
+ let cur_package_name =
165
+ match Map_string. find_opt map Bsb_build_schemas. name with
166
+ | Some (Str {str; loc} ) ->
167
+ (match top with
168
+ | Expect_none -> ()
169
+ | Expect_name s ->
170
+ if s <> str then
171
+ Bsb_exception. errorf ~loc
172
+ " package name is expected to be %s but got %s" s str);
173
+ str
174
+ | Some _ | None ->
175
+ Bsb_exception. errorf ~loc " package name missing in %s/bsconfig.json" dir
176
+ in
177
+ if Ext_list. mem_string paths cur_package_name then (
178
+ Bsb_log. error " @{<error>Cyclic dependencies in package stack@}@." ;
179
+ exit 2 );
180
+ let package_stacks = cur_package_name :: paths in
181
+ Bsb_log. info " @{<info>Package stack:@} %a @." pp_packages_rev package_stacks;
182
+ if Hash_string. mem visited cur_package_name then
183
+ Bsb_log. info " @{<info>Visited before@} %s@." cur_package_name
184
+ else
185
+ let explore_deps (deps : string ) pinned_dependencies =
186
+ map
187
+ |? ( deps,
188
+ `Arr
189
+ (fun (new_packages : Ext_json_types.t array ) ->
190
+ Ext_array. iter new_packages (fun js ->
191
+ match js with
192
+ | Str {str = new_package } ->
193
+ let package_dir =
194
+ Bsb_pkg. resolve_bs_package ~cwd: dir
195
+ (Bsb_pkg_types. string_as_package new_package)
196
+ in
197
+ walk_all_deps_aux visited package_stacks
198
+ ~top: (Expect_name new_package) package_dir queue
199
+ ~pinned_dependencies
200
+ | _ -> Bsb_exception. errorf ~loc " %s expect an array" deps))
201
+ )
202
+ |> ignore
173
203
in
174
- if Ext_list. mem_string paths cur_package_name then (
175
- Bsb_log. error " @{<error>Cyclic dependencies in package stack@}@." ;
176
- exit 2 );
177
- let package_stacks = cur_package_name :: paths in
178
- Bsb_log. info " @{<info>Package stack:@} %a @." pp_packages_rev
179
- package_stacks;
180
- if Hash_string. mem visited cur_package_name then
181
- Bsb_log. info " @{<info>Visited before@} %s@." cur_package_name
182
- else
183
- let explore_deps (deps : string ) pinned_dependencies =
184
- map
185
- |? ( deps,
186
- `Arr
187
- (fun (new_packages : Ext_json_types.t array ) ->
188
- Ext_array. iter new_packages (fun js ->
189
- match js with
190
- | Str { str = new_package } ->
191
- let package_dir =
192
- Bsb_pkg. resolve_bs_package ~cwd: dir
193
- (Bsb_pkg_types. string_as_package new_package)
194
- in
195
- walk_all_deps_aux visited package_stacks
196
- ~top: (Expect_name new_package) package_dir queue
197
- ~pinned_dependencies
198
- | _ ->
199
- Bsb_exception. errorf ~loc " %s expect an array" deps))
200
- )
201
- |> ignore
202
- in
203
- let is_pinned = match top with
204
+ let is_pinned =
205
+ match top with
204
206
| Expect_name n when Set_string. mem pinned_dependencies n -> true
205
207
| _ -> false
206
- in
207
- let pinned_dependencies = match is_pinned with
208
+ in
209
+ let pinned_dependencies =
210
+ match is_pinned with
208
211
| true ->
209
- let transitive_pinned_dependencies = extract_pinned_dependencies map
212
+ let transitive_pinned_dependencies =
213
+ extract_pinned_dependencies map
210
214
in
211
215
Set_string. union transitive_pinned_dependencies pinned_dependencies
212
216
| false -> pinned_dependencies
213
- in
214
- explore_deps Bsb_build_schemas. bs_dependencies pinned_dependencies;
215
- (match top with
216
- | Expect_none -> explore_deps Bsb_build_schemas. bs_dev_dependencies pinned_dependencies
217
- | Expect_name _ when is_pinned ->
218
- explore_deps Bsb_build_schemas. bs_dev_dependencies pinned_dependencies
219
- | Expect_name _ -> () );
220
- Queue. add { top; proj_dir = dir; is_pinned } queue;
221
- Hash_string. add visited cur_package_name dir
217
+ in
218
+ explore_deps Bsb_build_schemas. bs_dependencies pinned_dependencies;
219
+ (match top with
220
+ | Expect_none ->
221
+ explore_deps Bsb_build_schemas. bs_dev_dependencies pinned_dependencies
222
+ | Expect_name _ when is_pinned ->
223
+ explore_deps Bsb_build_schemas. bs_dev_dependencies pinned_dependencies
224
+ | Expect_name _ -> () );
225
+ Queue. add {top; proj_dir = dir; is_pinned} queue;
226
+ Hash_string. add visited cur_package_name dir
222
227
| _ -> ()
223
228
224
229
let walk_all_deps dir ~pinned_dependencies : package_context Queue. t =
0 commit comments