OCaml parser combinator that compiles to direct recursive descent
parser combinator ppx that compiles to recursive descent
author
vm.fail
date
(Jan 16, 2026, 9:38 PM UTC)
commit
067aeee8
067aeee83bfc6345fd94b7c0122244b3befe9dd1
vm.fail
date
(Jan 16, 2026, 9:38 PM UTC)
commit
067aeee8
067aeee83bfc6345fd94b7c0122244b3befe9dd1
+1112
+35
README.md
+35
README.md
···
1
+
# ppx_combin
2
+
3
+
Stupid PPX library because others are stupidly hacked together. This is a parser combinator syntax that compiles to direct recursive descent.It does first-set analysis and generates tight match/loop code.
4
+
5
+
## usage
6
+
7
+
```ocaml
8
+
open Combin
9
+
10
+
let is_digit c = c >= '0' && c <= '9'
11
+
12
+
let digit = [%parser satisfy is_digit <?> "digit"]
13
+
14
+
let number = [%parser
15
+
some (satisfy is_digit) >>= fun ds ->
16
+
pure (int_of_string (String.concat "" (List.map (String.make 1) ds)))
17
+
]
18
+
19
+
let expr = [%parser
20
+
chainl1
21
+
(satisfy is_digit >>= fun c -> pure (Char.code c - Char.code '0'))
22
+
(token '+' *> pure ( + ))
23
+
]
24
+
25
+
let () =
26
+
match parse_string expr "1+2+3" with
27
+
| Ok (n, _) -> Printf.printf "result: %d\n" n
28
+
| Error e -> print_endline (format_error e)
29
+
```
30
+
31
+
## install
32
+
33
+
```
34
+
opam pin add ppx_combin .
35
+
```
+15
dune-project
+15
dune-project
···
1
+
(lang dune 3.0)
2
+
(name ppx_combin)
3
+
(generate_opam_files true)
4
+
5
+
(license ISC)
6
+
(authors "oni")
7
+
(maintainers "oni")
8
+
(source (github oni/ppx_combin))
9
+
10
+
(package
11
+
(name ppx_combin)
12
+
(synopsis "Parser combinator ppx compiling to recursive descent")
13
+
(depends
14
+
(ocaml (>= 4.14))
15
+
(ppxlib (>= 0.28.0))))
+55
lib/combin.ml
+55
lib/combin.ml
···
1
+
module type INPUT = sig
2
+
type t
3
+
type token
4
+
val peek : t -> token option
5
+
val advance : t -> t
6
+
val position : t -> int
7
+
val show_token : token -> string
8
+
end
9
+
10
+
type error = {
11
+
pos : int;
12
+
expected : string list;
13
+
}
14
+
15
+
let merge_errors e1 e2 =
16
+
if e1.pos > e2.pos then e1
17
+
else if e2.pos > e1.pos then e2
18
+
else { pos = e1.pos; expected = e1.expected @ e2.expected }
19
+
20
+
let pure x _input = Ok (x, _input)
21
+
22
+
let fail msg _input = Error { pos = 0; expected = [msg] }
23
+
24
+
module Char_input : sig
25
+
include INPUT with type token = char
26
+
val of_string : string -> t
27
+
end = struct
28
+
type token = char
29
+
type t = { data : string; pos : int }
30
+
31
+
let of_string s = { data = s; pos = 0 }
32
+
33
+
let peek { data; pos } =
34
+
if pos >= String.length data then None
35
+
else Some (String.get data pos)
36
+
37
+
let advance t = { t with pos = t.pos + 1 }
38
+
let position t = t.pos
39
+
let show_token c = Printf.sprintf "'%c'" c
40
+
end
41
+
42
+
let parse_string parser s =
43
+
let input = Char_input.of_string s in
44
+
parser (module Char_input : INPUT with type t = Char_input.t and type token = char) input
45
+
46
+
let format_error ?(input = "") e =
47
+
let context =
48
+
if String.length input > 0 && e.pos < String.length input then
49
+
let start = max 0 (e.pos - 10) in
50
+
let len = min 20 (String.length input - start) in
51
+
Printf.sprintf " near '%s'" (String.sub input start len)
52
+
else ""
53
+
in
54
+
Printf.sprintf "parse error at position %d%s: expected %s"
55
+
e.pos context (String.concat " or " e.expected)
+161
src/check.ml
+161
src/check.ml
···
1
+
open Ir
2
+
3
+
type error =
4
+
| Left_recursion of { loc : loc; name : string; path : string list }
5
+
| Ambiguous_alt of { loc : loc }
6
+
7
+
let left_recursive_path env names expr =
8
+
let rec nullable = function
9
+
| Pure _ -> true
10
+
| Fail _ -> false
11
+
| Satisfy _ -> false
12
+
| Any _ -> false
13
+
| Eof _ -> true
14
+
| Token _ -> false
15
+
| Tokens _ -> false
16
+
| OneOf _ -> false
17
+
| NoneOf _ -> false
18
+
| Bind { p; _ } -> nullable p
19
+
| Map { p; _ } -> nullable p
20
+
| Apply { pf; px; _ } -> nullable pf && nullable px
21
+
| SeqLeft { p; q; _ } -> nullable p && nullable q
22
+
| SeqRight { p; q; _ } -> nullable p && nullable q
23
+
| Alt { p; q; _ } -> nullable p || nullable q
24
+
| Attempt { p; _ } -> nullable p
25
+
| Cut _ -> true
26
+
| Lookahead _ -> true
27
+
| NotFollowedBy _ -> true
28
+
| Many _ -> true
29
+
| Some_ { p; _ } -> nullable p
30
+
| Optional _ -> true
31
+
| Option _ -> true
32
+
| SepBy _ -> true
33
+
| SepBy1 { p; sep; _ } -> nullable p && nullable sep
34
+
| EndBy _ -> true
35
+
| EndBy1 { p; sep; _ } -> nullable p && nullable sep
36
+
| ManyTill _ -> true
37
+
| Count _ -> false
38
+
| Between { open_; close; p; _ } -> nullable open_ && nullable p && nullable close
39
+
| ChainL _ -> true
40
+
| ChainL1 { p; _ } -> nullable p
41
+
| ChainR _ -> true
42
+
| ChainR1 { p; _ } -> nullable p
43
+
| Choice { ps; _ } -> List.exists nullable ps
44
+
| Label { p; _ } -> nullable p
45
+
| Fix _ -> false
46
+
| Var { name; _ } ->
47
+
(match List.assoc_opt name env with
48
+
| Some e -> nullable e
49
+
| None -> false)
50
+
in
51
+
let rec check path = function
52
+
| Var { name; _ } when List.mem name names ->
53
+
Some (List.rev (name :: path))
54
+
| Var { name; _ } ->
55
+
(match List.assoc_opt name env with
56
+
| Some e -> check (name :: path) e
57
+
| None -> None)
58
+
| Bind { p; _ } -> check path p
59
+
| Map { p; _ } -> check path p
60
+
| Apply { pf; px; _ } ->
61
+
(match check path pf with
62
+
| Some _ as r -> r
63
+
| None -> if nullable pf then check path px else None)
64
+
| SeqLeft { p; q; _ } ->
65
+
(match check path p with
66
+
| Some _ as r -> r
67
+
| None -> if nullable p then check path q else None)
68
+
| SeqRight { p; q; _ } ->
69
+
(match check path p with
70
+
| Some _ as r -> r
71
+
| None -> if nullable p then check path q else None)
72
+
| Alt { p; q; _ } ->
73
+
(match check path p with
74
+
| Some _ as r -> r
75
+
| None -> check path q)
76
+
| Attempt { p; _ } -> check path p
77
+
| Lookahead { p; _ } -> check path p
78
+
| NotFollowedBy { p; _ } -> check path p
79
+
| Label { p; _ } -> check path p
80
+
| Many { p; _ } -> check path p
81
+
| Some_ { p; _ } -> check path p
82
+
| Optional { p; _ } -> check path p
83
+
| Option { p; _ } -> check path p
84
+
| SepBy { p; _ } -> check path p
85
+
| SepBy1 { p; _ } -> check path p
86
+
| EndBy { p; _ } -> check path p
87
+
| EndBy1 { p; _ } -> check path p
88
+
| ManyTill { p; _ } -> check path p
89
+
| Count { p; _ } -> check path p
90
+
| Between { open_; _ } -> check path open_
91
+
| ChainL { p; _ } -> check path p
92
+
| ChainL1 { p; _ } -> check path p
93
+
| ChainR { p; _ } -> check path p
94
+
| ChainR1 { p; _ } -> check path p
95
+
| Choice { ps; _ } -> List.find_map (check path) ps
96
+
| Fix _ -> None
97
+
| Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
98
+
| OneOf _ | NoneOf _ | Cut _ -> None
99
+
in
100
+
check [] expr
101
+
102
+
let check_left_recursion env names expr =
103
+
match left_recursive_path env names expr with
104
+
| Some path -> Some (Left_recursion { loc = loc_of_expr expr; name = List.hd names; path })
105
+
| None -> None
106
+
107
+
let is_wrapped_in_attempt = function
108
+
| Attempt _ -> true
109
+
| _ -> false
110
+
111
+
let rec check_expr env = function
112
+
| Alt { loc; p; q } ->
113
+
let p_first = First_set.compute env p in
114
+
let q_first = First_set.compute env q in
115
+
let errs =
116
+
if is_wrapped_in_attempt p || is_wrapped_in_attempt q then
117
+
[]
118
+
else if not (First_set.definitely_disjoint p_first q_first) then
119
+
[Ambiguous_alt { loc }]
120
+
else
121
+
[]
122
+
in
123
+
errs @ check_expr env p @ check_expr env q
124
+
| Bind { p; _ } -> check_expr env p
125
+
| Map { p; _ } -> check_expr env p
126
+
| Apply { pf; px; _ } -> check_expr env pf @ check_expr env px
127
+
| SeqLeft { p; q; _ } -> check_expr env p @ check_expr env q
128
+
| SeqRight { p; q; _ } -> check_expr env p @ check_expr env q
129
+
| Attempt { p; _ } -> check_expr env p
130
+
| Lookahead { p; _ } -> check_expr env p
131
+
| NotFollowedBy { p; _ } -> check_expr env p
132
+
| Many { p; _ } -> check_expr env p
133
+
| Some_ { p; _ } -> check_expr env p
134
+
| Optional { p; _ } -> check_expr env p
135
+
| Option { p; _ } -> check_expr env p
136
+
| SepBy { p; sep; _ } -> check_expr env p @ check_expr env sep
137
+
| SepBy1 { p; sep; _ } -> check_expr env p @ check_expr env sep
138
+
| EndBy { p; sep; _ } -> check_expr env p @ check_expr env sep
139
+
| EndBy1 { p; sep; _ } -> check_expr env p @ check_expr env sep
140
+
| ManyTill { p; end_; _ } -> check_expr env p @ check_expr env end_
141
+
| Count { p; _ } -> check_expr env p
142
+
| Between { open_; close; p; _ } -> check_expr env open_ @ check_expr env close @ check_expr env p
143
+
| ChainL { p; op; _ } -> check_expr env p @ check_expr env op
144
+
| ChainL1 { p; op; _ } -> check_expr env p @ check_expr env op
145
+
| ChainR { p; op; _ } -> check_expr env p @ check_expr env op
146
+
| ChainR1 { p; op; _ } -> check_expr env p @ check_expr env op
147
+
| Choice { ps; _ } -> List.concat_map (check_expr env) ps
148
+
| Label { p; _ } -> check_expr env p
149
+
| Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
150
+
| OneOf _ | NoneOf _ | Cut _ | Fix _ | Var _ -> []
151
+
152
+
let error_loc = function
153
+
| Left_recursion { loc; _ } -> loc
154
+
| Ambiguous_alt { loc } -> loc
155
+
156
+
let format_error = function
157
+
| Left_recursion { name; path; _ } ->
158
+
Printf.sprintf "left recursion detected: %s via %s"
159
+
name (String.concat " -> " path)
160
+
| Ambiguous_alt _ ->
161
+
"ambiguous alternation: branches may have overlapping first sets, wrap one in 'attempt'"
+427
src/codegen.ml
+427
src/codegen.ml
···
1
+
open Ppxlib
2
+
open Ast_builder.Default
3
+
open Ir
4
+
5
+
let fresh =
6
+
let counter = ref 0 in
7
+
fun prefix ->
8
+
incr counter;
9
+
Printf.sprintf "%s_%d" prefix !counter
10
+
11
+
let error_expr ~loc expected =
12
+
[%expr Error { Combin.pos = I.position input; expected = [%e expected] }]
13
+
14
+
let expected_list ~loc strs =
15
+
elist ~loc (List.map (estring ~loc) strs)
16
+
17
+
let ok_expr ~loc value input_e =
18
+
[%expr Ok ([%e value], [%e input_e])]
19
+
20
+
let merge_errors_expr ~loc e1 e2 =
21
+
[%expr Combin.merge_errors [%e e1] [%e e2]]
22
+
23
+
let pvar_s ~loc s = ppat_var ~loc { txt = s; loc }
24
+
let evar_s ~loc s = evar ~loc s
25
+
26
+
let mk_let_rec ~loc name params body rest =
27
+
let param_pats = List.map (pvar_s ~loc) params in
28
+
let func = List.fold_right (fun p e -> pexp_fun ~loc Nolabel None p e) param_pats body in
29
+
let vb = value_binding ~loc ~pat:(pvar_s ~loc name) ~expr:func in
30
+
pexp_let ~loc Recursive [vb] rest
31
+
32
+
let rec compile ~loc env expr =
33
+
match expr with
34
+
| Pure { value; _ } ->
35
+
[%expr Ok ([%e value], input)]
36
+
37
+
| Fail { msg; _ } ->
38
+
error_expr ~loc (elist ~loc [estring ~loc msg])
39
+
40
+
| Satisfy { pred; label; loc } ->
41
+
let expected = match label with
42
+
| Some l -> elist ~loc [estring ~loc l]
43
+
| None -> [%expr ["<satisfy>"]]
44
+
in
45
+
[%expr
46
+
match I.peek input with
47
+
| Some tok when [%e pred] tok -> Ok (tok, I.advance input)
48
+
| _ -> [%e error_expr ~loc expected]]
49
+
50
+
| Any { loc } ->
51
+
[%expr
52
+
match I.peek input with
53
+
| Some tok -> Ok (tok, I.advance input)
54
+
| None -> [%e error_expr ~loc (elist ~loc [estring ~loc "<any>"])]]
55
+
56
+
| Eof { loc } ->
57
+
[%expr
58
+
match I.peek input with
59
+
| None -> Ok ((), input)
60
+
| Some _ -> [%e error_expr ~loc (elist ~loc [estring ~loc "<eof>"])]]
61
+
62
+
| Token { tok; loc } ->
63
+
[%expr
64
+
match I.peek input with
65
+
| Some t when t = [%e tok] -> Ok (t, I.advance input)
66
+
| _ -> [%e error_expr ~loc [%expr [I.show_token [%e tok]]]]]
67
+
68
+
| Tokens { toks; loc } ->
69
+
[%expr
70
+
let rec loop toks_list inp =
71
+
match toks_list with
72
+
| [] -> Ok ([%e toks], inp)
73
+
| t :: rest ->
74
+
match I.peek inp with
75
+
| Some t' when t = t' -> loop rest (I.advance inp)
76
+
| _ -> [%e error_expr ~loc [%expr [String.concat "" (List.map I.show_token [%e toks])]]]
77
+
in
78
+
loop [%e toks] input]
79
+
80
+
| OneOf { toks; loc } ->
81
+
[%expr
82
+
match I.peek input with
83
+
| Some t when List.mem t [%e toks] -> Ok (t, I.advance input)
84
+
| _ -> [%e error_expr ~loc [%expr List.map I.show_token [%e toks]]]]
85
+
86
+
| NoneOf { toks; loc } ->
87
+
[%expr
88
+
match I.peek input with
89
+
| Some t when not (List.mem t [%e toks]) -> Ok (t, I.advance input)
90
+
| _ -> [%e error_expr ~loc (elist ~loc [estring ~loc "<none_of>"])]]
91
+
92
+
| Bind { p; f; loc } ->
93
+
let p_code = compile ~loc env p in
94
+
[%expr
95
+
match [%e p_code] with
96
+
| Ok (x, inp) ->
97
+
let input = inp in
98
+
[%e f] x input
99
+
| Error e -> Error e]
100
+
101
+
| Map { f; p; loc } ->
102
+
let p_code = compile ~loc env p in
103
+
[%expr
104
+
match [%e p_code] with
105
+
| Ok (x, inp) -> Ok ([%e f] x, inp)
106
+
| Error e -> Error e]
107
+
108
+
| Apply { pf; px; loc } ->
109
+
let pf_code = compile ~loc env pf in
110
+
let px_code = compile ~loc env px in
111
+
[%expr
112
+
match [%e pf_code] with
113
+
| Ok (f, inp1) ->
114
+
let input = inp1 in
115
+
(match [%e px_code] with
116
+
| Ok (x, inp2) -> Ok (f x, inp2)
117
+
| Error e -> Error e)
118
+
| Error e -> Error e]
119
+
120
+
| SeqLeft { p; q; loc } ->
121
+
let p_code = compile ~loc env p in
122
+
let q_code = compile ~loc env q in
123
+
[%expr
124
+
match [%e p_code] with
125
+
| Ok (x, inp1) ->
126
+
let input = inp1 in
127
+
(match [%e q_code] with
128
+
| Ok (_, inp2) -> Ok (x, inp2)
129
+
| Error e -> Error e)
130
+
| Error e -> Error e]
131
+
132
+
| SeqRight { p; q; loc } ->
133
+
let p_code = compile ~loc env p in
134
+
let q_code = compile ~loc env q in
135
+
[%expr
136
+
match [%e p_code] with
137
+
| Ok (_, inp1) ->
138
+
let input = inp1 in
139
+
[%e q_code]
140
+
| Error e -> Error e]
141
+
142
+
| Alt { p; q; loc } ->
143
+
let p_first = First_set.compute [] p in
144
+
let q_first = First_set.compute [] q in
145
+
if First_set.definitely_disjoint p_first q_first &&
146
+
First_set.all_static p_first && First_set.all_static q_first then
147
+
compile_committed_alt ~loc env p q p_first q_first
148
+
else
149
+
compile_backtrack_alt ~loc env p q
150
+
151
+
| Attempt { p; loc } ->
152
+
let p_code = compile ~loc env p in
153
+
[%expr
154
+
let saved = input in
155
+
match [%e p_code] with
156
+
| Ok _ as r -> r
157
+
| Error e -> Error { e with Combin.pos = I.position saved }]
158
+
159
+
| Cut { loc } ->
160
+
[%expr Ok ((), input)]
161
+
162
+
| Lookahead { p; loc } ->
163
+
let p_code = compile ~loc env p in
164
+
[%expr
165
+
let saved = input in
166
+
match [%e p_code] with
167
+
| Ok (v, _) -> Ok (v, saved)
168
+
| Error e -> Error e]
169
+
170
+
| NotFollowedBy { p; loc } ->
171
+
let p_code = compile ~loc env p in
172
+
[%expr
173
+
let saved = input in
174
+
match [%e p_code] with
175
+
| Ok _ -> [%e error_expr ~loc (elist ~loc [estring ~loc "<not_followed_by>"])]
176
+
| Error _ -> Ok ((), saved)]
177
+
178
+
| Many { p; loc } ->
179
+
let p_code = compile ~loc env p in
180
+
[%expr
181
+
let rec loop acc input =
182
+
match [%e p_code] with
183
+
| Ok (x, inp) -> loop (x :: acc) inp
184
+
| Error _ -> Ok (List.rev acc, input)
185
+
in
186
+
loop [] input]
187
+
188
+
| Some_ { p; loc } ->
189
+
let p_code = compile ~loc env p in
190
+
[%expr
191
+
match [%e p_code] with
192
+
| Ok (x, inp) ->
193
+
let rec loop acc input =
194
+
match [%e p_code] with
195
+
| Ok (y, inp2) -> loop (y :: acc) inp2
196
+
| Error _ -> Ok (List.rev acc, input)
197
+
in
198
+
loop [x] inp
199
+
| Error e -> Error e]
200
+
201
+
| Optional { p; loc } ->
202
+
let p_code = compile ~loc env p in
203
+
[%expr
204
+
match [%e p_code] with
205
+
| Ok (x, inp) -> Ok (Some x, inp)
206
+
| Error _ -> Ok (None, input)]
207
+
208
+
| Option { default; p; loc } ->
209
+
let p_code = compile ~loc env p in
210
+
[%expr
211
+
match [%e p_code] with
212
+
| Ok (x, inp) -> Ok (x, inp)
213
+
| Error _ -> Ok ([%e default], input)]
214
+
215
+
| SepBy { p; sep; loc } ->
216
+
let sepby1 = compile ~loc env (SepBy1 { p; sep; loc }) in
217
+
[%expr
218
+
match [%e sepby1] with
219
+
| Ok _ as r -> r
220
+
| Error _ -> Ok ([], input)]
221
+
222
+
| SepBy1 { p; sep; loc } ->
223
+
let p_code = compile ~loc env p in
224
+
let sep_code = compile ~loc env sep in
225
+
[%expr
226
+
match [%e p_code] with
227
+
| Ok (x, inp) ->
228
+
let rec loop acc input =
229
+
match [%e sep_code] with
230
+
| Ok (_, inp2) ->
231
+
let input = inp2 in
232
+
(match [%e p_code] with
233
+
| Ok (y, inp3) -> loop (y :: acc) inp3
234
+
| Error e -> Error e)
235
+
| Error _ -> Ok (List.rev acc, input)
236
+
in
237
+
loop [x] inp
238
+
| Error e -> Error e]
239
+
240
+
| EndBy { p; sep; loc } ->
241
+
let endby1 = compile ~loc env (EndBy1 { p; sep; loc }) in
242
+
[%expr
243
+
match [%e endby1] with
244
+
| Ok _ as r -> r
245
+
| Error _ -> Ok ([], input)]
246
+
247
+
| EndBy1 { p; sep; loc } ->
248
+
let p_code = compile ~loc env p in
249
+
let sep_code = compile ~loc env sep in
250
+
[%expr
251
+
match [%e p_code] with
252
+
| Ok (x, inp) ->
253
+
let input = inp in
254
+
(match [%e sep_code] with
255
+
| Ok (_, inp2) ->
256
+
let rec loop acc input =
257
+
match [%e p_code] with
258
+
| Ok (y, inp3) ->
259
+
let input = inp3 in
260
+
(match [%e sep_code] with
261
+
| Ok (_, inp4) -> loop (y :: acc) inp4
262
+
| Error e -> Error e)
263
+
| Error _ -> Ok (List.rev acc, input)
264
+
in
265
+
loop [x] inp2
266
+
| Error e -> Error e)
267
+
| Error e -> Error e]
268
+
269
+
| ManyTill { p; end_; loc } ->
270
+
let p_code = compile ~loc env p in
271
+
let end_code = compile ~loc env end_ in
272
+
[%expr
273
+
let rec loop acc input =
274
+
match [%e end_code] with
275
+
| Ok (_, inp) -> Ok (List.rev acc, inp)
276
+
| Error _ ->
277
+
match [%e p_code] with
278
+
| Ok (x, inp) -> loop (x :: acc) inp
279
+
| Error e -> Error e
280
+
in
281
+
loop [] input]
282
+
283
+
| Count { n; p; loc } ->
284
+
let p_code = compile ~loc env p in
285
+
[%expr
286
+
let rec loop n acc input =
287
+
if n <= 0 then Ok (List.rev acc, input)
288
+
else
289
+
match [%e p_code] with
290
+
| Ok (x, inp) -> loop (n - 1) (x :: acc) inp
291
+
| Error e -> Error e
292
+
in
293
+
loop [%e n] [] input]
294
+
295
+
| Between { open_; close; p; loc } ->
296
+
compile ~loc env (SeqRight { loc; p = open_; q = SeqLeft { loc; p; q = close } })
297
+
298
+
| ChainL { p; op; loc } ->
299
+
let chainl1 = compile ~loc env (ChainL1 { p; op; loc }) in
300
+
[%expr
301
+
match [%e chainl1] with
302
+
| Ok _ as r -> r
303
+
| Error _ -> Ok ([], input)]
304
+
305
+
| ChainL1 { p; op; loc } ->
306
+
let p_code = compile ~loc env p in
307
+
let op_code = compile ~loc env op in
308
+
[%expr
309
+
match [%e p_code] with
310
+
| Ok (x, inp) ->
311
+
let rec loop acc input =
312
+
match [%e op_code] with
313
+
| Ok (f, inp2) ->
314
+
let input = inp2 in
315
+
(match [%e p_code] with
316
+
| Ok (y, inp3) -> loop (f acc y) inp3
317
+
| Error e -> Error e)
318
+
| Error _ -> Ok (acc, input)
319
+
in
320
+
loop x inp
321
+
| Error e -> Error e]
322
+
323
+
| ChainR { p; op; loc } ->
324
+
let chainr1 = compile ~loc env (ChainR1 { p; op; loc }) in
325
+
[%expr
326
+
match [%e chainr1] with
327
+
| Ok _ as r -> r
328
+
| Error _ -> Ok ([], input)]
329
+
330
+
| ChainR1 { p; op; loc } ->
331
+
let p_code = compile ~loc env p in
332
+
let op_code = compile ~loc env op in
333
+
[%expr
334
+
match [%e p_code] with
335
+
| Ok (x, inp) ->
336
+
let rec loop stack input =
337
+
match [%e op_code] with
338
+
| Ok (f, inp2) ->
339
+
let input = inp2 in
340
+
(match [%e p_code] with
341
+
| Ok (y, inp3) -> loop ((f, y) :: stack) inp3
342
+
| Error e -> Error e)
343
+
| Error _ ->
344
+
let rec fold v = function
345
+
| [] -> v
346
+
| (f, y) :: rest -> fold (f v y) rest
347
+
in
348
+
Ok (fold x (List.rev stack), input)
349
+
in
350
+
loop [] inp
351
+
| Error e -> Error e]
352
+
353
+
| Choice { ps; label; loc } ->
354
+
let rec build_choice = function
355
+
| [] -> error_expr ~loc (match label with Some l -> elist ~loc [estring ~loc l] | None -> elist ~loc [estring ~loc "<choice>"])
356
+
| [p] -> compile ~loc env p
357
+
| p :: rest ->
358
+
let p_code = compile ~loc env p in
359
+
let rest_code = build_choice rest in
360
+
[%expr
361
+
let saved = input in
362
+
match [%e p_code] with
363
+
| Ok _ as r -> r
364
+
| Error e1 ->
365
+
let input = saved in
366
+
match [%e rest_code] with
367
+
| Ok _ as r -> r
368
+
| Error e2 -> Error (Combin.merge_errors e1 e2)]
369
+
in
370
+
build_choice ps
371
+
372
+
| Label { p; label; loc } ->
373
+
let p_code = compile ~loc env p in
374
+
[%expr
375
+
match [%e p_code] with
376
+
| Ok _ as r -> r
377
+
| Error e -> Error { e with Combin.expected = [[%e estring ~loc label]] }]
378
+
379
+
| Fix { body; _ } ->
380
+
[%expr
381
+
let rec parser_fix = [%e body] in
382
+
parser_fix input]
383
+
384
+
| Var { name; loc } ->
385
+
[%expr [%e evar ~loc name] (module I) input]
386
+
387
+
and compile_committed_alt ~loc env p q p_first q_first =
388
+
let p_code = compile ~loc env p in
389
+
let q_code = compile ~loc env q in
390
+
let build_guard first =
391
+
match first.First_set.firsts with
392
+
| [First_set.Token tok] ->
393
+
[%expr match I.peek input with Some t when t = [%e tok] -> true | _ -> false]
394
+
| [First_set.OneOf toks] ->
395
+
[%expr match I.peek input with Some t when List.mem t [%e toks] -> true | _ -> false]
396
+
| _ -> [%expr true]
397
+
in
398
+
let p_guard = build_guard p_first in
399
+
let q_guard = build_guard q_first in
400
+
[%expr
401
+
if [%e p_guard] then [%e p_code]
402
+
else if [%e q_guard] then [%e q_code]
403
+
else [%e error_expr ~loc (elist ~loc [estring ~loc "<alt>"])]]
404
+
405
+
and compile_backtrack_alt ~loc env p q =
406
+
let p_code = compile ~loc env p in
407
+
let q_code = compile ~loc env q in
408
+
[%expr
409
+
let saved = input in
410
+
match [%e p_code] with
411
+
| Ok _ as r -> r
412
+
| Error e1 ->
413
+
let input = saved in
414
+
match [%e q_code] with
415
+
| Ok _ as r -> r
416
+
| Error e2 -> Error (Combin.merge_errors e1 e2)]
417
+
418
+
let compile_def env { name; expr; loc } =
419
+
let body = compile ~loc env expr in
420
+
let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
421
+
value_binding ~loc ~pat:(pvar ~loc name) ~expr:func
422
+
423
+
let compile_mutual_def env { names; expr; loc } =
424
+
let body = compile ~loc env expr in
425
+
let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
426
+
let pat = ppat_tuple ~loc (List.map (pvar ~loc) names) in
427
+
value_binding ~loc ~pat ~expr:func
+7
src/dune
+7
src/dune
+103
src/first_set.ml
+103
src/first_set.ml
···
1
+
open Ir
2
+
3
+
type first =
4
+
| Epsilon
5
+
| Predicate of Ppxlib.expression
6
+
| Token of Ppxlib.expression
7
+
| Tokens of Ppxlib.expression
8
+
| OneOf of Ppxlib.expression
9
+
| Any
10
+
| Unknown
11
+
12
+
type t = {
13
+
firsts : first list;
14
+
nullable : bool;
15
+
}
16
+
17
+
let empty = { firsts = []; nullable = false }
18
+
let epsilon = { firsts = [Epsilon]; nullable = true }
19
+
let any = { firsts = [Any]; nullable = false }
20
+
let unknown = { firsts = [Unknown]; nullable = false }
21
+
22
+
let of_predicate e = { firsts = [Predicate e]; nullable = false }
23
+
let of_token e = { firsts = [Token e]; nullable = false }
24
+
let of_tokens e = { firsts = [Tokens e]; nullable = false }
25
+
let of_one_of e = { firsts = [OneOf e]; nullable = false }
26
+
27
+
let union a b = {
28
+
firsts = a.firsts @ b.firsts;
29
+
nullable = a.nullable || b.nullable;
30
+
}
31
+
32
+
let seq a b =
33
+
if a.nullable then union { a with nullable = false } b
34
+
else a
35
+
36
+
let rec compute env = function
37
+
| Pure _ -> epsilon
38
+
| Fail _ -> empty
39
+
| Satisfy { pred; _ } -> of_predicate pred
40
+
| Any _ -> any
41
+
| Eof _ -> epsilon
42
+
| Token { tok; _ } -> of_token tok
43
+
| Tokens { toks; _ } -> of_tokens toks
44
+
| OneOf { toks; _ } -> of_one_of toks
45
+
| NoneOf _ -> unknown
46
+
| Bind { p; _ } -> compute env p
47
+
| Map { p; _ } -> compute env p
48
+
| Apply { pf; px; _ } -> seq (compute env pf) (compute env px)
49
+
| SeqLeft { p; q; _ } -> seq (compute env p) (compute env q)
50
+
| SeqRight { p; q; _ } -> seq (compute env p) (compute env q)
51
+
| Alt { p; q; _ } -> union (compute env p) (compute env q)
52
+
| Attempt { p; _ } -> compute env p
53
+
| Cut _ -> epsilon
54
+
| Lookahead { p; _ } -> { (compute env p) with nullable = true }
55
+
| NotFollowedBy _ -> epsilon
56
+
| Many _ -> epsilon
57
+
| Some_ { p; _ } -> compute env p
58
+
| Optional { p; _ } -> { (compute env p) with nullable = true }
59
+
| Option { p; _ } -> { (compute env p) with nullable = true }
60
+
| SepBy _ -> epsilon
61
+
| SepBy1 { p; _ } -> compute env p
62
+
| EndBy _ -> epsilon
63
+
| EndBy1 { p; _ } -> compute env p
64
+
| ManyTill { p; _ } -> union (compute env p) epsilon
65
+
| Count { p; _ } -> compute env p
66
+
| Between { open_; _ } -> compute env open_
67
+
| ChainL _ -> epsilon
68
+
| ChainL1 { p; _ } -> compute env p
69
+
| ChainR _ -> epsilon
70
+
| ChainR1 { p; _ } -> compute env p
71
+
| Choice { ps; _ } -> List.fold_left (fun acc p -> union acc (compute env p)) empty ps
72
+
| Label { p; _ } -> compute env p
73
+
| Fix { names; _ } ->
74
+
List.fold_left (fun acc name ->
75
+
match List.assoc_opt name env with
76
+
| Some fs -> union acc fs
77
+
| None -> acc
78
+
) empty names
79
+
| Var { name; _ } ->
80
+
(match List.assoc_opt name env with
81
+
| Some fs -> fs
82
+
| None -> unknown)
83
+
84
+
let has_unknown t = List.exists (function Unknown -> true | _ -> false) t.firsts
85
+
86
+
let definitely_disjoint a b =
87
+
if has_unknown a || has_unknown b then false
88
+
else if a.nullable && b.nullable then false
89
+
else
90
+
let singleton_token = function
91
+
| [Token _] -> true
92
+
| [OneOf _] -> true
93
+
| _ -> false
94
+
in
95
+
singleton_token a.firsts && singleton_token b.firsts
96
+
97
+
let is_static = function
98
+
| Token _ -> true
99
+
| Tokens _ -> true
100
+
| OneOf _ -> true
101
+
| _ -> false
102
+
103
+
let all_static t = List.for_all is_static t.firsts
+93
src/ir.ml
+93
src/ir.ml
···
1
+
type loc = Ppxlib.Location.t
2
+
3
+
type expr =
4
+
| Pure of { loc : loc; value : Ppxlib.expression }
5
+
| Fail of { loc : loc; msg : string }
6
+
| Satisfy of { loc : loc; pred : Ppxlib.expression; label : string option }
7
+
| Any of { loc : loc }
8
+
| Eof of { loc : loc }
9
+
| Token of { loc : loc; tok : Ppxlib.expression }
10
+
| Tokens of { loc : loc; toks : Ppxlib.expression }
11
+
| OneOf of { loc : loc; toks : Ppxlib.expression }
12
+
| NoneOf of { loc : loc; toks : Ppxlib.expression }
13
+
| Bind of { loc : loc; p : expr; f : Ppxlib.expression }
14
+
| Map of { loc : loc; f : Ppxlib.expression; p : expr }
15
+
| Apply of { loc : loc; pf : expr; px : expr }
16
+
| SeqLeft of { loc : loc; p : expr; q : expr }
17
+
| SeqRight of { loc : loc; p : expr; q : expr }
18
+
| Alt of { loc : loc; p : expr; q : expr }
19
+
| Attempt of { loc : loc; p : expr }
20
+
| Cut of { loc : loc }
21
+
| Lookahead of { loc : loc; p : expr }
22
+
| NotFollowedBy of { loc : loc; p : expr }
23
+
| Many of { loc : loc; p : expr }
24
+
| Some_ of { loc : loc; p : expr }
25
+
| Optional of { loc : loc; p : expr }
26
+
| Option of { loc : loc; default : Ppxlib.expression; p : expr }
27
+
| SepBy of { loc : loc; p : expr; sep : expr }
28
+
| SepBy1 of { loc : loc; p : expr; sep : expr }
29
+
| EndBy of { loc : loc; p : expr; sep : expr }
30
+
| EndBy1 of { loc : loc; p : expr; sep : expr }
31
+
| ManyTill of { loc : loc; p : expr; end_ : expr }
32
+
| Count of { loc : loc; n : Ppxlib.expression; p : expr }
33
+
| Between of { loc : loc; open_ : expr; close : expr; p : expr }
34
+
| ChainL of { loc : loc; p : expr; op : expr }
35
+
| ChainL1 of { loc : loc; p : expr; op : expr }
36
+
| ChainR of { loc : loc; p : expr; op : expr }
37
+
| ChainR1 of { loc : loc; p : expr; op : expr }
38
+
| Choice of { loc : loc; ps : expr list; label : string option }
39
+
| Label of { loc : loc; p : expr; label : string }
40
+
| Fix of { loc : loc; arity : int; names : string list; body : Ppxlib.expression }
41
+
| Var of { loc : loc; name : string }
42
+
43
+
type parser_def = {
44
+
loc : loc;
45
+
name : string;
46
+
expr : expr;
47
+
}
48
+
49
+
type mutual_def = {
50
+
loc : loc;
51
+
names : string list;
52
+
expr : expr;
53
+
}
54
+
55
+
let loc_of_expr = function
56
+
| Pure { loc; _ } -> loc
57
+
| Fail { loc; _ } -> loc
58
+
| Satisfy { loc; _ } -> loc
59
+
| Any { loc } -> loc
60
+
| Eof { loc } -> loc
61
+
| Token { loc; _ } -> loc
62
+
| Tokens { loc; _ } -> loc
63
+
| OneOf { loc; _ } -> loc
64
+
| NoneOf { loc; _ } -> loc
65
+
| Bind { loc; _ } -> loc
66
+
| Map { loc; _ } -> loc
67
+
| Apply { loc; _ } -> loc
68
+
| SeqLeft { loc; _ } -> loc
69
+
| SeqRight { loc; _ } -> loc
70
+
| Alt { loc; _ } -> loc
71
+
| Attempt { loc; _ } -> loc
72
+
| Cut { loc } -> loc
73
+
| Lookahead { loc; _ } -> loc
74
+
| NotFollowedBy { loc; _ } -> loc
75
+
| Many { loc; _ } -> loc
76
+
| Some_ { loc; _ } -> loc
77
+
| Optional { loc; _ } -> loc
78
+
| Option { loc; _ } -> loc
79
+
| SepBy { loc; _ } -> loc
80
+
| SepBy1 { loc; _ } -> loc
81
+
| EndBy { loc; _ } -> loc
82
+
| EndBy1 { loc; _ } -> loc
83
+
| ManyTill { loc; _ } -> loc
84
+
| Count { loc; _ } -> loc
85
+
| Between { loc; _ } -> loc
86
+
| ChainL { loc; _ } -> loc
87
+
| ChainL1 { loc; _ } -> loc
88
+
| ChainR { loc; _ } -> loc
89
+
| ChainR1 { loc; _ } -> loc
90
+
| Choice { loc; _ } -> loc
91
+
| Label { loc; _ } -> loc
92
+
| Fix { loc; _ } -> loc
93
+
| Var { loc; _ } -> loc
+209
src/ppx_combin.ml
+209
src/ppx_combin.ml
···
1
+
open Ppxlib
2
+
3
+
let is_operator name =
4
+
String.length name > 0 &&
5
+
match name.[0] with
6
+
| '!' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' -> true
7
+
| _ -> false
8
+
9
+
let extract_fun_params expr =
10
+
match expr.pexp_desc with
11
+
| Pexp_function (params, None, Pfunction_body body) ->
12
+
let pats = List.filter_map (fun p ->
13
+
match p.pparam_desc with
14
+
| Pparam_val (Nolabel, None, pat) -> Some pat
15
+
| _ -> None
16
+
) params in
17
+
(pats, body)
18
+
| _ -> ([], expr)
19
+
20
+
let rec expr_to_ir ~loc (e : expression) : Ir.expr =
21
+
match e.pexp_desc with
22
+
| Pexp_ident { txt = Lident "pure"; _ } ->
23
+
Location.raise_errorf ~loc "pure requires an argument"
24
+
| Pexp_ident { txt = Lident "fail"; _ } ->
25
+
Location.raise_errorf ~loc "fail requires an argument"
26
+
| Pexp_ident { txt = Lident "any"; _ } ->
27
+
Ir.Any { loc }
28
+
| Pexp_ident { txt = Lident "eof"; _ } ->
29
+
Ir.Eof { loc }
30
+
| Pexp_ident { txt = Lident "cut"; _ } ->
31
+
Ir.Cut { loc }
32
+
| Pexp_ident { txt = Lident name; _ } ->
33
+
Ir.Var { loc; name }
34
+
35
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "pure"; _ }; _ }, [(Nolabel, arg)]) ->
36
+
Ir.Pure { loc; value = arg }
37
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fail"; _ }; _ }, [(Nolabel, { pexp_desc = Pexp_constant (Pconst_string (msg, _, _)); _ })]) ->
38
+
Ir.Fail { loc; msg }
39
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "satisfy"; _ }; _ }, [(Nolabel, pred)]) ->
40
+
Ir.Satisfy { loc; pred; label = None }
41
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "token"; _ }; _ }, [(Nolabel, tok)]) ->
42
+
Ir.Token { loc; tok }
43
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "tokens"; _ }; _ }, [(Nolabel, toks)]) ->
44
+
Ir.Tokens { loc; toks }
45
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "one_of"; _ }; _ }, [(Nolabel, toks)]) ->
46
+
Ir.OneOf { loc; toks }
47
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "none_of"; _ }; _ }, [(Nolabel, toks)]) ->
48
+
Ir.NoneOf { loc; toks }
49
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "char"; _ }; _ }, [(Nolabel, c)]) ->
50
+
Ir.Token { loc; tok = c }
51
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "string"; _ }; _ }, [(Nolabel, s)]) ->
52
+
Ir.Tokens { loc; toks = [%expr String.to_seq [%e s] |> List.of_seq] }
53
+
54
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "attempt"; _ }; _ }, [(Nolabel, p)]) ->
55
+
Ir.Attempt { loc; p = expr_to_ir ~loc p }
56
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "lookahead"; _ }; _ }, [(Nolabel, p)]) ->
57
+
Ir.Lookahead { loc; p = expr_to_ir ~loc p }
58
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "not_followed_by"; _ }; _ }, [(Nolabel, p)]) ->
59
+
Ir.NotFollowedBy { loc; p = expr_to_ir ~loc p }
60
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "many"; _ }; _ }, [(Nolabel, p)]) ->
61
+
Ir.Many { loc; p = expr_to_ir ~loc p }
62
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "some"; _ }; _ }, [(Nolabel, p)]) ->
63
+
Ir.Some_ { loc; p = expr_to_ir ~loc p }
64
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "optional"; _ }; _ }, [(Nolabel, p)]) ->
65
+
Ir.Optional { loc; p = expr_to_ir ~loc p }
66
+
67
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "option"; _ }; _ }, [(Nolabel, default); (Nolabel, p)]) ->
68
+
Ir.Option { loc; default; p = expr_to_ir ~loc p }
69
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "sep_by"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
70
+
Ir.SepBy { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
71
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "sep_by1"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
72
+
Ir.SepBy1 { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
73
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "end_by"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
74
+
Ir.EndBy { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
75
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "end_by1"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
76
+
Ir.EndBy1 { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
77
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "many_till"; _ }; _ }, [(Nolabel, p); (Nolabel, e)]) ->
78
+
Ir.ManyTill { loc; p = expr_to_ir ~loc p; end_ = expr_to_ir ~loc e }
79
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "count"; _ }; _ }, [(Nolabel, n); (Nolabel, p)]) ->
80
+
Ir.Count { loc; n; p = expr_to_ir ~loc p }
81
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "between"; _ }; _ }, [(Nolabel, o); (Nolabel, c); (Nolabel, p)]) ->
82
+
Ir.Between { loc; open_ = expr_to_ir ~loc o; close = expr_to_ir ~loc c; p = expr_to_ir ~loc p }
83
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainl"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
84
+
Ir.ChainL { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
85
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainl1"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
86
+
Ir.ChainL1 { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
87
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainr"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
88
+
Ir.ChainR { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
89
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainr1"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
90
+
Ir.ChainR1 { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
91
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "choice"; _ }; _ }, [(Nolabel, list_expr)]) ->
92
+
let ps = match list_expr.pexp_desc with
93
+
| Pexp_construct ({ txt = Lident "[]"; _ }, None) -> []
94
+
| Pexp_construct ({ txt = Lident "::"; _ }, _) ->
95
+
let rec extract_list e = match e.pexp_desc with
96
+
| Pexp_construct ({ txt = Lident "[]"; _ }, None) -> []
97
+
| Pexp_construct ({ txt = Lident "::"; _ }, Some { pexp_desc = Pexp_tuple [h; t]; _ }) ->
98
+
expr_to_ir ~loc h :: extract_list t
99
+
| _ -> Location.raise_errorf ~loc "choice expects a list"
100
+
in
101
+
extract_list list_expr
102
+
| _ -> Location.raise_errorf ~loc "choice expects a list"
103
+
in
104
+
Ir.Choice { loc; ps; label = None }
105
+
106
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident ">>="; _ }; _ }, [(Nolabel, p); (Nolabel, f)]) ->
107
+
Ir.Bind { loc; p = expr_to_ir ~loc p; f }
108
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<|>"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
109
+
Ir.Alt { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
110
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<*>"; _ }; _ }, [(Nolabel, pf); (Nolabel, px)]) ->
111
+
Ir.Apply { loc; pf = expr_to_ir ~loc pf; px = expr_to_ir ~loc px }
112
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "*>"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
113
+
Ir.SeqRight { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
114
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<*"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
115
+
Ir.SeqLeft { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
116
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<$>"; _ }; _ }, [(Nolabel, f); (Nolabel, p)]) ->
117
+
Ir.Map { loc; f; p = expr_to_ir ~loc p }
118
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<?>"; _ }; _ }, [(Nolabel, p); (Nolabel, { pexp_desc = Pexp_constant (Pconst_string (label, _, _)); _ })]) ->
119
+
Ir.Label { loc; p = expr_to_ir ~loc p; label }
120
+
121
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fix"; _ }; _ }, [(Nolabel, fn)]) ->
122
+
let (pats, body) = extract_fun_params fn in
123
+
(match pats with
124
+
| [pat] ->
125
+
let names = extract_pattern_names pat in
126
+
Ir.Fix { loc; arity = List.length names; names; body }
127
+
| _ -> Location.raise_errorf ~loc "fix requires a single function argument")
128
+
129
+
| Pexp_apply (_, _) when is_infix_chain e ->
130
+
parse_infix_chain ~loc e
131
+
132
+
| _ ->
133
+
Location.raise_errorf ~loc "unsupported parser expression"
134
+
135
+
and is_infix_chain e =
136
+
match e.pexp_desc with
137
+
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident op; _ }; _ }, [(Nolabel, _); (Nolabel, _)])
138
+
when is_operator op -> true
139
+
| _ -> false
140
+
141
+
and parse_infix_chain ~loc e =
142
+
expr_to_ir ~loc e
143
+
144
+
and extract_pattern_names pat =
145
+
match pat.ppat_desc with
146
+
| Ppat_var { txt; _ } -> [txt]
147
+
| Ppat_tuple pats -> List.concat_map extract_pattern_names pats
148
+
| _ -> Location.raise_errorf ~loc:pat.ppat_loc "fix pattern must be variable or tuple of variables"
149
+
150
+
let expand_parser_expr ~ctxt expr =
151
+
let loc = Expansion_context.Extension.extension_point_loc ctxt in
152
+
let ir = expr_to_ir ~loc expr in
153
+
let errors = Check.check_expr [] ir in
154
+
List.iter (fun e ->
155
+
let err_loc = Check.error_loc e in
156
+
let msg = Check.format_error e in
157
+
Location.raise_errorf ~loc:err_loc "%s" msg
158
+
) errors;
159
+
let body = Codegen.compile ~loc [] ir in
160
+
[%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> [%e body]]
161
+
162
+
let parser_extension =
163
+
Extension.V3.declare
164
+
"parser"
165
+
Extension.Context.expression
166
+
Ast_pattern.(single_expr_payload __)
167
+
expand_parser_expr
168
+
169
+
let parser_rule = Context_free.Rule.extension parser_extension
170
+
171
+
let extract_let_bindings str_items =
172
+
List.filter_map (fun item ->
173
+
match item.pstr_desc with
174
+
| Pstr_value (Nonrecursive, [vb]) ->
175
+
(match vb.pvb_pat.ppat_desc with
176
+
| Ppat_var { txt = name; _ } -> Some (name, vb.pvb_expr, vb.pvb_loc)
177
+
| _ -> None)
178
+
| _ -> None
179
+
) str_items
180
+
181
+
let expand_parser_stri ~ctxt str_items =
182
+
let loc = Expansion_context.Extension.extension_point_loc ctxt in
183
+
let bindings = extract_let_bindings str_items in
184
+
let compiled = List.map (fun (name, expr, binding_loc) ->
185
+
let ir = expr_to_ir ~loc:binding_loc expr in
186
+
let errors = Check.check_expr [] ir in
187
+
List.iter (fun e ->
188
+
let err_loc = Check.error_loc e in
189
+
let msg = Check.format_error e in
190
+
Location.raise_errorf ~loc:err_loc "%s" msg
191
+
) errors;
192
+
let body = Codegen.compile ~loc:binding_loc [] ir in
193
+
let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> [%e body]] in
194
+
Ast_builder.Default.value_binding ~loc:binding_loc
195
+
~pat:(Ast_builder.Default.pvar ~loc:binding_loc name)
196
+
~expr:func
197
+
) bindings in
198
+
Ast_builder.Default.pstr_value ~loc Nonrecursive compiled
199
+
200
+
let parser_stri_extension =
201
+
Extension.V3.declare
202
+
"parser"
203
+
Extension.Context.structure_item
204
+
Ast_pattern.(pstr __)
205
+
expand_parser_stri
206
+
207
+
let parser_stri_rule = Context_free.Rule.extension parser_stri_extension
208
+
209
+
let () = Driver.register_transformation ~rules:[parser_rule; parser_stri_rule] "ppx_combin"