Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 280 lines (249 sloc) 8.552 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 type data = string list
20 type t =
21 {
22 pos : int ; (* the len currently used in (hd data) *)
23 data : data ; (* rev *)
24 len_data : int (* caching sum of length of data *)
25 }
26
27 let s_alloc min (i:int) =
28 Pervasives.min Sys.max_string_length (Pervasives.max min i)
29
30 let create ?name:_ hint =
31 {
32 pos = 0 ;
33 data = [ String.create hint ] ;
34 len_data = 0
35 }
36
37 let diverge t =
38 match t.data with
39 | h::q -> { t with data = (String.copy h)::q }
40 | _ -> t
41
42 (* Mathieu : Sat Jul 3 01:26:23 CEST 2010
43 + Keep ident like in SRope for homogenity
44 + merging add and add_substring
45 *)
46
47 let add_substring t s start len_s =
48 ( if start < 0 || len_s < 0 || start + len_s > String.length s then invalid_arg "FBuffer.add_substring" ) ;
49 let e = List.hd t.data in
50 let full_e = String.length e in
51 let len_e = t.pos in
52 let rest_e = full_e - len_e in
53 if len_s <= rest_e
54 then (* s can be inserted in place *)
55 let _ = String.unsafe_blit s start e len_e len_s in
56 { t with pos = len_e + len_s }
57 else
58 (* blit fully e, and allocated a new head *)
59 let _ = String.unsafe_blit s start e len_e rest_e in
60 let rest_s = len_s - rest_e in
61 let snew = String.create (s_alloc rest_s (2 * full_e)) in
62 let _ = String.unsafe_blit s (start + rest_e) snew 0 rest_s in
63 { pos = rest_s ; data = snew :: t.data ; len_data = full_e + t.len_data }
64
65 let add t s = add_substring t s 0 (String.length s)
66
67 let addln t s = add (add t s) "\n"
68
69 (* must be keeped tail rec *)
70 let iter f t =
71 match t.data with
72 | [] -> ()
73 | s::q ->
74 let iter s = f s 0 (String.length s) in
75 List.iter iter (List.rev q) ;
76 f s 0 t.pos
77
78 let fold f acc t =
79 match t.data with
80 | [] -> acc
81 | s::q ->
82 let fold acc s = f acc s 0 (String.length s) in
83 let acc = List.fold_left fold acc (List.rev q) in
84 f acc s 0 t.pos
85
86 let rev_iter f t =
87 match t.data with
88 | [] -> ()
89 | s::q ->
90 f s 0 t.pos ;
91 let iter s = f s 0 (String.length s) in
92 List.iter iter q
93
94 let rev_fold f acc t =
95 match t.data with
96 | [] -> acc
97 | s::q ->
98 let acc = f acc s 0 t.pos in
99 let fold acc s = f acc s 0 (String.length s) in
100 List.fold_left fold acc q
101
102 let iter_sub f t =
103 match t.data with
104 | [] -> ()
105 | s::q ->
106 List.iter f (List.rev q) ;
107 f (String.sub s 0 t.pos)
108
109 let fold_sub f acc t =
110 match t.data with
111 | [] -> acc
112 | s::q ->
113 let acc = List.fold_left f acc (List.rev q) in
114 f acc (String.sub s 0 t.pos)
115
116 let concat t1 t2 =
117 {
118 pos = t2.pos ;
119 data = (
120 match t1.data with
121 | hd :: tl ->
122 (* please, keep tail rec *)
123 List.rev_append (List.rev t2.data)
124 (String.sub hd 0 t1.pos :: tl)
125 | [] -> t2.data
126 ) ;
127 len_data = t1.len_data + t1.pos + t2.len_data
128 }
129
130 let length t = t.pos + t.len_data
131 (* without cache is : *)
132 (* t.pos +
133 (List.fold_left (fun acc x -> acc + String.length x) 0 (List.tl t.data)) *)
134
135 (* rev_iter has better perf, we could use it, or inline its code there *)
136 let contents t =
137 let len = length t in
138 if len > Sys.max_string_length then invalid_arg "FBuffer.contents"
139 else
140 let r = String.create len in
141 let len_h = t.pos in
142 let p = ref (len - len_h) in
143 let _ =
144 match t.data with
145 | [] -> ()
146 | h::q ->
147 String.unsafe_blit h 0 r !p len_h ;
148 List.iter
149 ( fun s ->
150 let len_s = String.length s in
151 p := !p - len_s ;
152 String.unsafe_blit s 0 r !p len_s ) q
153 in
154 r
155
156 let sub t start len =
157 ( if start < 0 || len < 0 then invalid_arg "FBuffer.sub" ) ;
158 let s = String.create len in
159 let len_data = t.len_data in
160 let right_s = start + len in
161 let length = len_data + t.pos in
162 ( if right_s > length then invalid_arg "FBuffer.sub" ) ;
163 let _ =
164 if start >= len_data
165 then String.unsafe_blit (List.hd t.data) (start - len_data) s 0 len
166 else (* start < len_data *)
167 (* bliting s from right to left. *)
168 let blit =
169 let p = ref len in
170 (fun src start len -> p := !p - len ; String.unsafe_blit src start s !p len)
171 in
172 (* please, keep tail rec *)
173 let rec aux right_elt right_s = function
174 | [] -> ()
175 | elt::q ->
176 let left_elt = right_elt - (String.length elt) in
177 if right_s <= left_elt then aux left_elt right_s q
178 else (* some piece of elt goes into s *)
179 if start >= left_elt (* elt is the last elt going into s *)
180 then blit elt (start - left_elt) (right_s - start)
181 else
182 begin
183 (* blit elt into s and continue with q *)
184 blit elt 0 (right_s - left_elt) ;
185 aux left_elt left_elt q
186 end
187 in
188 (* <!> special case for hd because (String.length hd <> t.pos) *)
189 let right_elt = length in
190 match t.data with
191 | elt::q ->
192 let left_elt = right_elt - t.pos (* <> String.length elt *) in
193 if right_s <= left_elt then aux left_elt right_s q
194 else (* some piece of elt goes into s *)
195 if start >= left_elt (* elt is the last elt going into s *)
196 then blit elt (start - left_elt) (right_s - start)
197 else
198 begin
199 (* blit elt into s and continue with q *)
200 blit elt 0 (right_s - left_elt) ;
201 aux left_elt left_elt q
202 end
203 | _ -> assert false (* internal error *)
204 in
205 s
206
207 let output oc = iter (Pervasives.output oc)
208
209 (* format *)
210 let make_formatter t_ref =
211 Format.make_formatter
212 (fun s start len -> t_ref := add_substring !t_ref s start len)
213 (fun _ -> ())
214
215 let fmt fmt =
216 let pp = fst (Format.pp_get_formatter_output_functions fmt ()) in
217 iter pp
218
219 let printf t fmt =
220 let t = ref t in
221 let formatter = make_formatter t in
222 Format.kfprintf (fun _ -> Format.pp_print_flush formatter (); !t) formatter fmt
223
224 let sprintf fmt =
225 let t = ref (create 1024) in
226 let formatter = make_formatter t in
227 Format.kfprintf (fun _ -> Format.pp_print_flush formatter (); contents !t) formatter fmt
228
229 (* dynamic choice of impl *)
230 type 'fbuffer implementation =
231 {
232 create : int -> 'fbuffer ;
233 add : 'fbuffer -> string -> 'fbuffer ;
234 addln : 'fbuffer -> string -> 'fbuffer ;
235 concat : 'fbuffer -> 'fbuffer -> 'fbuffer ;
236 add_substring : 'fbuffer -> string -> int -> int -> 'fbuffer ;
237 diverge : 'fbuffer -> 'fbuffer ;
238 contents : 'fbuffer -> string ;
239 output : out_channel -> 'fbuffer -> unit ;
240 length : 'fbuffer -> int ;
241 sub : 'fbuffer -> int -> int -> string ;
242 iter : (string -> int -> int -> unit) -> 'fbuffer -> unit ;
243 fold : 'a. ('a -> string -> int -> int -> 'a) -> 'a -> 'fbuffer -> 'a ;
244 rev_iter : (string -> int -> int -> unit) -> 'fbuffer -> unit ;
245 rev_fold : 'a. ('a -> string -> int -> int -> 'a) -> 'a -> 'fbuffer -> 'a ;
246 iter_sub : (string -> unit) -> 'fbuffer -> unit ;
247 fold_sub : 'a. ('a -> string -> 'a) -> 'a -> 'fbuffer -> 'a ;
248 fmt : Format.formatter -> 'fbuffer -> unit ;
249 printf : 'params. 'fbuffer -> ('params, Format.formatter, unit, 'fbuffer) format4 -> 'params ;
250 sprintf : 'params. ('params, Format.formatter, unit, string) format4 -> 'params ;
251 }
252
253 let implementation =
254 {
255 create = create ;
256 add = add ;
257 addln = addln ;
258 concat = concat ;
259 add_substring = add_substring ;
260 diverge = diverge ;
261 contents = contents ;
262 output = output ;
263 length = length ;
264 sub = sub ;
265 iter = iter ;
266 fold = fold ;
267 rev_iter = rev_iter ;
268 rev_fold = rev_fold ;
269 iter_sub = iter_sub ;
270 fold_sub = fold_sub ;
271 fmt = fmt ;
272 printf = printf ;
273 sprintf = sprintf ;
274 }
275
276 (* deprecated, backward compat *)
277 let make ?name:_ i = create i
278 let union = concat
279 let write t oc = output oc t
Something went wrong with that request. Please try again.