test.ml 8.46 KB
Newer Older
1
2
3
4
5
(* This script produces the file [dune.auto], which describes the tests we
   would like dune to execute. *)

(* Note: the contents of the .conflicts and .automaton files are not tested. *)

6
7
(* Note: no test in bad/ should have the same name as a test in good/. *)

8
9
(* -------------------------------------------------------------------------- *)

10
11
12
13
14
15
open Sys
open Array
open List
open Printf
open Auxiliary

16
17
18
19
20
21
let up =
  Filename.parent_dir_name
let (/) =
  Filename.concat
let (//) directory filenames =
  map (fun filename -> directory/filename) filenames
22
23
24
25
26

(* -------------------------------------------------------------------------- *)

(* Settings. *)

27
28
let extra : string list ref =
  ref []
29
30
31
32
33

let usage =
  sprintf "Usage: %s\n" argv.(0)

let spec = Arg.align [
34
  "--extra-flags",     Arg.String (fun flag -> extra := flag :: !extra),
35
36
37
38
39
40
                       "<string> specify extra flags for Menhir";
]

let () =
  Arg.parse spec (fun _ -> ()) usage

41
let extra : string list =
42
  rev !extra
43
44
45
46
47
48

(* -------------------------------------------------------------------------- *)

(* Paths. *)

let good =
49
  up / "good"
50
51

let bad =
52
  up / "bad"
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87

(* -------------------------------------------------------------------------- *)

(* Test files and groups of test files. *)

let id basenames =
  (* A name for a nonempty group of test files. *)
  hd basenames

let mly basename =
  basename ^ ".mly"

let mlys =
  map mly

(* -------------------------------------------------------------------------- *)

(* Test inputs and outputs. *)

(* A test input is a list of basenames, without the .mly extension.
   These files must be passed together to menhir. *)

type input =
  | NegativeTest of filename list
  | PositiveTest of filename list

type inputs = input list

(* -------------------------------------------------------------------------- *)

(* An S-expression printer. *)

type sexp =
  | A of string
  | L of sexp list
88
  | Lnewline of sexp list
89

90
91
92
93
let atom sexp =
  A sexp

let atoms =
94
  map atom
95

96
let rec print ppf = function
97
98
99
  | A s ->
      Format.pp_print_string ppf s
  | L l ->
100
      Format.fprintf ppf "@[<2>(%a)@]"
101
        (Format.pp_print_list ~pp_sep:Format.pp_print_space print) l
102
103
  | Lnewline l ->
      Format.fprintf ppf "@[<v 2>(%a)@]"
104
        (Format.pp_print_list ~pp_sep:Format.pp_print_space print) l
105

106
107
let print sexp =
  Format.printf "@[<v>%a@,@]" print sexp;
108
  Format.print_newline()
109
110
111

(* -------------------------------------------------------------------------- *)

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
(* Constructing a standard [make]-like rule. *)

let rule (target : string) (deps : string list) (action : sexp) =
  L[A"rule";
    L[A"target"; A target];
    L(A"deps" :: atoms deps);
    L[A"action"; action]
  ]

(* Constructing a phony rule, that is, a rule whose target is an alias. *)

let phony (alias : string) (action : sexp) =
  L[A"rule";
    L[A"alias"; A alias];
    L[A"action"; action]
  ]

(* Constructing a diff action. *)

let diff (expected : string) (actual : string) =
  L[A"diff"; A expected; A actual]

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
(* Redirecting the output channels of an action towards its target. *)

let targeted action =
  L[A"with-outputs-to"; A"%{target}"; action]

(* Changing the working directory of an action. *)

let chdir directory action =
  L[A"chdir"; A directory; action]

(* Expressing the fact that an action is expected to fail. *)

let expecting_failure action =
  L[A"with-accepted-exit-codes"; L[A"not"; A"0"]; action]

149
150
151
let possibly_expecting_failure positive action =
  if positive then action else expecting_failure action

152
153
154
155
156
157
158
159
160
161
162
163
164
(* -------------------------------------------------------------------------- *)

(* Calling conventions for Menhir. *)

(* A --base option is needed for groups of several files. *)

let base basenames =
  if length basenames > 1 then
    let id = id basenames in
    [A"--base"; A id]
  else
    []

165
166
167
168
169
170
171
172
173
174
(* The extra flags passed to Menhir are those found in a local .flags file,
   if there is one, plus those passed to us via --extra-flags. *)

let extra source id =
  let flags_file = source / id ^ ".flags" in
  if file_exists flags_file then
    A(sprintf "%%{read-lines:%s}" flags_file) :: atoms extra
  else
    atoms extra

175
176
177
178
179
180
181
(* The Menhir command. *)

(* This command is meant to be used inside a rule. *)

let menhir base flags =
  L(A"run" :: A"menhir" :: base @ flags @ [A"%{deps}"])

182
183
(* Constructing (and printing) a pair of rules to run Menhir and compare its
   output against an expected-output file.
184

185
186
187
188
189
190
191
   [id]         name of the phony target
   [positive]   positive or negative test?
   [source]     directory where the .mly files reside
   [basenames]  base names of the .mly files
   [output]     name of the output file
   [expected]   name of the expected-output file
   [flags]      flags for Menhir
192

193
 *)
194

195
196
197
let run_and_compare id positive source basenames output expected flags =
  (* Run Menhir. *)
  print (rule
198
199
200
    output
    (source // mlys basenames)
    (targeted (chdir source (
201
202
203
      possibly_expecting_failure positive (
        menhir (base basenames) flags
  )))));
204
  (* Check that the output coincides with what was expected. *)
205
206
207
  print (phony id (
    diff (source/expected) output
  ))
208
209
210

(* -------------------------------------------------------------------------- *)

211
(* Running a negative test. *)
212

213
(* This test takes place in the directory [bad]. *)
214

215
(* The file %.flags   (if it exists) stores flags for Menhir.
216
217
   The file %.out     stores the output of menhir.
   The file %.exp     stores its expected output. *)
218

219
220
221
let process_negative_test basenames : unit =
  (* Run menhir. *)
  let source = bad in
222
  let id = id basenames in
223
224
  let output = id ^ ".out" in
  let expected = id ^ ".exp" in
225
  let flags = extra source id in
226
  run_and_compare id false source basenames output expected flags
227

228
(* -------------------------------------------------------------------------- *)
229

230
(* Running a positive test. *)
231

232
(* This test takes place in the directory [good]. *)
233

234
235
236
237
(* The file %.flags   (if it exists) stores flags for Menhir.
   The file %.opp.out stores the output of menhir --only-preprocess.
   The file %.opp.exp stores its expected output.
   The file %.out     stores the output of menhir.
238
239
240
241
242
243
   The file %.exp     stores its expected output.
 *)

(* The file %.out.timings stores performance data, which of course is
   not perfectly reproducible, therefore is not compared against a
   reference. *)
244

245
246
247
248
249
250
251
let process_positive_test basenames : unit =
  let source = good in
  let id = id basenames in
  let flags = extra source id in
  (* Run menhir --only-preprocess. *)
  let output = id ^ ".opp.out" in
  let expected = id ^ ".opp.exp" in
252
253
254
  run_and_compare id true source basenames output expected (atoms [
    "--only-preprocess";
  ] @ flags);
255
  (* Run menhir. *)
256
257
  let output = id ^ ".out" in
  let expected = id ^ ".exp" in
258
259
260
261
262
263
264
265
  let timings = id ^ ".out.timings" in
  run_and_compare id true source basenames output expected (atoms [
    "--explain";
    "-lg"; "2";
    "-la"; "2";
    "-lc"; "2";
    "--timings-to"; timings;
  ] @ flags)
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288

(* -------------------------------------------------------------------------- *)

(* Running a test. *)

let process input =
  match input with
  | NegativeTest basenames ->
      process_negative_test basenames
  | PositiveTest basenames ->
      process_positive_test basenames

let id input =
  match input with
  | NegativeTest basenames
  | PositiveTest basenames ->
      id basenames

(* -------------------------------------------------------------------------- *)

(* [run] runs a bunch of tests in parallel. *)

let run (inputs : inputs) =
289
290
291
292
  iter process inputs;
  let ids = map id inputs in
  let ids = sort_uniq compare ids in
  print
293
294
    (L[A"alias";
       L[A"name"; A"test"];
295
       Lnewline(A"deps" :: map (fun id -> L[A"alias"; A id]) ids)])
296
297
298
299
300
301
302
303
304
305
306
307
308

(* -------------------------------------------------------------------------- *)

(* Main. *)

(* Menhir can accept several .mly files at once. By convention, if several
   files have the same name up to a numeric suffix, then they belong in a
   single group and should be fed together to Menhir. *)

let inputs directory : filename list list =
     readdir directory
  |> to_list
  |> filter (has_suffix ".mly")
309
  |> map Filename.chop_extension
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
  |> sort compare
  |> groups equal_up_to_numeric_suffix

let positive : inputs =
     inputs good
  |> map (fun basenames -> PositiveTest basenames)

let negative : inputs =
     inputs bad
  |> map (fun basenames -> NegativeTest basenames)

let inputs =
  positive @ negative

let () =
  print_endline
    ";; This file has been auto-generated. Please do not edit it.\n\
     ;; Instead, edit [test.ml] and run [make depend].\n"

let () =
  run inputs