Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 264 lines (232 sloc) 6.714 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 t =
20 | Leaf of int * string (* string, real string length *)
21 | Node of int * t * t (* left, right, len *)
22
23 (* joke: who does want a Walker ? *)
24
25 (* start size for a Leaf, after that perform each realloc * 2 *)
26 let create hint = Leaf (0, String.create hint)
27
28 external length : t -> int = "%field0"
29
30 let concat t t' = Node ((length t) + (length t'), t, t')
31
32 let diverge = function
33 | Leaf (i, s) -> Leaf (i, String.copy s)
34 | Node (i, t, Leaf (j, s)) -> Node (i, t, Leaf (j, String.copy s))
35 | t -> t
36
37 let s_alloc min (i:int) =
38 Pervasives.min Sys.max_string_length (Pervasives.max min i)
39
40 let add_leaf e len_e s =
41 let full_e = String.length e in
42 let len_s = String.length s in
43 let len_es = len_e + len_s in
44 let rest_e = full_e - len_e in
45 if len_s <= rest_e
46 then (* s can be inserted in place *)
47 let _ = String.unsafe_blit s 0 e len_e len_s in
48 Leaf (len_es, e)
49 else
50 (* blit fully e, and allocate a new Leaf *)
51 let _ = String.unsafe_blit s 0 e len_e rest_e in
52 let rest_s = len_s - rest_e in
53 let snew = String.create (s_alloc rest_s (2 * full_e)) in
54 let _ = String.unsafe_blit s rest_e snew 0 rest_s in
55 Node (len_es, Leaf (full_e, e), Leaf (rest_s, snew))
56
57 let add t s =
58 match t with
59 | Node (len_t, t, Leaf (len_e, e)) ->
60 let t' = add_leaf e len_e s in
61 Node (len_t + (String.length s), t, t')
62 | Leaf (len_e, e) -> add_leaf e len_e s
63 | _ ->
64 let len_t = length t in
65 let len_s = String.length s in
66 Node (len_t + len_s, t, Leaf (len_s, s))
67
68 let addln t s = add (add t s) "\n"
69
70 let iter f t =
71 let stack = Stack.create () in
72 let push t = Stack.push t stack in
73 let pop () =
74 match Stack.pop stack with
75 | Node (_, l, r) ->
76 push r ;
77 push l
78 | Leaf (len_s, s) ->
79 f s 0 len_s
80 in
81 try
82 push t ;
83 while true do
84 pop ()
85 done
86 with
87 | Stack.Empty -> ()
88
89 let fold f acc t =
90 let stack = Stack.create () in
91 let push t = Stack.push t stack in
92 let acc = ref acc in
93 let pop () =
94 match Stack.pop stack with
95 | Node (_, l, r) ->
96 push r ;
97 push l
98 | Leaf (len_s, s) ->
99 acc := f !acc s 0 len_s
100 in
101 try
102 push t ;
103 while true do
104 pop ()
105 done ;
106 !acc
107 with
108 | Stack.Empty -> !acc
109
110 let rev_iter f t =
111 let stack = Stack.create () in
112 let push t = Stack.push t stack in
113 let pop () =
114 match Stack.pop stack with
115 | Node (_, l, r) ->
116 push l ;
117 push r
118 | Leaf (len_s, s) ->
119 f s 0 len_s
120 in
121 try
122 push t ;
123 while true do
124 pop ()
125 done
126 with
127 | Stack.Empty -> ()
128
129 let rev_fold f acc t =
130 let stack = Stack.create () in
131 let push t = Stack.push t stack in
132 let acc = ref acc in
133 let pop () =
134 match Stack.pop stack with
135 | Node (_, l, r) ->
136 push l ;
137 push r
138 | Leaf (len_s, s) ->
139 acc := f !acc s 0 len_s
140 in
141 try
142 push t ;
143 while true do
144 pop ()
145 done ;
146 !acc
147 with
148 | Stack.Empty -> !acc
149
150
151 let iter_sub f = iter (fun s start len -> f (String.sub s start len))
152 let fold_sub f = fold (fun acc s start len -> f acc (String.sub s start len))
153
154 let add_substring t s start len = add t (String.sub s start len)
155
156 let contents t =
157 let len = length t in
158 if len > Sys.max_string_length then invalid_arg "SRope.contents" else
159 let s = String.create len in
160 let push =
161 let p = ref 0 in
162 ( fun s' start len ->
163 Base.String.unsafe_blit s' start s !p len ;
164 p := !p + len ) in
165 iter push t ;
166 s
167
168 (* should be tail rec => Stack *)
169 let sub t start len =
170 let s = String.create len in
171 (* bliting from left to right *)
172 let blit =
173 let p = ref 0 in
174 (fun src start len -> String.unsafe_blit src start s !p len ; p := !p + len)
175 in
176 let stack = Stack.create () in
177 let push t = Stack.push t stack in
178 let pop () =
179 match Stack.pop stack with
180 | t, start, len ->
181 begin
182 match t with
183 | Leaf (len_s, s) ->
184 if start + len > len_s then invalid_arg "SRope.sub"
185 else blit s start len
186 | Node (len_n, l, r) ->
187 let stop = start + len in
188 if start + len > len_n then invalid_arg "SRope.sub"
189 else
190 let a = length l in
191 if stop < a
192 then push (l, start, len)
193 else
194 (* stop >= a *)
195 if start >= a
196 then push (r, (start - a), len)
197 else
198 (* should take from l and from r, Stack => push r first *)
199 let from_a = a - start in
200 ( push (r, 0, (len - from_a)) ;
201 push (l, start, from_a) )
202 end
203 in
204 try
205 push (t, start, len) ;
206 while true do
207 pop ()
208 done ;
209 s
210 with
211 | Stack.Empty -> s
212
213 let output oc = iter (Pervasives.output oc)
214
215 (* format *)
216 let make_formatter t_ref =
217 Format.make_formatter
218 (fun s start len -> t_ref := add_substring !t_ref s start len)
219 (fun _ -> ())
220
221 let fmt fmt =
222 let pp = fst (Format.pp_get_formatter_output_functions fmt ()) in
223 iter pp
224
225 let printf t fmt =
226 let t = ref t in
227 let formatter = make_formatter t in
228 Format.kfprintf (fun _ -> Format.pp_print_flush formatter (); !t) formatter fmt
229
230 let sprintf fmt =
231 let t = ref (create 1024) in
232 let formatter = make_formatter t in
233 Format.kfprintf (fun _ -> Format.pp_print_flush formatter (); contents !t) formatter fmt
234
235 (* dynamic choice of impl *)
236 let implementation =
237 { FBuffer.
238 create = create ;
239 add = add ;
240 addln = addln ;
241 concat = concat ;
242 add_substring = add_substring ;
243 diverge = diverge ;
244 contents = contents ;
245 output = output ;
246 length = length ;
247 sub = sub ;
248 iter = iter ;
249 fold = fold ;
250 rev_iter = rev_iter ;
251 rev_fold = rev_fold ;
252 iter_sub = iter_sub ;
253 fold_sub = fold_sub ;
254 fmt = fmt ;
255 printf = printf ;
256 sprintf = sprintf ;
257 }
258
259
260 (* deprecated, backward compat *)
261 let make ?name:_ i = create i
262 let union = concat
263 let write t oc = output oc t
Something went wrong with that request. Please try again.