vm.fail
OCaml parser combinator that compiles to direct recursive descent
3.4 kB
108 lines
1open Ir
2
3type 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
12type t = {
13 firsts : first list;
14 nullable : bool;
15}
16
17let empty = { firsts = []; nullable = false }
18let epsilon = { firsts = [Epsilon]; nullable = true }
19let any = { firsts = [Any]; nullable = false }
20let unknown = { firsts = [Unknown]; nullable = false }
21
22let of_predicate e = { firsts = [Predicate e]; nullable = false }
23let of_token e = { firsts = [Token e]; nullable = false }
24let of_tokens e = { firsts = [Tokens e]; nullable = false }
25let of_one_of e = { firsts = [OneOf e]; nullable = false }
26
27let union a b = {
28 firsts = a.firsts @ b.firsts;
29 nullable = a.nullable || b.nullable;
30}
31
32let seq a b =
33 if a.nullable then union { a with nullable = false } b
34 else a
35
36let 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 | SkipMany _ -> epsilon
59 | SkipSome { p; _ } -> compute env p
60 | TakeWhile { at_least_one = false; _ } -> epsilon
61 | TakeWhile { pred; at_least_one = true; _ } -> of_predicate pred
62 | Optional { p; _ } -> { (compute env p) with nullable = true }
63 | Option { p; _ } -> { (compute env p) with nullable = true }
64 | SepBy _ -> epsilon
65 | SepBy1 { p; _ } -> compute env p
66 | EndBy _ -> epsilon
67 | EndBy1 { p; _ } -> compute env p
68 | ManyTill { p; _ } -> union (compute env p) epsilon
69 | Count { p; _ } -> compute env p
70 | Between { open_; _ } -> compute env open_
71 | ChainL _ -> epsilon
72 | ChainL1 { p; _ } -> compute env p
73 | ChainR _ -> epsilon
74 | ChainR1 { p; _ } -> compute env p
75 | Choice { ps; _ } -> List.fold_left (fun acc p -> union acc (compute env p)) empty ps
76 | Label { p; _ } -> compute env p
77 | Memo { p; _ } -> compute env p
78 | Fix { names; _ } ->
79 List.fold_left (fun acc name ->
80 match List.assoc_opt name env with
81 | Some fs -> union acc fs
82 | None -> acc
83 ) empty names
84 | Var { name; _ } ->
85 (match List.assoc_opt name env with
86 | Some fs -> fs
87 | None -> unknown)
88
89let has_unknown t = List.exists (function Unknown -> true | _ -> false) t.firsts
90
91let definitely_disjoint a b =
92 if has_unknown a || has_unknown b then false
93 else if a.nullable && b.nullable then false
94 else
95 let singleton_token = function
96 | [Token _] -> true
97 | [OneOf _] -> true
98 | _ -> false
99 in
100 singleton_token a.firsts && singleton_token b.firsts
101
102let is_static = function
103 | Token _ -> true
104 | Tokens _ -> true
105 | OneOf _ -> true
106 | _ -> false
107
108let all_static t = List.for_all is_static t.firsts