vm.fail
OCaml parser combinator that compiles to direct recursive descent
6.0 kB
161 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 | 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
102let 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
107let is_wrapped_in_attempt = function
108 | Attempt _ -> true
109 | _ -> false
110
111let 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
152let error_loc = function
153 | Left_recursion { loc; _ } -> loc
154 | Ambiguous_alt { loc } -> loc
155
156let 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'"