OCaml parser combinator that compiles to direct recursive descent
streaming/lazy input support and generic token infrastructure
author
vm.fail
date
(Jan 16, 2026, 10:19 PM UTC)
commit
38312f7a
38312f7a895743548de38a3255c990ff82c58e28
parent
64537099
645370990bbc76b0ab1ef0bac1c998887dda33f1
vm.fail
date
(Jan 16, 2026, 10:19 PM UTC)
commit
38312f7a
38312f7a895743548de38a3255c990ff82c58e28
parent
64537099
645370990bbc76b0ab1ef0bac1c998887dda33f1
+84
-4
+80
lib/combin.ml
+80
lib/combin.ml
···
75
75
end
76
76
77
77
type 'a memo_table = ('a * Char_input.t, error) result Memo.table
78
+
79
+
module 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
83
+
end = 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
128
+
end
129
+
130
+
module type TOKEN = sig
131
+
type t
132
+
val equal : t -> t -> bool
133
+
val show : t -> string
134
+
end
135
+
136
+
module Make_list_input (T : TOKEN) : sig
137
+
include INPUT with type token = T.t
138
+
val of_list : T.t list -> t
139
+
end = 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
157
+
end
+4
-4
src/codegen.ml
+4
-4
src/codegen.ml
···
47
47
in
48
48
[%expr
49
49
match I.peek input with
50
-
| Some tok when [%e pred] tok -> Ok (tok, I.advance input)
50
+
| Some c when [%e pred] c -> Ok (c, I.advance input)
51
51
| _ -> [%e error_expr ~loc expected]]
52
52
53
53
| Any { loc } ->
54
54
[%expr
55
55
match I.peek input with
56
-
| Some tok -> Ok (tok, I.advance input)
56
+
| Some c -> Ok (c, I.advance input)
57
57
| None -> [%e error_expr ~loc (elist ~loc [estring ~loc "<any>"])]]
58
58
59
59
| Eof { loc } ->
···
602
602
603
603
let compile_def env { name; expr; loc } =
604
604
let body = compile ~loc env expr in
605
-
let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
605
+
let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) input -> [%e body]] in
606
606
value_binding ~loc ~pat:(pvar ~loc name) ~expr:func
607
607
608
608
let compile_mutual_def env { names; expr; loc } =
609
609
let body = compile ~loc env expr in
610
-
let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
610
+
let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) input -> [%e body]] in
611
611
let pat = ppat_tuple ~loc (List.map (pvar ~loc) names) in
612
612
value_binding ~loc ~pat ~expr:func