@@ -14,7 +14,7 @@ module Spec = struct
1414
1515 let empty =
1616 { loc = Loc. none
17- ; alias = Alias.Name.Set. singleton Alias0. runtest
17+ ; alias = Alias.Name.Set. empty
1818 ; enabled_if = [ Blang. true_ ]
1919 ; locks = Path.Set. empty
2020 ; deps = []
@@ -149,51 +149,97 @@ let rules ~sctx ~expander ~dir tests =
149149 | Error (Source_tree.Dir. Missing_run_t test ) -> Cram_test. name test
150150 in
151151 let init =
152- let alias = Alias.Name. of_string name |> Alias.Name.Set. add Spec. empty.alias in
153- { Spec. empty with alias }
152+ ( None
153+ , let alias = Alias.Name. of_string name |> Alias.Name.Set. add Spec. empty.alias in
154+ { Spec. empty with alias } )
154155 in
155- Memo.List. fold_left
156- stanzas
157- ~init
158- ~f: (fun (acc : Spec.t ) (dir , (stanza : Cram_stanza.t )) ->
159- match
160- match stanza.applies_to with
161- | Whole_subtree -> true
162- | Files_matching_in_this_dir pred ->
163- Predicate_lang.Glob. test pred ~standard: Predicate_lang. true_ name
164- with
165- | false -> Memo. return acc
166- | true ->
167- let + deps, sandbox =
168- match stanza.deps with
169- | None -> Memo. return (acc.deps, acc.sandbox)
170- | Some deps ->
171- let + (deps : unit Action_builder.t ), _, sandbox =
172- let + expander = Super_context. expander sctx ~dir in
173- Dep_conf_eval. named ~expander deps
174- in
175- deps :: acc.deps, Sandbox_config. inter acc.sandbox sandbox
176- and + locks =
177- (* Locks must be relative to the cram stanza directory and not
178- the individual tests directories *)
179- let base = `This (Path. build dir) in
180- Expander. expand_locks ~base expander stanza.locks
181- >> | Path.Set. of_list
182- >> | Path.Set. union acc.locks
183- in
184- let enabled_if = stanza.enabled_if :: acc.enabled_if in
185- let alias =
186- match stanza.alias with
187- | None -> acc.alias
188- | Some a -> Alias.Name.Set. add acc.alias a
189- in
190- let packages =
191- match stanza.package with
192- | None -> acc.packages
193- | Some (p : Package.t ) ->
194- Package.Name.Set. add acc.packages (Package.Id. name p.id)
195- in
196- { acc with enabled_if; locks; deps; alias; packages; sandbox })
156+ let + runtest_alias, acc =
157+ Memo.List. fold_left
158+ stanzas
159+ ~init
160+ ~f: (fun (runtest_alias , (acc : Spec.t )) (dir , (stanza : Cram_stanza.t )) ->
161+ match
162+ match stanza.applies_to with
163+ | Whole_subtree -> true
164+ | Files_matching_in_this_dir pred ->
165+ Predicate_lang.Glob. test pred ~standard: Predicate_lang. true_ name
166+ with
167+ | false -> Memo. return (runtest_alias, acc)
168+ | true ->
169+ let + deps, sandbox =
170+ match stanza.deps with
171+ | None -> Memo. return (acc.deps, acc.sandbox)
172+ | Some deps ->
173+ let + (deps : unit Action_builder.t ), _, sandbox =
174+ let + expander = Super_context. expander sctx ~dir in
175+ Dep_conf_eval. named ~expander deps
176+ in
177+ deps :: acc.deps, Sandbox_config. inter acc.sandbox sandbox
178+ and + locks =
179+ (* Locks must be relative to the cram stanza directory and not
180+ the individual tests directories *)
181+ let base = `This (Path. build dir) in
182+ Expander. expand_locks ~base expander stanza.locks
183+ >> | Path.Set. of_list
184+ >> | Path.Set. union acc.locks
185+ in
186+ let runtest_alias =
187+ match stanza.runtest_alias with
188+ | None -> None
189+ | Some (loc , set ) ->
190+ (match runtest_alias with
191+ | None -> Some (loc, set)
192+ | Some (loc' , _ ) ->
193+ let main_message =
194+ Pp. concat
195+ ~sep: Pp. newline
196+ [ Pp. text
197+ " enabling or disabling the runtest alias for a cram test \
198+ may only be set once."
199+ ; Pp. textf " It's already set for the test %S" name
200+ ]
201+ in
202+ let annots =
203+ let main = User_message. make ~loc: loc' [ main_message ] in
204+ let related =
205+ [ User_message. make ~loc [ Pp. text " Already set here" ] ]
206+ in
207+ User_message.Annots. singleton
208+ Compound_user_error. annot
209+ [ Compound_user_error. make ~main ~related ]
210+ in
211+ User_error. raise
212+ ~annots
213+ ~loc
214+ [ main_message
215+ ; Pp. text " The first definition is at:"
216+ ; Pp. text (Loc. to_file_colon_line loc')
217+ ])
218+ in
219+ let enabled_if = stanza.enabled_if :: acc.enabled_if in
220+ let alias =
221+ match stanza.alias with
222+ | None -> acc.alias
223+ | Some a -> Alias.Name.Set. add acc.alias a
224+ in
225+ let packages =
226+ match stanza.package with
227+ | None -> acc.packages
228+ | Some (p : Package.t ) ->
229+ Package.Name.Set. add acc.packages (Package.Id. name p.id)
230+ in
231+ ( runtest_alias
232+ , { acc with enabled_if; locks; deps; alias; packages; sandbox } ))
233+ in
234+ let alias =
235+ let to_add =
236+ match runtest_alias with
237+ | None | Some (_ , true ) -> Alias.Name.Set. singleton Alias0. runtest
238+ | Some (_ , false ) -> Alias.Name.Set. empty
239+ in
240+ Alias.Name.Set. union to_add acc.alias
241+ in
242+ { acc with alias }
197243 in
198244 with_package_mask spec.packages (fun () -> test_rule ~sctx ~expander ~dir spec test))
199245;;
0 commit comments