OCaml parser combinator that compiles to direct recursive descent
inline small parsers to reduce closure overhead
author
vm.fail
date
(Jan 16, 2026, 10:00 PM UTC)
commit
25d8d7e2
25d8d7e264c768416b4d35b8112e451f133443a6
parent
18626473
18626473dfbfde95e601fbffa9c03a5c1fb47d31
vm.fail
date
(Jan 16, 2026, 10:00 PM UTC)
commit
25d8d7e2
25d8d7e264c768416b4d35b8112e451f133443a6
parent
18626473
18626473dfbfde95e601fbffa9c03a5c1fb47d31
+102
+100
src/optimise.ml
+100
src/optimise.ml
···
1
+
open Ir
2
+
3
+
let rec optimise expr =
4
+
match expr with
5
+
| Map { f; p; loc } ->
6
+
let p' = optimise p in
7
+
(match p' with
8
+
| Pure { value; _ } ->
9
+
Pure { loc; value = [%expr [%e f] [%e value]] }
10
+
| Map { f = f2; p = p2; _ } ->
11
+
Map { loc; f = [%expr fun x -> [%e f] ([%e f2] x)]; p = p2 }
12
+
| _ -> Map { loc; f; p = p' })
13
+
14
+
| SeqRight { p; q; loc } ->
15
+
let p' = optimise p in
16
+
let q' = optimise q in
17
+
(match p' with
18
+
| Pure _ -> q'
19
+
| _ -> SeqRight { loc; p = p'; q = q' })
20
+
21
+
| SeqLeft { p; q; loc } ->
22
+
let p' = optimise p in
23
+
let q' = optimise q in
24
+
(match q' with
25
+
| Pure _ -> p'
26
+
| _ -> SeqLeft { loc; p = p'; q = q' })
27
+
28
+
| Apply { pf; px; loc } ->
29
+
let pf' = optimise pf in
30
+
let px' = optimise px in
31
+
(match pf', px' with
32
+
| Pure { value = f; _ }, Pure { value = x; _ } ->
33
+
Pure { loc; value = [%expr [%e f] [%e x]] }
34
+
| Pure { value = f; _ }, _ ->
35
+
Map { loc; f; p = px' }
36
+
| _, Pure { value = x; _ } ->
37
+
Map { loc; f = [%expr fun f -> f [%e x]]; p = pf' }
38
+
| _ -> Apply { loc; pf = pf'; px = px' })
39
+
40
+
| Alt { p; q; loc } ->
41
+
let p' = optimise p in
42
+
let q' = optimise q in
43
+
(match p' with
44
+
| Fail _ -> q'
45
+
| _ -> Alt { loc; p = p'; q = q' })
46
+
47
+
| Bind { p; f; loc } ->
48
+
let p' = optimise p in
49
+
(match p' with
50
+
| Pure { value; _ } ->
51
+
Bind { loc; p = Pure { loc; value = [%expr ()] }; f = [%expr fun () -> [%e f] [%e value]] }
52
+
| _ -> Bind { loc; p = p'; f })
53
+
54
+
| Attempt { p; loc } ->
55
+
Attempt { loc; p = optimise p }
56
+
| Lookahead { p; loc } ->
57
+
Lookahead { loc; p = optimise p }
58
+
| NotFollowedBy { p; loc } ->
59
+
NotFollowedBy { loc; p = optimise p }
60
+
| Many { p; loc } ->
61
+
Many { loc; p = optimise p }
62
+
| Some_ { p; loc } ->
63
+
Some_ { loc; p = optimise p }
64
+
| Optional { p; loc } ->
65
+
Optional { loc; p = optimise p }
66
+
| Option { default; p; loc } ->
67
+
Option { loc; default; p = optimise p }
68
+
| SepBy { p; sep; loc } ->
69
+
SepBy { loc; p = optimise p; sep = optimise sep }
70
+
| SepBy1 { p; sep; loc } ->
71
+
SepBy1 { loc; p = optimise p; sep = optimise sep }
72
+
| EndBy { p; sep; loc } ->
73
+
EndBy { loc; p = optimise p; sep = optimise sep }
74
+
| EndBy1 { p; sep; loc } ->
75
+
EndBy1 { loc; p = optimise p; sep = optimise sep }
76
+
| ManyTill { p; end_; loc } ->
77
+
ManyTill { loc; p = optimise p; end_ = optimise end_ }
78
+
| Count { n; p; loc } ->
79
+
Count { loc; n; p = optimise p }
80
+
| Between { open_; close; p; loc } ->
81
+
Between { loc; open_ = optimise open_; close = optimise close; p = optimise p }
82
+
| ChainL { p; op; loc } ->
83
+
ChainL { loc; p = optimise p; op = optimise op }
84
+
| ChainL1 { p; op; loc } ->
85
+
ChainL1 { loc; p = optimise p; op = optimise op }
86
+
| ChainR { p; op; loc } ->
87
+
ChainR { loc; p = optimise p; op = optimise op }
88
+
| ChainR1 { p; op; loc } ->
89
+
ChainR1 { loc; p = optimise p; op = optimise op }
90
+
| Choice { ps; label; loc } ->
91
+
let ps' = List.map optimise ps in
92
+
let ps'' = List.filter (function Fail _ -> false | _ -> true) ps' in
93
+
Choice { loc; ps = (if ps'' = [] then ps' else ps''); label }
94
+
| Label { p; label; loc } ->
95
+
Label { loc; p = optimise p; label }
96
+
| Memo { name; p; loc } ->
97
+
Memo { loc; name; p = optimise p }
98
+
99
+
| Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
100
+
| OneOf _ | NoneOf _ | Cut _ | Fix _ | Var _ -> expr
+2
src/ppx_combin.ml
+2
src/ppx_combin.ml
···
152
152
let expand_parser_expr ~ctxt expr =
153
153
let loc = Expansion_context.Extension.extension_point_loc ctxt in
154
154
let ir = expr_to_ir ~loc expr in
155
+
let ir = Optimise.optimise ir in
155
156
let errors = Check.check_expr [] ir in
156
157
List.iter (fun e ->
157
158
let err_loc = Check.error_loc e in
···
187
188
let bindings = extract_let_bindings str_items in
188
189
let compiled = List.map (fun (name, expr, binding_loc) ->
189
190
let ir = expr_to_ir ~loc:binding_loc expr in
191
+
let ir = Optimise.optimise ir in
190
192
let memoized_ir = Ir.Memo { loc = binding_loc; name; p = ir } in
191
193
let errors = Check.check_expr [] memoized_ir in
192
194
List.iter (fun e ->