vm.fail
OCaml parser combinator that compiles to direct recursive descent
6.1 kB
164 lines
1open Ir
2
3type error =
4 | Left_recursion of { loc : loc; name : string; path : string list }
5 | Ambiguous_alt of { loc : loc }
6
7let 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 | Memo { p; _ } -> nullable p
46 | Fix _ -> false
47 | Var { name; _ } ->
48 (match List.assoc_opt name env with
49 | Some e -> nullable e
50 | None -> false)
51 in
52 let rec check path = function
53 | Var { name; _ } when List.mem name names ->
54 Some (List.rev (name :: path))
55 | Var { name; _ } ->
56 (match List.assoc_opt name env with
57 | Some e -> check (name :: path) e
58 | None -> None)
59 | Bind { p; _ } -> check path p
60 | Map { p; _ } -> check path p
61 | Apply { pf; px; _ } ->
62 (match check path pf with
63 | Some _ as r -> r
64 | None -> if nullable pf then check path px else None)
65 | SeqLeft { p; q; _ } ->
66 (match check path p with
67 | Some _ as r -> r
68 | None -> if nullable p then check path q else None)
69 | SeqRight { p; q; _ } ->
70 (match check path p with
71 | Some _ as r -> r
72 | None -> if nullable p then check path q else None)
73 | Alt { p; q; _ } ->
74 (match check path p with
75 | Some _ as r -> r
76 | None -> check path q)
77 | Attempt { p; _ } -> check path p
78 | Lookahead { p; _ } -> check path p
79 | NotFollowedBy { p; _ } -> check path p
80 | Label { p; _ } -> check path p
81 | Many { p; _ } -> check path p
82 | Some_ { p; _ } -> check path p
83 | Optional { p; _ } -> check path p
84 | Option { p; _ } -> check path p
85 | SepBy { p; _ } -> check path p
86 | SepBy1 { p; _ } -> check path p
87 | EndBy { p; _ } -> check path p
88 | EndBy1 { p; _ } -> check path p
89 | ManyTill { p; _ } -> check path p
90 | Count { p; _ } -> check path p
91 | Between { open_; _ } -> check path open_
92 | ChainL { p; _ } -> check path p
93 | ChainL1 { p; _ } -> check path p
94 | ChainR { p; _ } -> check path p
95 | ChainR1 { p; _ } -> check path p
96 | Choice { ps; _ } -> List.find_map (check path) ps
97 | Memo { p; _ } -> check path p
98 | Fix _ -> None
99 | Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
100 | OneOf _ | NoneOf _ | Cut _ -> None
101 in
102 check [] expr
103
104let check_left_recursion env names expr =
105 match left_recursive_path env names expr with
106 | Some path -> Some (Left_recursion { loc = loc_of_expr expr; name = List.hd names; path })
107 | None -> None
108
109let is_wrapped_in_attempt = function
110 | Attempt _ -> true
111 | _ -> false
112
113let rec check_expr env = function
114 | Alt { loc; p; q } ->
115 let p_first = First_set.compute env p in
116 let q_first = First_set.compute env q in
117 let errs =
118 if is_wrapped_in_attempt p || is_wrapped_in_attempt q then
119 []
120 else if not (First_set.definitely_disjoint p_first q_first) then
121 [Ambiguous_alt { loc }]
122 else
123 []
124 in
125 errs @ check_expr env p @ check_expr env q
126 | Bind { p; _ } -> check_expr env p
127 | Map { p; _ } -> check_expr env p
128 | Apply { pf; px; _ } -> check_expr env pf @ check_expr env px
129 | SeqLeft { p; q; _ } -> check_expr env p @ check_expr env q
130 | SeqRight { p; q; _ } -> check_expr env p @ check_expr env q
131 | Attempt { p; _ } -> check_expr env p
132 | Lookahead { p; _ } -> check_expr env p
133 | NotFollowedBy { p; _ } -> check_expr env p
134 | Many { p; _ } -> check_expr env p
135 | Some_ { p; _ } -> check_expr env p
136 | Optional { p; _ } -> check_expr env p
137 | Option { p; _ } -> check_expr env p
138 | SepBy { p; sep; _ } -> check_expr env p @ check_expr env sep
139 | SepBy1 { p; sep; _ } -> check_expr env p @ check_expr env sep
140 | EndBy { p; sep; _ } -> check_expr env p @ check_expr env sep
141 | EndBy1 { p; sep; _ } -> check_expr env p @ check_expr env sep
142 | ManyTill { p; end_; _ } -> check_expr env p @ check_expr env end_
143 | Count { p; _ } -> check_expr env p
144 | Between { open_; close; p; _ } -> check_expr env open_ @ check_expr env close @ check_expr env p
145 | ChainL { p; op; _ } -> check_expr env p @ check_expr env op
146 | ChainL1 { p; op; _ } -> check_expr env p @ check_expr env op
147 | ChainR { p; op; _ } -> check_expr env p @ check_expr env op
148 | ChainR1 { p; op; _ } -> check_expr env p @ check_expr env op
149 | Choice { ps; _ } -> List.concat_map (check_expr env) ps
150 | Label { p; _ } -> check_expr env p
151 | Memo { p; _ } -> check_expr env p
152 | Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
153 | OneOf _ | NoneOf _ | Cut _ | Fix _ | Var _ -> []
154
155let error_loc = function
156 | Left_recursion { loc; _ } -> loc
157 | Ambiguous_alt { loc } -> loc
158
159let format_error = function
160 | Left_recursion { name; path; _ } ->
161 Printf.sprintf "left recursion detected: %s via %s"
162 name (String.concat " -> " path)
163 | Ambiguous_alt _ ->
164 "ambiguous alternation: branches may have overlapping first sets, wrap one in 'attempt'"