vm.fail
OCaml parser combinator that compiles to direct recursive descent
2.3 kB
77 lines
1module 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
8end
9
10type span = { start_pos : int; end_pos : int }
11
12type error = {
13 span : span;
14 expected : string list;
15}
16
17let merge_errors e1 e2 =
18 if e1.span.end_pos > e2.span.end_pos then e1
19 else if e2.span.end_pos > e1.span.end_pos then e2
20 else { span = { start_pos = min e1.span.start_pos e2.span.start_pos; end_pos = e1.span.end_pos }; expected = e1.expected @ e2.expected }
21
22let pure x _input = Ok (x, _input)
23
24let fail msg _input = Error { span = { start_pos = 0; end_pos = 0 }; expected = [msg] }
25
26module Char_input : sig
27 include INPUT with type token = char
28 val of_string : string -> t
29end = struct
30 type token = char
31 type t = { data : string; pos : int }
32
33 let of_string s = { data = s; pos = 0 }
34
35 let peek { data; pos } =
36 if pos >= String.length data then None
37 else Some (String.get data pos)
38
39 let advance t = { t with pos = t.pos + 1 }
40 let position t = t.pos
41 let show_token c = Printf.sprintf "'%c'" c
42end
43
44let parse_string parser s =
45 let input = Char_input.of_string s in
46 parser (module Char_input : INPUT with type t = Char_input.t and type token = char) input
47
48let format_error ?(input = "") e =
49 let context =
50 if String.length input > 0 && e.span.end_pos < String.length input then
51 let start = max 0 (e.span.start_pos - 5) in
52 let len = min 30 (String.length input - start) in
53 Printf.sprintf " near '%s'" (String.sub input start len)
54 else ""
55 in
56 let pos_str =
57 if e.span.start_pos = e.span.end_pos then
58 Printf.sprintf "position %d" e.span.start_pos
59 else
60 Printf.sprintf "positions %d-%d" e.span.start_pos e.span.end_pos
61 in
62 Printf.sprintf "parse error at %s%s: expected %s"
63 pos_str context (String.concat " or " e.expected)
64
65module Memo : sig
66 type 'a table
67 val create : unit -> 'a table
68 val find : 'a table -> string -> int -> 'a option
69 val add : 'a table -> string -> int -> 'a -> unit
70end = struct
71 type 'a table = (string * int, 'a) Hashtbl.t
72 let create () = Hashtbl.create 64
73 let find tbl name pos = Hashtbl.find_opt tbl (name, pos)
74 let add tbl name pos v = Hashtbl.replace tbl (name, pos) v
75end
76
77type 'a memo_table = ('a * Char_input.t, error) result Memo.table