-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathbs4j_tmltest.ml
186 lines (177 loc) · 9.99 KB
/
bs4j_tmltest.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
open OUnit2
open OUnitTest
let tml_dir = "yaml-test-suite/test"
let only_tags = []
let exclude_tags = ["anchor"; "alias"; "explicit-key"; "tag"; "complex-key"; "empty-key"]
let skiplist = [
("5U3A.tml", Some "supported block syntax in BS4J")
; ("A2M4.tml", Some "``?'' used for key, unsupported syntax")
; ("9C9N.tml", Some "supported flow syntax in BS4J")
; ("87E4.tml", Some "flow style should be JSON, yaml quotations")
; ("U9NS.tml", Some "``:'' is a special char, cannot be used in raw scalars")
; ("MYW6.tml", Some "raw-string-literals obviate this")
; ("J3BT.tml", Some "raw-string-literal, yaml quotation")
; ("753E.tml", Some "raw-string-literals obviate this")
; ("6H3V.tml", Some "yaml quotations")
; ("Q5MG.tml", Some "<TAB> at margin")
; ("9DXL.tml", Some "multiple docs must all be prefixed by ``---''")
; ("2LFX.tml", Some "directives are unsupported")
; ("BEC7.tml", Some "change filetype to BS4J; filetype matching is strict")
; ("CC74.tml", Some "tag directives are unsupported")
; ("9WXW.tml", Some "(tag) directives are unsupported")
; ("27NA.tml", Some "content on same line as ``---'' is supported in BS4J")
; ("6WLZ.tml", Some "(tag) directives are unsupported")
; ("6LVF.tml", Some "directives are unsupported")
; ("P2AD.tml", Some "neither indentation nor chomping are necessary")
; ("6ZKB.tml", Some "multiple docs must all be prefixed with ``---''")
; ("PUW8.tml", Some "docs cannot be null")
; ("6XDY.tml", Some "docs cannot be null")
; ("RZT7.tml", Some "``:'' is a special char, cannot be used in raw scalars")
; ("RTP8.tml", Some "change filetype to BS4J; filetype matching is strict")
; ("UT92.tml", Some "yaml quotations, also multiline scalars forbidden in flow style")
; ("W4TN.tml", Some "change filetype to BS4J; filetype matching is strict")
; ("F8F9.tml", Some "chomping/stripping is unnecessary")
; ("A984.tml", Some "margin-indent must be identical for multiline yamlscalars")
; ("UDM2.tml", Some "flow scalar with special chars must be quoted")
; ("T26H.tml", Some "whitespace precision is best done with raw-string-literals")
; ("S7BG.tml", Some "flow scalar with special chars must be quoted")
; ("FBC9.tml", Some "special chars in scalars require quotations")
; ("4ZYM.tml", Some "yaml quotations")
; ("LQZ7.tml", Some "yaml quotations")
; ("3MYT.tml", Some "special chars in scalars require quotations")
; ("DWX9.tml", Some "whitespace precision is best done with raw-string-literals")
; ("G992.tml", Some "whitespace precision is best done with raw-string-literals")
; ("4QFQ.tml", Some "whitespace precision is best done with raw-string-literals")
; ("4Q9F.tml", Some "whitespace precision is best done with raw-string-literals")
; ("36F6.tml", Some "margin-indent must be identical for multiline yamlscalars")
; ("M29M.tml", Some "whitespace precision is best done with raw-string-literals")
; ("MJS9.tml", Some "whitespace precision is best done with raw-string-literals")
; ("Q8AD.tml", Some "yaml quotations")
; ("H2RW.tml", Some "whitespace precision is best done with raw-string-literals")
; ("T5N4.tml", Some "whitespace precision is best done with raw-string-literals")
; ("HS5T.tml", Some "whitespace precision is best done with raw-string-literals")
; ("5T43.tml", Some "yaml quotations")
; ("B3HG.tml", Some "whitespace precision is best done with raw-string-literals")
; ("AB8U.tml", Some "whitespace precision is best done with raw-string-literals")
; ("DBG4.tml", Some "special chars in scalars require quotations")
; ("93WF.tml", Some "whitespace precision is best done with raw-string-literals")
; ("EX5H.tml", Some "whitespace precision is best done with raw-string-literals")
; ("DK3J.tml", Some "special chars in scalars require quotations")
; ("7T8X.tml", Some "whitespace precision is best done with raw-string-literals")
; ("6FWR.tml", Some "whitespace precision is best done with raw-string-literals")
; ("FP8R.tml", Some "whitespace precision is best done with raw-string-literals")
; ("2EBW.tml", Some "special chars in scalars require quotations")
; ("82AN.tml", Some "special chars in scalars require quotations")
; ("8CWC.tml", Some "special chars in scalars require quotations")
; ("96L6.tml", Some "whitespace precision is best done with raw-string-literals")
; ("M9B4.tml", Some "whitespace precision is best done with raw-string-literals")
; ("R4YG.tml", Some "whitespace precision is best done with raw-string-literals")
; ("8G76.tml", Some "empty documents aren't supported")
; ("4V8U.tml", Some "special chars in scalars require quotations")
; ("K527.tml", Some "whitespace precision is best done with raw-string-literals")
; ("5BVJ.tml", Some "whitespace precision is best done with raw-string-literals")
; ("6VJK.tml", Some "whitespace precision is best done with raw-string-literals")
; ("TS54.tml", Some "whitespace precision is best done with raw-string-literals")
; ("XV9V.tml", Some "yaml quotations")
; ("6JQW.tml", Some "whitespace precision is best done with raw-string-literals")
; ("EXG3.tml", Some "special chars in scalars require quotations")
; ("9YRD.tml", Some "whitespace precision is best done with raw-string-literals")
; ("A6F9.tml", Some "special chars in scalars require quotations")
; ("G4RS.tml", Some "yaml quotations")
; ("NB6Z.tml", Some "special chars in scalars require quotations")
; ("QF4Y.tml", Some "flow style should be JSON, yaml quotations")
; ("8UDB.tml", Some "yaml quotations, also multiline scalars forbidden in flow style")
; ("C2DT.tml", Some "empty value forbidden")
; ("9BXH.tml", Some "empty value forbidden")
; ("G5U8.tml", Some "special chars in scalars require quotations")
; ("9MMW.tml", Some "complex key unsupported")
; ("L9U5.tml", Some "flow style should be JSON, trailing comma")
; ("NJ66.tml", Some "yaml quotations, also multiline scalars forbidden in flow style")
; ("5C5M.tml", Some "trailing comma in flow style")
; ("6HB6.tml", Some "whitespace precision is best done with raw-string-literals")
; ("7ZZ5.tml", Some "subsidiary values MUST be indented")
; ("4ABK.tml", Some "special chars in scalars require quotations, empty values, trailing comma")
; ("8KB6.tml", Some "multi line scalars in flow keys require quotations, empty values")
; ("F6MC.tml", Some "whitespace precision is best done with raw-string-literals")
; ("AZ63.tml", Some "subsidiary values MUST be indented")
; ("RLU9.tml", Some "subsidiary values MUST be indented")
; ("D83L.tml", Some "explicit indent is superfluous")
; ("AVM7.tml", Some "empty documents aren't supported")
; ("HWV9.tml", Some "empty documents aren't supported")
; ("QT73.tml", Some "empty documents aren't supported")
; ("S4T7.tml", Some "doc end-delimiter can only come after start-delimiter")
; ("K858.tml", Some "empty scalar values are unsupported")
; ("HMK4.tml", Some "whitespace precision is best done with raw-string-literals")
; ("M7A3.tml", Some "doc end-delimiter can only come after start-delimiter")
; ("W42U.tml", Some "empty value")
; ("AZW3.tml", Some "special chars in scalars require quotations, empty values")
; ("7Z25.tml", Some "trailing text after document")
; ("98YD.tml", Some "empty document with comments")
; ("QB6E.tml", Some "multiline quoted-strings don't need to obey indentation rules: continuation lines can have arbitray indent ")
; ("RXY3.tml", Some "multiline quoted-strings don't need to obey indentation rules: continuation lines can have arbitray indent ")
; ("5TRB.tml", Some "multiline quoted-strings don't need to obey indentation rules: continuation lines can have arbitrary indent")
; ("SU5Z.tml", Some "comments are allowed anywhere")
; ("BF9H.tml", Some "comments are allowed anywhere")
; ("X4QW.tml", Some "comments are allowed anywhere")
; ("W9L4.tml", Some "indentation in empty lines is superfluous outside of quotes")
; ("EB22.tml", Some "with multiple documents, only headers are mandatory")
; ("9JBA.tml", Some "comments are allowed anywhere")
; ("9KBC.tml", Some "value can start on same line as header")
; ("ZL4Z.tml", Some "mappings, arrays can nest in arbitrary order")
; ("CVW2.tml", Some "comments are allowed anywhere")
; ("ZCZ6.tml", Some "mappings, arrays can nest in arbitrary order")
; ("5LLU.tml", Some "indentation in empty lines is superfluous outside of quotes")
; ("D49Q.tml", Some "multiline quoted-strings are allowed anywhere quoted strings are")
; ("7LBH.tml", Some "multiline quoted-strings are allowed anywhere quoted strings are")
; ("BS4K.tml", Some "comments are allowed anywhere")
]
let select_tests ?(exclude_tags=[]) ?(only_tags=[]) l =
let open Tml in
let l =
if only_tags = [] then l else
l |> List.filter (fun t ->
let tags = Tml.tags t in
tags |> List.exists (fun s -> List.mem s only_tags)) in
if exclude_tags = [] then l else
l |> List.filter (fun t ->
let tags = Tml.tags t in
tags |> List.for_all (fun s -> not(List.mem s exclude_tags)))
let make_test t =
let open Tml in
let base = Fpath.(t.filename |> v |> basename) in
let tagsl = Tml.tags t in
match List.assoc base skiplist with
msg ->
let msg = match msg with None -> t.name | Some s -> s in
let name = Fmt.(str "%s (%s) [%a]" t.name base (list ~sep:(const string " ") string) tagsl) in
base >::: [
name >:: (fun ctxt ->
Tml.warning (Fmt.str "%s: Not handled: %s" t.filename msg)
)
]
| exception Not_found ->
base >::: [
let name = Fmt.(str "%s (%s) [%a]" t.name base (list ~sep:(const string " ") string) tagsl) in
name >:: (fun ctxt ->
BS4J.exec t
)
]
let parse1 n =
let file =
if n |> Fpath.v |> Bos.OS.File.exists |> Rresult.R.get_ok then n
else Fpath.(to_string (append (v tml_dir) (v n))) in
Tml.(BS4J.parse_yaml (from_file file))
let exec1 n =
let file =
if n |> Fpath.v |> Bos.OS.File.exists |> Rresult.R.get_ok then n
else Fpath.(to_string (append (v tml_dir) (v n))) in
Tml.(BS4J.exec (from_file file))
let tests = "BS4J testsuite" >::: (
let fl = Tml.files ~override_dir:"bs4j-overrides" tml_dir in
let tests = List.map Tml.from_file fl in
let tests = select_tests ~only_tags ~exclude_tags tests in
List.map make_test tests
)
if not !Sys.interactive then
run_test_tt_main tests
;;