Xt templating language (OCaml server) (http://chris.pacejo.net/programs/xt)

root / streams.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
type byte = int
type word = int

module type S = sig
	type t
end

module type Input = S

module type Output = sig
	include S
	val flush: t -> unit
end

module type Reader = sig
	include Input
	type u
	val get: t -> u
end

module type Putback = sig
	include Reader
	val unget: t -> u -> unit
end

module type Writer = sig
	include Output
	type u
	val put: t -> u -> unit
end

module Channel_Input = struct
	type t = in_channel
end

module Channel_Output = struct
	type t = out_channel
	let flush = flush
end

module Channel_ByteReader = struct
	include Channel_Input
	type u = byte
	let get = input_byte
end

module Channel_CharReader = struct
	include Channel_Input
	type u = char
	let get = input_char
end

module Channel_ByteWriter = struct
	include Channel_Output
	type u = byte
	let put = output_byte
end

module Channel_CharWriter = struct
	include Channel_Output
	type u = char
	let put = output_char
end

module Channel_StringWriter = struct
	include Channel_Output
	type u = string
	let put = output_string
end

module String_Input = struct
	type t = { string: string; mutable pos: int }
	let of_string s = { string = s; pos = 0 }
end

module String_CharReader = struct
	include String_Input
	type u = char
	let get sp =
		if sp.pos >= String.length sp.string then raise End_of_file
		else begin
			let b = sp.string.[sp.pos] in
			sp.pos <- sp.pos + 1;
			b
		end
end

module String_ByteReader = struct
	include String_Input
	type u = byte
	let get sp = int_of_char (String_CharReader.get sp)
end

module Buffer_Output = struct
	type t = Buffer.t
	let flush = ignore
end

module Buffer_ByteWriter = struct
	include Buffer_Output
	type u = byte
	let put buf byte = Buffer.add_char buf (char_of_int byte)
end

module Buffer_CharWriter = struct
	include Buffer_Output
	type u = char
	let put = Buffer.add_char
end

module Buffer_StringWriter = struct
	include Buffer_Output
	type u = string
	let put = Buffer.add_string
end

module Reader_Putback(Reader: Reader) = struct
	type t = { reader: Reader.t; mutable queue: Reader.u list }
	type u = Reader.u
	let get s =
		match s.queue with
		| hd :: tl -> s.queue <- tl; hd
		| [] -> Reader.get s.reader
	let unget s u = s.queue <- u :: s.queue
	let of_reader r = { reader = r; queue = [] }
end

module LEWordReader(Reader: Reader with type u = byte) = struct
	type t = Reader.t
	type u = word
	let get s =
		let l = Reader.get s in
		let h = Reader.get s in
		(h lsl 8) lor l
end

module BEWordReader(Reader: Reader with type u = byte) = struct
	type t = Reader.t
	type u = word
	let get s =
		let h = Reader.get s in
		let l = Reader.get s in
		(h lsl 8) lor l
end

module LEWordPutback(Putback: Putback with type u = byte) = struct
	include LEWordReader(Putback)
	let unget s w =
		Putback.unget s (w lsr 8);
		Putback.unget s (w land 0xFF)
end

module BEWordPutback(Putback: Putback with type u = byte) = struct
	include BEWordReader(Putback)
	let unget s w =
		Putback.unget s (w land 0xFF);
		Putback.unget s (w lsr 8)
end

module LEWordWriter(Writer: Writer with type u = byte) = struct
	type t = Writer.t
	type u = word
	let flush = Writer.flush
	let put s w =
		Writer.put s (w land 0xFF);
		Writer.put s (w lsr 8)
end

module BEWordWriter(Writer: Writer with type u = byte) = struct
	type t = Writer.t
	type u = word
	let flush = Writer.flush
	let put s w =
		Writer.put s (w lsr 8);
		Writer.put s (w land 0xFF)
end

module ReaderOps(Reader: Reader) = struct
	let maybe_get s =
		try Some (Reader.get s) with End_of_file -> None
	
	let rec fold f s i =
		match maybe_get s with
		| Some r -> fold f s (f r i)
		| None -> i
	
	let rec iter f s =
		match maybe_get s with
		| Some r -> f r; iter f s
		| None -> ()
end

module PutbackOps(Putback: Putback) = struct
	include ReaderOps(Putback)
	
	let peek s =
		let u = Putback.get s in
		Putback.unget s u;
		u

	let rec token s = function
		| h :: t ->
			begin match try Some (Putback.get s) with End_of_file -> None with
			| Some u ->
				if u = h && token s t then true
				else (Putback.unget s u; false)
			| None -> false
			end
		| [] -> true
end