vm.fail
OCaml parser combinator that compiles to direct recursive descent
4.1 kB
157 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
78
79module Stream_input : sig
80 include INPUT with type token = char
81 val of_channel : in_channel -> t
82 val of_seq : char Seq.t -> t
83end = struct
84 type token = char
85 type t = {
86 mutable buffer : char list;
87 mutable source : char Seq.t;
88 mutable pos : int;
89 }
90
91 let of_seq seq = { buffer = []; source = seq; pos = 0 }
92
93 let of_channel ch =
94 let rec seq () =
95 match input_char ch with
96 | c -> Seq.Cons (c, seq)
97 | exception End_of_file -> Seq.Nil
98 in
99 of_seq seq
100
101 let ensure_buffered t n =
102 let rec fill needed =
103 if needed <= 0 then ()
104 else match t.source () with
105 | Seq.Nil -> ()
106 | Seq.Cons (c, rest) ->
107 t.buffer <- t.buffer @ [c];
108 t.source <- rest;
109 fill (needed - 1)
110 in
111 let buffered = List.length t.buffer in
112 if buffered < n then fill (n - buffered)
113
114 let peek t =
115 ensure_buffered t 1;
116 match t.buffer with
117 | [] -> None
118 | c :: _ -> Some c
119
120 let advance t =
121 ensure_buffered t 1;
122 match t.buffer with
123 | [] -> t
124 | _ :: rest -> { t with buffer = rest; pos = t.pos + 1 }
125
126 let position t = t.pos
127 let show_token c = Printf.sprintf "'%c'" c
128end
129
130module type TOKEN = sig
131 type t
132 val equal : t -> t -> bool
133 val show : t -> string
134end
135
136module Make_list_input (T : TOKEN) : sig
137 include INPUT with type token = T.t
138 val of_list : T.t list -> t
139end = struct
140 type token = T.t
141 type t = { data : T.t list; pos : int }
142
143 let of_list lst = { data = lst; pos = 0 }
144
145 let peek { data; _ } =
146 match data with
147 | [] -> None
148 | x :: _ -> Some x
149
150 let advance t =
151 match t.data with
152 | [] -> t
153 | _ :: rest -> { data = rest; pos = t.pos + 1 }
154
155 let position t = t.pos
156 let show_token = T.show
157end