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
(* This file is part of Markup.ml, released under the MIT license. See
LICENSE.md for details, or visit https://github.com/aantron/markup.ml. *)
open Common
open Kstream
let state_fold f initial =
let state = ref initial in
(fun throw e k ->
f !state throw e (fun (c, new_state) ->
state := new_state; k c))
|> make
let string s =
state_fold (fun i _ e k ->
if i >= String.length s then e () else k (s.[i], i + 1)) 0
let buffer b =
state_fold (fun i _ e k ->
if i >= Buffer.length b then e () else k (Buffer.nth b i, i + 1)) 0
(* Optimized away by Flambda. *)
type result = Count of int | Exn of exn
let channel c =
let ended = ref false in
let buffer_length = 4096 in
let buffer = Bytes.create buffer_length in
let position = ref 0 in
let buffered = ref 0 in
(fun throw e k ->
let position' = !position in
if position' < !buffered then begin
position := position' + 1;
k (Bytes.get buffer position')
end
else
let result =
try Count (input c buffer 0 buffer_length)
with exn -> Exn exn
in
match result with
| Count 0 ->
ended := true;
e ()
| Count n ->
position := 1;
buffered := n;
k (Bytes.get buffer 0)
| Exn exn ->
if !ended then e ()
else throw exn)
|> make
let file f =
let c = open_in f in
let s = channel c in
let s' =
(fun throw e k ->
next s
(fun exn -> close_in_noerr c; throw exn)
(fun () -> close_in_noerr c; e ())
k)
|> make
in
s', fun () -> close_in_noerr c
let to_buffer s throw k =
let buffer = Buffer.create 4096 in
iter (fun b _ k -> Buffer.add_char buffer b; k ()) s throw (fun () ->
k buffer)
let to_string s throw k =
to_buffer s throw (fun buffer -> k (Buffer.contents buffer))
let to_channel c s throw k =
let write b throw k =
let exn =
try output_char c b; None
with exn -> Some exn
in
match exn with
| None -> k ()
| Some exn -> throw exn
in
iter write s throw k
let to_file f s throw k =
let c = open_out f in
to_channel c s
(fun exn -> close_out_noerr c; throw exn)
(fun () -> close_out_noerr c; k ())