simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2026-01-23 09:36:41 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into stable

Browse source
This commit is contained in:
Simon Cruanes 2014-11-11 23:53:59 +01:00
commit e0a47cba9b
80 changed files with 1226 additions and 2178 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.merlin
View file

@ -15,4 +15,4 @@ PKG benchmark
PKG threads
PKG threads.posix
PKG lwt
FLG -w +K,+Y,+X
FLG -w +a -w -4 -w -44

7
AUTHORS.md Normal file
View file

@ -0,0 +1,7 @@
# Authors and contributors
- Simon Cruanes
- Drup (Gabriel Radanne)
- Jacques-Pascal Deplaix
- Nicolas Braud-Santoni
- Whitequark (Peter Zotov)

33
Makefile
View file

@ -42,7 +42,7 @@ configure:
EXAMPLES = examples/mem_size.native examples/collatz.native \
examples/bencode_write.native # examples/crawl.native
OPTIONS = -use-ocamlfind
OPTIONS = -use-ocamlfind -I _build
examples: all
ocamlbuild $(OPTIONS) -package unix -I . $(EXAMPLES)
@ -53,9 +53,10 @@ push_doc: doc
scp -r containers_advanced.docdir/* cedeela.fr:~/simon/root/software/containers/advanced
scp -r containers_misc.docdir/* cedeela.fr:~/simon/root/software/containers/misc/
DONTTEST=myocamlbuild.ml setup.ml
DONTTEST=myocamlbuild.ml setup.ml $(wildcard **/*.cppo*)
QTESTABLE=$(filter-out $(DONTTEST), \
$(wildcard core/*.ml) $(wildcard core/*.mli) \
$(wildcard core/*.cppo.ml) $(wildcard core/*.cppo.mli) \
$(wildcard misc/*.ml) $(wildcard misc/*.mli) \
$(wildcard string/*.ml) $(wildcard string/*.mli) \
)
@ -65,16 +66,20 @@ qtest-clean:
QTEST_PREAMBLE='open CCFun;; '
qtest-build: qtest-clean build
@mkdir -p qtest
@qtest extract --preamble $(QTEST_PREAMBLE) -o qtest/qtest_all.ml $(QTESTABLE) 2> /dev/null
@ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib \
-I core -I misc -I string \
qtest/qtest_all.native
#qtest-build: qtest-clean build
# @mkdir -p qtest
# @qtest extract --preamble $(QTEST_PREAMBLE) \
# -o qtest/qtest_all.ml \
# $(QTESTABLE) 2> /dev/null
# @ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib,ocamlbuildlib \
# -I core -I misc -I string \
# qtest/qtest_all.native
qtest: qtest-build
@echo
./qtest_all.native
qtest-gen: qtest-clean
@mkdir -p qtest
@qtest extract --preamble $(QTEST_PREAMBLE) \
-o qtest/run_qtest.cppo.ml \
$(QTESTABLE) 2> /dev/null
push-stable:
git checkout stable
@ -87,11 +92,11 @@ push-stable:
clean-generated:
rm **/*.{mldylib,mlpack,mllib} myocamlbuild.ml -f
run-test: build qtest-build
./qtest_all.native
run-test: build
./run_qtest.native
./run_tests.native
test-all: run-test qtest
test-all: run-test
tags:
otags *.ml *.mli

2
README.md
View file

@ -23,7 +23,7 @@ ocaml-containers
least) are unfinished or don't really work.
Some of the modules have been moved to their own repository (e.g. `sequence`,
`gen`, `qcheck` and are on opam for great fun and profit (or not)).
`gen`, `qcheck`) and are on opam for great fun and profit.
[![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/)

34
_oasis
View file

@ -47,8 +47,9 @@ Library "containers"
CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash,
CCKList, CCInt, CCBool, CCArray, CCOrd, CCIO,
CCRandom, CCKTree, CCTrie, CCString, CCHashtbl,
CCFlatHashtbl, CCSexp
FindlibName: containers
CCFlatHashtbl, CCSexp, CCMap
BuildDepends: bytes
XMETARequires: cppo
Library "containers_string"
Path: string
@ -78,11 +79,9 @@ Library "containers_misc"
Modules: Cache, FHashtbl, FlatHashtbl, Hashset,
Heap, LazyGraph, PersistentGraph,
PHashtbl, SkipList, SplayTree, SplayMap, Univ,
Bij, PiCalculus, Bencode, RAL,
UnionFind, SmallSet, AbsSet, CSM,
ActionMan, BencodeOnDisk, TTree, PrintBox,
HGraph, Automaton, Conv, Bidir, Iteratee, BTree,
Ty, Tell, BencodeStream, RatTerm, Cause, AVL, ParseReact
Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM,
TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee,
BTree, Ty, Cause, AVL, ParseReact
BuildDepends: unix,containers
FindlibName: misc
FindlibParent: containers
@ -206,10 +205,16 @@ Executable test_threads
MainIs: test_Future.ml
BuildDepends: containers,threads,oUnit,containers.lwt
Test all
Command: make test-all
TestTools: run_tests
Run$: flag(tests)
PreBuildCommand: make qtest-gen
Executable run_qtest
Path: qtest/
Install: false
CompiledObject: native
MainIs: run_qtest.ml
Build$: flag(tests)
BuildDepends: containers, containers.misc, containers.string,
oUnit, QTest2Lib
Executable run_tests
Path: tests/
@ -217,7 +222,12 @@ Executable run_tests
CompiledObject: native
MainIs: run_tests.ml
Build$: flag(tests) && flag(misc)
BuildDepends: containers,oUnit,qcheck,containers.misc
BuildDepends: containers, oUnit, qcheck, containers.misc
Test all
Command: make test-all
TestTools: run_tests, run_qtest
Run$: flag(tests) && flag(misc)
Executable web_pwd
Path: examples/cgi/

132
_tags
View file

@ -1,8 +1,9 @@
# OASIS_START
# DO NOT EDIT (digest: 126bedd0d6759f38e9b7190eebb08140)
# DO NOT EDIT (digest: c052544c3d7576d929b768e46a58e0a9)
# Ignore VCS directories, you can use the same kind of rule outside
# OASIS_START/STOP if you want to exclude directories that contains
# useless stuff for the build process
true: annot, bin_annot
<**/.svn>: -traverse
<**/.svn>: not_hygienic
".bzr": -traverse
@ -15,6 +16,7 @@
"_darcs": not_hygienic
# Library containers
"core/containers.cmxs": use_containers
<core/*.ml{,i,y}>: package(bytes)
# Library containers_string
"string/containers_string.cmxs": use_containers_string
"string/KMP.cmx": for-pack(Containers_string)
@ -24,10 +26,12 @@
"advanced/CCLinq.cmx": for-pack(Containers_advanced)
"advanced/CCBatch.cmx": for-pack(Containers_advanced)
"advanced/CCCat.cmx": for-pack(Containers_advanced)
<advanced/*.ml{,i}>: use_containers
<advanced/*.ml{,i,y}>: package(bytes)
<advanced/*.ml{,i,y}>: use_containers
# Library containers_pervasives
"pervasives/containers_pervasives.cmxs": use_containers_pervasives
<pervasives/*.ml{,i}>: use_containers
<pervasives/*.ml{,i,y}>: package(bytes)
<pervasives/*.ml{,i,y}>: use_containers
# Library containers_misc
"misc/containers_misc.cmxs": use_containers_misc
"misc/cache.cmx": for-pack(Containers_misc)
@ -44,14 +48,11 @@
"misc/univ.cmx": for-pack(Containers_misc)
"misc/bij.cmx": for-pack(Containers_misc)
"misc/piCalculus.cmx": for-pack(Containers_misc)
"misc/bencode.cmx": for-pack(Containers_misc)
"misc/RAL.cmx": for-pack(Containers_misc)
"misc/unionFind.cmx": for-pack(Containers_misc)
"misc/smallSet.cmx": for-pack(Containers_misc)
"misc/absSet.cmx": for-pack(Containers_misc)
"misc/CSM.cmx": for-pack(Containers_misc)
"misc/actionMan.cmx": for-pack(Containers_misc)
"misc/bencodeOnDisk.cmx": for-pack(Containers_misc)
"misc/tTree.cmx": for-pack(Containers_misc)
"misc/printBox.cmx": for-pack(Containers_misc)
"misc/hGraph.cmx": for-pack(Containers_misc)
@ -61,61 +62,69 @@
"misc/iteratee.cmx": for-pack(Containers_misc)
"misc/bTree.cmx": for-pack(Containers_misc)
"misc/ty.cmx": for-pack(Containers_misc)
"misc/tell.cmx": for-pack(Containers_misc)
"misc/bencodeStream.cmx": for-pack(Containers_misc)
"misc/ratTerm.cmx": for-pack(Containers_misc)
"misc/cause.cmx": for-pack(Containers_misc)
"misc/AVL.cmx": for-pack(Containers_misc)
"misc/parseReact.cmx": for-pack(Containers_misc)
<misc/*.ml{,i}>: package(unix)
<misc/*.ml{,i}>: use_containers
<misc/*.ml{,i,y}>: package(bytes)
<misc/*.ml{,i,y}>: package(unix)
<misc/*.ml{,i,y}>: use_containers
# Library containers_thread
"threads/containers_thread.cmxs": use_containers_thread
<threads/*.ml{,i}>: package(threads)
<threads/*.ml{,i}>: use_containers
<threads/*.ml{,i,y}>: package(bytes)
<threads/*.ml{,i,y}>: package(threads)
<threads/*.ml{,i,y}>: use_containers
# Library containers_lwt
"lwt/containers_lwt.cmxs": use_containers_lwt
"lwt/behavior.cmx": for-pack(Containers_lwt)
"lwt/lwt_automaton.cmx": for-pack(Containers_lwt)
<lwt/*.ml{,i}>: package(lwt)
<lwt/*.ml{,i}>: package(lwt.unix)
<lwt/*.ml{,i}>: package(unix)
<lwt/*.ml{,i}>: use_containers
<lwt/*.ml{,i}>: use_containers_misc
<lwt/*.ml{,i,y}>: package(bytes)
<lwt/*.ml{,i,y}>: package(lwt)
<lwt/*.ml{,i,y}>: package(lwt.unix)
<lwt/*.ml{,i,y}>: package(unix)
<lwt/*.ml{,i,y}>: use_containers
<lwt/*.ml{,i,y}>: use_containers_misc
# Library containers_cgi
"cgi/containers_cgi.cmxs": use_containers_cgi
<cgi/*.ml{,i}>: package(CamlGI)
<cgi/*.ml{,i}>: use_containers
<cgi/*.ml{,i,y}>: package(CamlGI)
<cgi/*.ml{,i,y}>: package(bytes)
<cgi/*.ml{,i,y}>: use_containers
# Executable benchs
"benchs/benchs.native": package(bench)
"benchs/benchs.native": package(bytes)
"benchs/benchs.native": package(unix)
"benchs/benchs.native": use_containers
"benchs/benchs.native": use_containers_advanced
"benchs/benchs.native": use_containers_misc
"benchs/benchs.native": use_containers_string
<benchs/*.ml{,i}>: package(bench)
<benchs/*.ml{,i}>: use_containers_advanced
<benchs/*.ml{,i}>: use_containers_string
<benchs/*.ml{,i,y}>: package(bench)
<benchs/*.ml{,i,y}>: use_containers_advanced
<benchs/*.ml{,i,y}>: use_containers_string
# Executable bench_conv
"benchs/bench_conv.native": package(benchmark)
"benchs/bench_conv.native": package(bytes)
"benchs/bench_conv.native": use_containers
# Executable bench_batch
"benchs/bench_batch.native": package(benchmark)
"benchs/bench_batch.native": package(bytes)
"benchs/bench_batch.native": use_containers
<benchs/*.ml{,i}>: package(benchmark)
<benchs/*.ml{,i,y}>: package(benchmark)
# Executable bench_hash
"benchs/bench_hash.native": package(bytes)
"benchs/bench_hash.native": package(unix)
"benchs/bench_hash.native": use_containers
"benchs/bench_hash.native": use_containers_misc
<benchs/*.ml{,i}>: package(unix)
<benchs/*.ml{,i}>: use_containers
<benchs/*.ml{,i}>: use_containers_misc
<benchs/*.ml{,i,y}>: package(bytes)
<benchs/*.ml{,i,y}>: package(unix)
<benchs/*.ml{,i,y}>: use_containers
<benchs/*.ml{,i,y}>: use_containers_misc
# Executable test_levenshtein
"tests/test_levenshtein.native": package(bytes)
"tests/test_levenshtein.native": package(qcheck)
"tests/test_levenshtein.native": use_containers
"tests/test_levenshtein.native": use_containers_string
<tests/*.ml{,i}>: use_containers_string
<tests/*.ml{,i,y}>: use_containers_string
# Executable test_lwt
<tests/lwt/test_Behavior.{native,byte}>: package(bytes)
<tests/lwt/test_Behavior.{native,byte}>: package(lwt)
<tests/lwt/test_Behavior.{native,byte}>: package(lwt.unix)
<tests/lwt/test_Behavior.{native,byte}>: package(oUnit)
@ -124,6 +133,7 @@
<tests/lwt/test_Behavior.{native,byte}>: use_containers_lwt
<tests/lwt/test_Behavior.{native,byte}>: use_containers_misc
# Executable test_threads
<tests/lwt/test_Future.{native,byte}>: package(bytes)
<tests/lwt/test_Future.{native,byte}>: package(lwt)
<tests/lwt/test_Future.{native,byte}>: package(lwt.unix)
<tests/lwt/test_Future.{native,byte}>: package(oUnit)
@ -132,45 +142,69 @@
<tests/lwt/test_Future.{native,byte}>: use_containers
<tests/lwt/test_Future.{native,byte}>: use_containers_lwt
<tests/lwt/test_Future.{native,byte}>: use_containers_misc
<tests/lwt/*.ml{,i}>: package(lwt)
<tests/lwt/*.ml{,i}>: package(lwt.unix)
<tests/lwt/*.ml{,i}>: package(oUnit)
<tests/lwt/*.ml{,i}>: package(threads)
<tests/lwt/*.ml{,i}>: package(unix)
<tests/lwt/*.ml{,i}>: use_containers
<tests/lwt/*.ml{,i}>: use_containers_lwt
<tests/lwt/*.ml{,i}>: use_containers_misc
<tests/lwt/*.ml{,i,y}>: package(bytes)
<tests/lwt/*.ml{,i,y}>: package(lwt)
<tests/lwt/*.ml{,i,y}>: package(lwt.unix)
<tests/lwt/*.ml{,i,y}>: package(oUnit)
<tests/lwt/*.ml{,i,y}>: package(threads)
<tests/lwt/*.ml{,i,y}>: package(unix)
<tests/lwt/*.ml{,i,y}>: use_containers
<tests/lwt/*.ml{,i,y}>: use_containers_lwt
<tests/lwt/*.ml{,i,y}>: use_containers_misc
# Executable run_qtest
"qtest/run_qtest.native": package(QTest2Lib)
"qtest/run_qtest.native": package(bytes)
"qtest/run_qtest.native": package(oUnit)
"qtest/run_qtest.native": package(unix)
"qtest/run_qtest.native": use_containers
"qtest/run_qtest.native": use_containers_misc
"qtest/run_qtest.native": use_containers_string
<qtest/*.ml{,i,y}>: package(QTest2Lib)
<qtest/*.ml{,i,y}>: package(bytes)
<qtest/*.ml{,i,y}>: package(oUnit)
<qtest/*.ml{,i,y}>: package(unix)
<qtest/*.ml{,i,y}>: use_containers
<qtest/*.ml{,i,y}>: use_containers_misc
<qtest/*.ml{,i,y}>: use_containers_string
# Executable run_tests
"tests/run_tests.native": package(bytes)
"tests/run_tests.native": package(oUnit)
"tests/run_tests.native": package(qcheck)
"tests/run_tests.native": package(unix)
"tests/run_tests.native": use_containers
"tests/run_tests.native": use_containers_misc
<tests/*.ml{,i}>: package(oUnit)
<tests/*.ml{,i}>: package(qcheck)
<tests/*.ml{,i}>: package(unix)
<tests/*.ml{,i}>: use_containers
<tests/*.ml{,i}>: use_containers_misc
<tests/*.ml{,i,y}>: package(bytes)
<tests/*.ml{,i,y}>: package(oUnit)
<tests/*.ml{,i,y}>: package(qcheck)
<tests/*.ml{,i,y}>: package(unix)
<tests/*.ml{,i,y}>: use_containers
<tests/*.ml{,i,y}>: use_containers_misc
# Executable web_pwd
"examples/cgi/web_pwd.byte": package(CamlGI)
"examples/cgi/web_pwd.byte": package(bytes)
"examples/cgi/web_pwd.byte": package(threads)
"examples/cgi/web_pwd.byte": use_containers
"examples/cgi/web_pwd.byte": use_containers_cgi
<examples/cgi/*.ml{,i}>: package(CamlGI)
<examples/cgi/*.ml{,i}>: package(threads)
<examples/cgi/*.ml{,i}>: use_containers
<examples/cgi/*.ml{,i}>: use_containers_cgi
<examples/cgi/*.ml{,i,y}>: package(CamlGI)
<examples/cgi/*.ml{,i,y}>: package(bytes)
<examples/cgi/*.ml{,i,y}>: package(threads)
<examples/cgi/*.ml{,i,y}>: use_containers
<examples/cgi/*.ml{,i,y}>: use_containers_cgi
# Executable lambda
"examples/lambda.byte": package(bytes)
"examples/lambda.byte": package(unix)
"examples/lambda.byte": use_containers
"examples/lambda.byte": use_containers_misc
<examples/*.ml{,i}>: package(unix)
<examples/*.ml{,i}>: use_containers_misc
<examples/*.ml{,i,y}>: package(unix)
<examples/*.ml{,i,y}>: use_containers_misc
# Executable id_sexp
"examples/id_sexp.native": package(bytes)
"examples/id_sexp.native": use_containers
<examples/*.ml{,i}>: use_containers
<examples/*.ml{,i,y}>: package(bytes)
<examples/*.ml{,i,y}>: use_containers
# OASIS_STOP
<tests/*.ml{,i}>: thread
<threads/*.ml{,i}>: thread
<sequence>: -traverse
<{string,core}/**/*.ml>: warn_K, warn_Y, warn_X
<core/CCVector.cmx>: inline(25)
<{string,core}/**/*.ml>: warn_A, warn(-4), warn(-44)

3
containers.odocl
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: f2008fc227a68cb26812ab37438e52a8)
# DO NOT EDIT (digest: e1f5b42bfafae735d510742c5ac3cefd)
core/CCVector
core/CCDeque
core/CCGen
@ -30,6 +30,7 @@ core/CCString
core/CCHashtbl
core/CCFlatHashtbl
core/CCSexp
core/CCMap
string/KMP
string/Levenshtein
# OASIS_STOP

6
containers_advanced.odocl Normal file
View file

@ -0,0 +1,6 @@
# OASIS_START
# DO NOT EDIT (digest: 49f87e2d7015c5adc472ae3cf76a5351)
advanced/CCLinq
advanced/CCBatch
advanced/CCCat
# OASIS_STOP

8
containers_misc.odocl
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 5c08a0bf51a82d21179a12753e47acff)
# DO NOT EDIT (digest: 3c4c75622413b2b99679e7439134f037)
misc/Cache
misc/FHashtbl
misc/FlatHashtbl
@ -14,14 +14,11 @@ misc/SplayMap
misc/Univ
misc/Bij
misc/PiCalculus
misc/Bencode
misc/RAL
misc/UnionFind
misc/SmallSet
misc/AbsSet
misc/CSM
misc/ActionMan
misc/BencodeOnDisk
misc/TTree
misc/PrintBox
misc/HGraph
@ -31,9 +28,6 @@ misc/Bidir
misc/Iteratee
misc/BTree
misc/Ty
misc/Tell
misc/BencodeStream
misc/RatTerm
misc/Cause
misc/AVL
misc/ParseReact

6
core/CCArray.ml
View file

@ -225,7 +225,7 @@ let _shuffle _rand_int a i j =
let _choose a i j st =
if i>=j then raise Not_found;
a.(i+Random.int (j-i))
a.(i+Random.State.int st (j-i))
let _pp ~sep pp_item buf a i j =
for k = i to j - 1 do
@ -283,7 +283,7 @@ let iteri = Array.iteri
let blit = Array.blit
let reverse_in_place a =
_reverse_in_place a 0 (Array.length a)
_reverse_in_place a 0 ~len:(Array.length a)
(*$T
reverse_in_place [| |]; true
@ -464,7 +464,7 @@ module Sub = struct
let copy a = Array.sub a.arr a.i (length a)
let sub a i len = make a.arr (a.i + i) len
let sub a i len = make a.arr ~len:(a.i + i) len
let equal eq a b =
length a = length b && _equal eq a.arr a.i a.j b.arr b.i b.j

77
core/CCError.ml
View file

@ -34,9 +34,9 @@ type 'a formatter = Format.formatter -> 'a -> unit
(** {2 Basics} *)
type +'a t =
[ `Ok of 'a
| `Error of string
type (+'good, +'bad) t =
[ `Ok of 'good
| `Error of 'bad
]
let return x = `Ok x
@ -68,6 +68,10 @@ let map f e = match e with
| `Ok x -> `Ok (f x)
| `Error s -> `Error s
let map_err f e = match e with
| `Ok _ as res -> res
| `Error y -> `Error (f y)
let map2 f g e = match e with
| `Ok x -> `Ok (f x)
| `Error s -> `Error (g s)
@ -88,16 +92,16 @@ let (>|=) e f = map f e
let (>>=) e f = flat_map f e
let equal eq a b = match a, b with
let equal ?(err=Pervasives.(=)) eq a b = match a, b with
| `Ok x, `Ok y -> eq x y
| `Error s, `Error s' -> s = s'
| `Error s, `Error s' -> err s s'
| _ -> false
let compare cmp a b = match a, b with
let compare ?(err=Pervasives.compare) cmp a b = match a, b with
| `Ok x, `Ok y -> cmp x y
| `Ok _, _ -> 1
| _, `Ok _ -> -1
| `Error s, `Error s' -> String.compare s s'
| `Error s, `Error s' -> err s s'
let fold ~success ~failure x = match x with
| `Ok x -> success x
@ -106,21 +110,24 @@ let fold ~success ~failure x = match x with
(** {2 Wrappers} *)
let guard f =
try
return (f ())
try `Ok (f ())
with e -> `Error e
let guard_str f =
try `Ok (f())
with e -> of_exn e
let wrap1 f x =
try return (f x)
with e -> of_exn e
with e -> `Error e
let wrap2 f x y =
try return (f x y)
with e -> of_exn e
with e -> `Error e
let wrap3 f x y z =
try return (f x y z)
with e -> of_exn e
with e -> `Error e
(** {2 Applicative} *)
@ -141,18 +148,20 @@ let map_l f l =
| `Ok y -> map (y::acc) l'
in map [] l
exception LocalExit of string
exception LocalExit
let fold_seq f acc seq =
let err = ref None in
try
let acc = ref acc in
seq
(fun x -> match f !acc x with
| `Error s -> raise (LocalExit s)
| `Error s -> err := Some s; raise LocalExit
| `Ok y -> acc := y
);
`Ok !acc
with LocalExit s -> `Error s
with LocalExit ->
match !err with None -> assert false | Some s -> `Error s
let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l)
@ -166,26 +175,17 @@ let choose l =
in
try _find l
with Not_found ->
let buf = Buffer.create 32 in
(* print errors on the buffer *)
let rec print buf l = match l with
| `Ok _ :: _ -> assert false
| (`Error x)::((y::xs) as l) ->
Buffer.add_string buf x;
Buffer.add_string buf ", ";
print buf l
| `Error x::[] -> Buffer.add_string buf x
| [] -> ()
in
Printf.bprintf buf "CCError.choice failed: [%a]" print l;
fail (Buffer.contents buf)
let l' = List.map (function `Error s -> s | `Ok _ -> assert false) l in
`Error l'
let rec retry n f = match n with
| 0 -> fail "retry failed"
let retry n f =
let rec retry n acc = match n with
| 0 -> fail (List.rev acc)
| _ ->
match f () with
| `Ok _ as res -> res
| `Error _ -> retry (n-1) f
| `Error e -> retry (n-1) (e::acc)
in retry n []
(** {2 Monadic Operations} *)
@ -205,16 +205,17 @@ module Traverse(M : MONAD) = struct
let sequence_m m = map_m (fun x->x) m
let fold_m f acc e = match e with
| `Error s -> M.return acc
| `Error _ -> M.return acc
| `Ok x -> f acc x >>= fun y -> M.return y
let rec retry_m n f = match n with
| 0 -> M.return (fail "retry failed")
let retry_m n f =
let rec retry n acc = match n with
| 0 -> M.return (fail (List.rev acc))
| _ ->
let x = f () in
x >>= function
| `Ok _ -> x
| `Error _ -> retry_m (n-1) f
f () >>= function
| `Ok x -> M.return (`Ok x)
| `Error e -> retry (n-1) (e::acc)
in retry n []
end
(** {2 Conversions} *)

106
core/CCError.mli
View file

@ -24,7 +24,9 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Error Monad} *)
(** {1 Error Monad}
The variant is polymorphic in the error type since NEXT_RELEASE *)
type 'a sequence = ('a -> unit) -> unit
type 'a equal = 'a -> 'a -> bool
@ -34,90 +36,104 @@ type 'a formatter = Format.formatter -> 'a -> unit
(** {2 Basics} *)
type +'a t =
[ `Ok of 'a
| `Error of string
type (+'good, +'bad) t =
[ `Ok of 'good
| `Error of 'bad
]
val return : 'a -> 'a t
val return : 'a -> ('a,'err) t
(** Successfully return a value *)
val fail : string -> 'a t
val fail : 'err -> ('a,'err) t
(** Fail with an error *)
val of_exn : exn -> 'a t
val of_exn : exn -> ('a, string) t
(** [of_exn e] uses {!Printexc} to print the exception as a string *)
val fail_printf : ('a, Buffer.t, unit, 'a t) format4 -> 'a
val fail_printf : ('a, Buffer.t, unit, ('a,string) t) format4 -> 'a
(** [fail_printf format] uses [format] to obtain an error message
and then returns [`Error msg]
@since 0.3.3 *)
val map : ('a -> 'b) -> 'a t -> 'b t
val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t
(** Map on success *)
val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t
val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t
(** Map on error.
@since NEXT_RELEASE *)
val map2 : ('a -> 'b) -> ('err -> 'err) -> ('a, 'err) t -> ('b, 'err) t
(** Same as {!map}, but also with a function that can transform
the error message in case of failure *)
val iter : ('a -> unit) -> 'a t -> unit
val iter : ('a -> unit) -> ('a, _) t -> unit
(** Apply the function only in case of `Ok *)
val get_exn : 'a t -> 'a
val get_exn : ('a, _) t -> 'a
(** Extract the value [x] from [`Ok x], fails otherwise.
You should be careful with this function, and favor other combinators
whenever possible.
@raise Invalid_argument if the value is an error. *)
val flat_map : ('a -> 'b t) -> 'a t -> 'b t
val flat_map : ('a -> ('b, 'err) t) -> ('a, 'err) t -> ('b, 'err) t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t
val equal : 'a equal -> 'a t equal
val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal
val compare : 'a ord -> 'a t ord
val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord
val fold : success:('a -> 'b) -> failure:(string -> 'b) -> 'a t -> 'b
val fold : success:('a -> 'b) -> failure:('err -> 'b) -> ('a, 'err) t -> 'b
(** [fold ~success ~failure e] opens [e] and, if [e = `Ok x], returns
[success x], otherwise [e = `Error s] and it returns [failure s]. *)
(** {2 Wrappers} *)
(** {2 Wrappers}
val guard : (unit -> 'a) -> 'a t
The functions {!guard}, {!wrap1}, {!wrap2} and {!wrap3} now return
exceptions in case of failure, @since NEXT_RELEASE *)
val guard : (unit -> 'a) -> ('a, exn) t
(** [guard f] runs [f ()] and returns its result wrapped in [`Ok]. If
[f ()] raises some exception [e], then it fails with [`Error msg]
where [msg] is some printing of [e] (see {!register_printer}). *)
[f ()] raises some exception [e], then it fails with [`Error e] *)
val wrap1 : ('a -> 'b) -> 'a -> 'b t
val guard_str : (unit -> 'a) -> ('a, string) t
(** Same as {!guard} but uses {!of_exn} to print the exception.
See {!register_printer} *)
val wrap1 : ('a -> 'b) -> 'a -> ('b, exn) t
(** Same as {!guard} but gives the function one argument. *)
val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t
val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> ('c, exn) t
(** Same as {!guard} but gives the function two arguments. *)
val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t
val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t
(** {2 Applicative} *)
val pure : 'a -> 'a t
val pure : 'a -> ('a, 'err) t
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t
(** {2 Collections} *)
val map_l : ('a -> 'b t) -> 'a list -> 'b list t
val map_l : ('a -> ('b, 'err) t) -> 'a list -> ('b list, 'err) t
val fold_l : ('b -> 'a -> 'b t) -> 'b -> 'a list -> 'b t
val fold_l : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a list -> ('b, 'err) t
val fold_seq : ('b -> 'a -> 'b t) -> 'b -> 'a sequence -> 'b t
val fold_seq : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a sequence -> ('b, 'err) t
(** {2 Misc} *)
val choose : 'a t list -> 'a t
val choose : ('a, 'err) t list -> ('a, 'err list) t
(** [choose l] selects a member of [l] that is a [`Ok _] value,
or returns [`Error msg] otherwise, where [msg] is obtained by
combining the error messages of all elements of [l] *)
or returns [`Error l] otherwise, where [l] is the list of errors. *)
val retry : int -> (unit -> 'a t) -> 'a t
val retry : int -> (unit -> ('a, 'err) t) -> ('a, 'err list) t
(** [retry n f] calls [f] at most [n] times, returning the first result
of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails. *)
of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails
with the list of successive errors. *)
(** {2 Monadic Operations} *)
module type MONAD = sig
@ -127,28 +143,28 @@ module type MONAD = sig
end
module Traverse(M : MONAD) : sig
val sequence_m : 'a M.t t -> 'a t M.t
val sequence_m : ('a M.t, 'err) t -> ('a, 'err) t M.t
val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t
val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> ('a, 'err) t -> 'b M.t
val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t
val map_m : ('a -> 'b M.t) -> ('a, 'err) t -> ('b, 'err) t M.t
val retry_m : int -> (unit -> 'a t M.t) -> 'a t M.t
val retry_m : int -> (unit -> ('a, 'err) t M.t) -> ('a, 'err list) t M.t
end
(** {2 Conversions} *)
val to_opt : 'a t -> 'a option
val to_opt : ('a, _) t -> 'a option
val of_opt : 'a option -> 'a t
val of_opt : 'a option -> ('a, string) t
val to_seq : 'a t -> 'a sequence
val to_seq : ('a, _) t -> 'a sequence
(** {2 IO} *)
val pp : 'a printer -> 'a t printer
val pp : 'a printer -> ('a, string) t printer
val print : 'a formatter -> 'a t formatter
val print : 'a formatter -> ('a, string) t formatter
(** {2 Global Exception Printers}
@ -156,7 +172,7 @@ One can register exception printers here, so they will be used by {!guard},
{!wrap1}, etc. The printers should succeed (print) on exceptions they
can deal with, and re-raise the exception otherwise. For instance
if I register a printer for [Not_found], it could look like:
{[CCError.register_printer
(fun buf exn -> match exn with
| Not_found -> Buffer.add_string buf "Not_found"

8
core/CCFQueue.ml
View file

@ -68,7 +68,7 @@ let rec cons : 'a. 'a -> 'a t -> 'a t
| Shallow (Two (y,z)) -> Shallow (Three (x,y,z))
| Shallow (Three (y,z,z')) ->
_deep 4 (Two (x,y)) _empty (Two (z,z'))
| Deep (_, Zero, middle, tl) -> assert false
| Deep (_, Zero, _middle, _tl) -> assert false
| Deep (n,One y, middle, tl) -> _deep (n+1) (Two (x,y)) middle tl
| Deep (n,Two (y,z), middle, tl) -> _deep (n+1)(Three (x,y,z)) middle tl
| Deep (n,Three (y,z,z'), lazy q', tail) ->
@ -81,7 +81,7 @@ let rec snoc : 'a. 'a t -> 'a -> 'a t
| Shallow (Two (y,z)) -> Shallow (Three (y,z,x))
| Shallow (Three (y,z,z')) ->
_deep 4 (Two (y,z)) _empty (Two (z',x))
| Deep (_,hd, middle, Zero) -> assert false
| Deep (_,_hd, _middle, Zero) -> assert false
| Deep (n,hd, middle, One y) -> _deep (n+1) hd middle (Two(y,x))
| Deep (n,hd, middle, Two (y,z)) -> _deep (n+1) hd middle (Three(y,z,x))
| Deep (n,hd, lazy q', Three (y,z,z')) ->
@ -131,7 +131,7 @@ let rec take_back_exn : 'a. 'a t -> 'a t * 'a
| Shallow (One x) -> empty, x
| Shallow (Two (x,y)) -> _single x, y
| Shallow (Three (x,y,z)) -> Shallow (Two(x,y)), z
| Deep (_, hd, middle, Zero) -> assert false
| Deep (_, _hd, _middle, Zero) -> assert false
| Deep (n, hd, lazy q', One x) ->
if is_empty q'
then Shallow hd, x
@ -206,7 +206,7 @@ let rec nth_exn : 'a. int -> 'a t -> 'a
| 1, Shallow (Three (_,x,_)) -> x
| 2, Shallow (Three (_,_,x)) -> x
| _, Shallow _ -> raise Not_found
| _, Deep (n, l, q, r) ->
| _, Deep (_, l, q, r) ->
if i<_size_digit l
then _nth_digit i l
else

2
core/CCFlatHashtbl.ml
View file

@ -170,7 +170,7 @@ module Make(X : HASHABLE) = struct
| Empty -> ()
| Key (_, _, h_k) when _dib tbl h_k i = 0 ->
() (* stop *)
| Key (k, v, h_k) as bucket ->
| Key (_k, _v, h_k) as bucket ->
assert (_dib tbl h_k i > 0);
(* shift backward *)
tbl.arr.(_pred tbl i) <- bucket;

10
core/CCFun.ml → core/CCFun.cppo.ml
View file

@ -26,7 +26,17 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Basic Functions} *)
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2
external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
external (@@) : ('a -> 'b) -> 'a -> 'b = "%apply"
#else
let (|>) x f = f x
let (@@) f x = f x
#endif
let compose f g x = g (f x)

6
core/CCFun.mli
View file

@ -27,7 +27,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Basic Functions} *)
val (|>) : 'a -> ('a -> 'b) -> 'b
(** Pipeline (naive implementation) *)
(** Pipeline. [x |> f] is the same as [f x]. *)
val compose : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
(** Composition *)
@ -35,6 +35,10 @@ val compose : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
val (%>) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
(** Alias to [compose] *)
val (@@) : ('a -> 'b) -> 'a -> 'b
(** [f @@ x] is the same as [f x], but right-associative.
@since NEXT_RELEASE *)
val id : 'a -> 'a
(** Identity function *)

20
core/CCGen.ml
View file

@ -201,7 +201,7 @@ module type S = sig
[e1, e2, ... ] picks elements in [e1], [e2],
in [e3], [e1], [e2] .... Once a generator is empty, it is skipped;
when they are all empty, and none remains in the input,
their merge is also empty.
their merge is also empty.
For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *)
val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t
@ -384,7 +384,7 @@ let reduce f g =
let acc = match g () with
| None -> raise (Invalid_argument "reduce")
| Some x -> x
in
in
fold f acc g
(* Dual of {!fold}, with a deconstructing operation *)
@ -671,7 +671,7 @@ let drop_while p gen =
| Yield ->
begin match gen () with
| None -> state := Stop; None
| (Some x) as res -> res
| Some _ as res -> res
end
in next
@ -1088,7 +1088,7 @@ let sorted_merge_n ?(cmp=Pervasives.compare) l =
let round_robin ?(n=2) gen =
(* array of queues, together with their index *)
let qs = Array.init n (fun i -> Queue.create ()) in
let qs = Array.init n (fun _ -> Queue.create ()) in
let cur = ref 0 in
(* get next element for the i-th queue *)
let rec next i =
@ -1128,7 +1128,7 @@ let round_robin ?(n=2) gen =
when they are consumed evenly *)
let tee ?(n=2) gen =
(* array of queues, together with their index *)
let qs = Array.init n (fun i -> Queue.create ()) in
let qs = Array.init n (fun _ -> Queue.create ()) in
let finished = ref false in (* is [gen] exhausted? *)
(* get next element for the i-th queue *)
let rec next i =
@ -1139,7 +1139,7 @@ let tee ?(n=2) gen =
else Queue.pop qs.(i)
(* consume one more element *)
and get_next i = match gen() with
| (Some x) as res ->
| Some _ as res ->
for j = 0 to n-1 do
if j <> i then Queue.push res qs.(j)
done;
@ -1158,7 +1158,7 @@ let tee ?(n=2) gen =
module InterleaveState = struct
type 'a t =
| Only of 'a gen
| Only of 'a gen
| Both of 'a gen * 'a gen * bool ref
| Stop
end
@ -1487,7 +1487,7 @@ module Restart = struct
let repeat x () = repeat x
let unfold f acc () = unfold f acc
let unfold f acc () = unfold f acc
let init ?limit f () = init ?limit f
@ -1625,7 +1625,7 @@ module Restart = struct
let of_list l () = of_list l
let to_rev_list e = to_rev_list (e ())
let to_list e = to_list (e ())
let to_array e = to_array (e ())
@ -1678,7 +1678,7 @@ module MList = struct
then begin
prev := cur;
fill next Nil
end else fill prev cur
end else fill prev cur
in
fill start !start ;
!start

18
core/CCGen.mli
View file

@ -28,7 +28,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Values of type ['a Gen.t] represent a possibly infinite sequence of values
of type 'a. One can only iterate once on the sequence, as it is consumed
by iteration/deconstruction/access. [None] is returned when the generator
is exhausted.
is exhausted. Most functions consume elements.
The submodule {!Restart} provides utilities to work with
{b restartable generators}, that is, functions [unit -> 'a Gen.t] that
@ -78,25 +78,27 @@ module type S = sig
(** {2 Basic combinators} *)
val is_empty : _ t -> bool
(** Check whether the enum is empty. *)
(** Check whether the genertor is empty. Consumes one element if the
generator isn't empty. *)
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
(** Fold on the generator, tail-recursively *)
(** Fold on the generator, tail-recursively; consumes it *)
val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a
(** Fold on non-empty sequences (otherwise raise Invalid_argument) *)
(** Fold on non-empty sequences
@raise Invalid_argument if the generator is empty *)
val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t
(** Like {!fold}, but keeping successive values of the accumulator *)
val iter : ('a -> unit) -> 'a t -> unit
(** Iterate on the enum *)
(** Iterate on the generator, consuming it *)
val iteri : (int -> 'a -> unit) -> 'a t -> unit
(** Iterate on elements with their index in the enum, from 0 *)
(** Iterate on elements with their index in the enum, from 0. Consumes it. *)
val length : _ t -> int
(** Length of an enum (linear time) *)
(** Length of a generator (linear time, consumes its input) *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Lazy map. No iteration is performed now, the function will be called
@ -217,7 +219,7 @@ module type S = sig
[e1, e2, ... ] picks elements in [e1], [e2],
in [e3], [e1], [e2] .... Once a generator is empty, it is skipped;
when they are all empty, and none remains in the input,
their merge is also empty.
their merge is also empty.
For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *)
val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t

2
core/CCIO.ml
View file

@ -415,7 +415,7 @@ module Seq = struct
try _yield (input_line ic)
with End_of_file -> _stop()
let words g =
let words _g =
failwith "words: not implemented yet"
(* TODO: state machine that goes:
- 0: read input chunk

2
core/CCInt.ml
View file

@ -37,6 +37,8 @@ let sign i =
else if i>0 then 1
else 0
let neg i = -i
type 'a printer = Buffer.t -> 'a -> unit
type 'a formatter = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a

4
core/CCInt.mli
View file

@ -37,6 +37,10 @@ val hash : t -> int
val sign : t -> int
(** [sign i] is one of [-1, 0, 1] *)
val neg : t -> t
(** [neg i = - i]
@since NEXT_RELEASE *)
type 'a printer = Buffer.t -> 'a -> unit
type 'a formatter = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a

6
core/CCKTree.ml
View file

@ -199,14 +199,14 @@ module Dot = struct
let mk_id format =
let buf = Buffer.create 64 in
Printf.kbprintf
(fun fmt -> `Id (Buffer.contents buf))
(fun _ -> `Id (Buffer.contents buf))
buf
format
let mk_label format =
let buf = Buffer.create 64 in
Printf.kbprintf
(fun fmt -> `Label(Buffer.contents buf))
(fun _ -> `Label(Buffer.contents buf))
buf
format
@ -287,6 +287,6 @@ module Dot = struct
Printf.bprintf buf "}\n";
()
let pp_single name buf t = pp buf (singleton name t)
let pp_single name buf t = pp buf (singleton ~name t)
end

10
core/CCList.ml
View file

@ -51,6 +51,8 @@ let map f l =
List.rev (List.rev_map f l) = map f l)
*)
let (>|=) l f = map f l
let append l1 l2 =
let rec direct i l1 l2 = match l1 with
| [] -> l2
@ -448,7 +450,7 @@ module Assoc = struct
let rec search eq acc l x y = match l with
| [] -> (x,y)::acc
| (x',y')::l' ->
if eq x x'
if eq x x'
then (x,y)::List.rev_append acc l'
else search eq ((x',y')::acc) l' x y
in search eq [] l x y
@ -497,7 +499,7 @@ module Zipper = struct
| l, x::r ->
begin match f (Some x) with
| None -> l,r
| Some x' -> l, x::r
| Some _ -> l, x::r
end
let focused = function
@ -661,7 +663,7 @@ let of_klist l =
let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf l =
let rec print l = match l with
| x::((y::xs) as l) ->
| x::((_::_) as l) ->
pp_item buf x;
Buffer.add_string buf sep;
print l
@ -675,7 +677,7 @@ let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf l =
let print ?(start="[") ?(stop="]") ?(sep=", ") pp_item fmt l =
let rec print fmt l = match l with
| x::((y::xs) as l) ->
| x::((_::_) as l) ->
pp_item fmt x;
Format.pp_print_string fmt sep;
Format.pp_print_cut fmt ();

4
core/CCList.mli
View file

@ -33,6 +33,10 @@ val empty : 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
(** Safe version of map *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
(** Infix version of [map] with reversed arguments
@since NEXT_RELEASE *)
val append : 'a t -> 'a t -> 'a t
(** Safe version of append *)

116
core/CCMap.ml Normal file
View file

@ -0,0 +1,116 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Extensions of Standard Map} *)
type 'a sequence = ('a -> unit) -> unit
type 'a printer = Buffer.t -> 'a -> unit
type 'a formatter = Format.formatter -> 'a -> unit
module type S = sig
include Map.S
val get : key -> 'a t -> 'a option
(** Safe version of {!find} *)
val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
(** [update k f m] calls [f (Some v)] if [find k m = v],
otherwise it calls [f None]. In any case, if the result is [None]
[k] is removed from [m], and if the result is [Some v'] then
[add k v' m] is returned. *)
val of_seq : (key * 'a) sequence -> 'a t
val to_seq : 'a t -> (key * 'a) sequence
val of_list : (key * 'a) list -> 'a t
val to_list : 'a t -> (key * 'a) list
val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
key printer -> 'a printer -> 'a t printer
val print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
key formatter -> 'a formatter -> 'a t formatter
end
module Make(O : Map.OrderedType) = struct
include Map.Make(O)
let get k m =
try Some (find k m)
with Not_found -> None
let update k f m =
let x =
try f (Some (find k m))
with Not_found -> f None
in
match x with
| None -> remove k m
| Some v' -> add k v' m
let of_seq s =
let m = ref empty in
s (fun (k,v) -> m := add k v !m);
!m
let to_seq m yield =
iter (fun k v -> yield (k,v)) m
let of_list l =
List.fold_left
(fun m (k,v) -> add k v m) empty l
let to_list m =
fold (fun k v acc -> (k,v)::acc) m []
let pp ?(start="{") ?(stop="}") ?(arrow="->") ?(sep=", ") pp_k pp_v buf m =
let first = ref true in
Buffer.add_string buf start;
iter
(fun k v ->
if !first then first := false else Buffer.add_string buf sep;
pp_k buf k;
Buffer.add_string buf arrow;
pp_v buf v
) m;
Buffer.add_string buf stop
let print ?(start="[") ?(stop="]") ?(arrow="->") ?(sep=", ") pp_k pp_v fmt m =
Format.pp_print_string fmt start;
let first = ref true in
iter
(fun k v ->
if !first then first := false else Format.pp_print_string fmt sep;
pp_k fmt k;
Format.pp_print_string fmt arrow;
pp_v fmt v;
Format.pp_print_cut fmt ()
) m;
Format.pp_print_string fmt stop
end

59
misc/bencodeOnDisk.mli → core/CCMap.mli
View file

@ -1,6 +1,6 @@
(*
copyright (c) 2013, simon cruanes
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
@ -24,37 +24,42 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Serialize Bencode on disk with persistency guarantees}
(** {1 Extensions of Standard Map}
This module provides an append-only interface to some file, with
synchronized access and fsync() called after every write.
It needs {b Extunix} to compile (needs fsync).
*)
Provide useful functions and iterators on [Map.S]
@since NEXT_RELEASE *)
type t
(** Handle to a file on which we can append values atomically *)
type 'a sequence = ('a -> unit) -> unit
type 'a printer = Buffer.t -> 'a -> unit
type 'a formatter = Format.formatter -> 'a -> unit
val open_out : ?lock:string -> string -> t
(** Open the given file for appending values. Creates the file
if it doesn't exist.
@param lock, if provided, is the name of the lock file used. By default,
the file that is provided for writing is also used for locking.
@raise Unix.Unix_error if some IO error occurs. *)
module type S = sig
include Map.S
val close_out : t -> unit
(** Close the file descriptor *)
val get : key -> 'a t -> 'a option
(** Safe version of {!find} *)
val write : t -> Bencode.t -> unit
(** Write "atomically" a value to the end of the file *)
val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
(** [update k f m] calls [f (Some v)] if [find k m = v],
otherwise it calls [f None]. In any case, if the result is [None]
[k] is removed from [m], and if the result is [Some v'] then
[add k v' m] is returned. *)
val write_batch : t -> Bencode.t list -> unit
(** Write several values at once, at the end of the file *)
val of_seq : (key * 'a) sequence -> 'a t
type 'a result =
| Ok of 'a
| Error of string
val to_seq : 'a t -> (key * 'a) sequence
val read : ?lock:string -> string -> 'a -> ('a -> Bencode.t -> 'a) -> 'a result
(** Fold on values serialized in the given file.
@param lock see {!open_out}.
@raise Unix.Unix_error if some IO error occurs. *)
val of_list : (key * 'a) list -> 'a t
val to_list : 'a t -> (key * 'a) list
val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
key printer -> 'a printer -> 'a t printer
val print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string ->
key formatter -> 'a formatter -> 'a t formatter
end
module Make(O : Map.OrderedType) : S
with type 'a t = 'a Map.Make(O).t
and type key = O.t

6
core/CCMultiMap.ml
View file

@ -167,7 +167,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let union m1 m2 =
M.merge
(fun k v1 v2 -> match v1, v2 with
(fun _k v1 v2 -> match v1, v2 with
| None, None -> None
| Some set1, Some set2 -> Some (S.union set1 set2)
| Some set, None
@ -176,7 +176,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let inter m1 m2 =
M.merge
(fun k v1 v2 -> match v1, v2 with
(fun _k v1 v2 -> match v1, v2 with
| None, _
| _, None -> None
| Some set1, Some set2 ->
@ -188,7 +188,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let diff m1 m2 =
M.merge
(fun k v1 v2 -> match v1, v2 with
(fun _k v1 v2 -> match v1, v2 with
| None, _ -> None
| Some set, None -> Some set
| Some set1, Some set2 ->

8
core/CCMultiSet.ml
View file

@ -117,7 +117,7 @@ module Make(O : Set.OrderedType) = struct
let union m1 m2 =
M.merge
(fun x n1 n2 -> match n1, n2 with
(fun _x n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some n, None
| None, Some n -> Some n
@ -134,7 +134,7 @@ module Make(O : Set.OrderedType) = struct
let intersection m1 m2 =
M.merge
(fun x n1 n2 -> match n1, n2 with
(fun _x n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some _, None
| None, Some _ -> None
@ -143,10 +143,10 @@ module Make(O : Set.OrderedType) = struct
let diff m1 m2 =
M.merge
(fun x n1 n2 -> match n1, n2 with
(fun _x n1 n2 -> match n1, n2 with
| None, None -> assert false
| Some n1, None -> Some n1
| None, Some n2 -> None
| None, Some _n2 -> None
| Some n1, Some n2 ->
if n1 > n2
then Some (n1 - n2)

4
core/CCOpt.ml
View file

@ -84,6 +84,10 @@ let map2 f o1 o2 = match o1, o2 with
| _, None -> None
| Some x, Some y -> Some (f x y)
let filter p = function
| Some x as o when p x -> o
| o -> o
let iter f o = match o with
| None -> ()
| Some x -> f x

5
core/CCOpt.mli
View file

@ -60,6 +60,11 @@ val iter : ('a -> unit) -> 'a t -> unit
val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
(** Fold on 0 or 1 elements *)
val filter : ('a -> bool) -> 'a t -> 'a t
(** Filter on 0 or 1 elements
@since NEXT_RELEASE *)
val get : 'a -> 'a t -> 'a
(** [get default x] unwraps [x], but if [x = None] it returns [default] instead.
@since 0.4.1 *)

2
core/CCPersistentHashtbl.ml
View file

@ -294,7 +294,7 @@ module Make(H : HashedType) : S with type key = H.t = struct
(fun k v2 ->
if not (mem t1 k) then match f k None (Some v2) with
| None -> ()
| Some v' -> Table.replace tbl k v2);
| Some _ -> Table.replace tbl k v2);
ref (Table tbl)
let add_seq init seq =

8
core/CCPrint.ml
View file

@ -38,7 +38,7 @@ type 'a t = Buffer.t -> 'a -> unit
(** {2 Combinators} *)
let silent buf _ = ()
let silent _buf _ = ()
let unit buf () = Buffer.add_string buf "()"
let int buf i = Buffer.add_string buf (string_of_int i)
@ -49,7 +49,7 @@ let float buf f = Buffer.add_string buf (string_of_float f)
let list ?(start="[") ?(stop="]") ?(sep=", ") pp buf l =
let rec pp_list l = match l with
| x::((y::xs) as l) ->
| x::((_::_) as l) ->
pp buf x;
Buffer.add_string buf sep;
pp_list l
@ -116,14 +116,14 @@ let to_string pp x =
let sprintf format =
let buffer = Buffer.create 64 in
Printf.kbprintf
(fun fmt -> Buffer.contents buffer)
(fun _fmt -> Buffer.contents buffer)
buffer
format
let fprintf oc format =
let buffer = Buffer.create 64 in
Printf.kbprintf
(fun fmt -> Buffer.output_buffer oc buffer)
(fun _fmt -> Buffer.output_buffer oc buffer)
buffer
format

8
core/CCSequence.mli
View file

@ -604,7 +604,15 @@ module IO : sig
@param mode default [0o644]
@param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *)
val write_bytes_to : ?mode:int -> ?flags:open_flag list ->
string -> Bytes.t t -> unit
(** @since NEXT_RELEASE *)
val write_lines : ?mode:int -> ?flags:open_flag list ->
string -> string t -> unit
(** Same as {!write_to}, but intercales ['\n'] between each string *)
val write_bytes_lines : ?mode:int -> ?flags:open_flag list ->
string -> Bytes.t t -> unit
(** @since NEXT_RELEASE *)
end

54
core/CCString.ml → core/CCString.cppo.ml
View file

@ -46,6 +46,7 @@ module type S = sig
val to_list : t -> char list
val pp : Buffer.t -> t -> unit
val print : Format.formatter -> t -> unit
end
let equal (a:string) b = a=b
@ -54,10 +55,18 @@ let compare = String.compare
let hash s = Hashtbl.hash s
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2
let init = String.init
#else
let init n f =
let s = String.make n ' ' in
for i = 0 to n-1 do s.[i] <- f i done;
s
let buf = Buffer.create n in
for i = 0 to n-1 do Buffer.add_char buf (f i) done;
Buffer.contents buf
#endif
let length = String.length
@ -167,11 +176,7 @@ let repeat s n =
assert (n>=0);
let len = String.length s in
assert(len > 0);
let buf = String.create (len * n) in
for i = 0 to n-1 do
String.blit s 0 buf (i * len) len;
done;
buf
init (len * n) (fun i -> s.[i mod len])
let prefix ~pre s =
String.length pre <= String.length s &&
@ -212,26 +217,23 @@ let rec _to_klist s i len () =
else `Cons (s.[i], _to_klist s (i+1)(len-1))
let of_klist l =
let rec aux acc n l = match l() with
let b = Buffer.create 15 in
let rec aux l = match l() with
| `Nil ->
let s = String.create n in
let acc = ref acc in
for i=n-1 downto 0 do
s.[i] <- List.hd !acc;
acc := List.tl !acc
done;
s
| `Cons (x,l') -> aux (x::acc) (n+1) l'
in aux [] 0 l
Buffer.contents b
| `Cons (x,l') ->
Buffer.add_char b x;
aux l'
in aux l
let to_klist s = _to_klist s 0 (String.length s)
let to_list s = _to_list s [] 0 (String.length s)
let of_list l =
let s = String.make (List.length l) ' ' in
List.iteri (fun i c -> s.[i] <- c) l;
s
let buf = Buffer.create (List.length l) in
List.iter (Buffer.add_char buf) l;
Buffer.contents buf
(*$T
of_list ['a'; 'b'; 'c'] = "abc"
@ -239,9 +241,7 @@ let of_list l =
*)
let of_array a =
let s = String.make (Array.length a) ' ' in
Array.iteri (fun i c -> s.[i] <- c) a;
s
init (Array.length a) (fun i -> a.(i))
let to_array s =
Array.init (String.length s) (fun i -> s.[i])
@ -251,6 +251,9 @@ let pp buf s =
Buffer.add_string buf s;
Buffer.add_char buf '"'
let print fmt s =
Format.fprintf fmt "\"%s\"" s
module Sub = struct
type t = string * int * int
@ -284,4 +287,7 @@ module Sub = struct
Buffer.add_char buf '"';
Buffer.add_substring buf s i len;
Buffer.add_char buf '"'
let print fmt s =
Format.fprintf fmt "\"%s\"" (copy s)
end

1
core/CCString.mli
View file

@ -50,6 +50,7 @@ module type S = sig
val to_list : t -> char list
val pp : Buffer.t -> t -> unit
val print : Format.formatter -> t -> unit
end
(** {2 Strings} *)

10
core/CCTrie.ml
View file

@ -211,7 +211,7 @@ module Make(W : WORD) = struct
let _remove_sub c t = match t with
| Empty -> t
| Path ([], _) -> assert false
| Path (c'::l, t') ->
| Path (c'::_, _) ->
if W.compare c c' = 0
then Empty
else t
@ -357,7 +357,7 @@ module Make(W : WORD) = struct
| Some v -> f acc v
in
M.fold
(fun c t' acc -> fold_values f acc t')
(fun _c t' acc -> fold_values f acc t')
map acc
let iter_values f t = fold_values (fun () x -> f x) () t
@ -535,9 +535,9 @@ module String = Make(struct
let compare = Char.compare
let to_seq s k = String.iter k s
let of_list l =
let s = String.create (List.length l) in
List.iteri (fun i c -> s.[i] <- c) l;
s
let buf = Buffer.create (List.length l) in
List.iter (fun c -> Buffer.add_char buf c) l;
Buffer.contents buf
end)
(*$T

38
core/CCVector.ml
View file

@ -139,6 +139,11 @@ let append a b =
a.size <- a.size + b.size
)
(*$T
let v1 = init 5 (fun i->i) and v2 = init 5 (fun i->i+5) in \
append v1 v2; to_list v1 = CCList.(0--9)
*)
let get v i =
if i < 0 || i >= v.size then failwith "Vector.get";
Array.unsafe_get v.vec i
@ -159,8 +164,14 @@ let append_seq a seq =
seq (fun x -> push a x)
let append_array a b =
ensure a (a.size + Array.length b);
Array.iter (push a) b
(*$T
let v1 = init 5 (fun i->i) and v2 = Array.init 5 (fun i->i+5) in \
append_array v1 v2; to_list v1 = CCList.(0--9)
*)
let equal eq v1 v2 =
let n = min v1.size v2.size in
let rec check i =
@ -243,6 +254,11 @@ let uniq_sort cmp v =
then traverse v.vec.(0) 1 1
(* start at 1, to get the first element in hand *)
(*$T
let v = of_list [1;4;5;3;2;4;1] in \
uniq_sort Pervasives.compare v; to_list v = [1;2;3;4;5]
*)
let iter k v =
for i = 0 to v.size -1 do
k (Array.unsafe_get v.vec i)
@ -256,10 +272,18 @@ let iteri k v =
let map f v =
if _empty_array v
then create ()
else {
size=v.size;
vec=Array.map f v.vec
}
else (
let vec = Array.init v.size (fun i -> f (Array.unsafe_get v.vec i)) in
{
size=v.size;
vec;
}
)
(*$T
let v = create() in push v 1; push v 2; push v 3; \
to_list (map string_of_int v) = ["1"; "2"; "3"]
*)
let filter' p v =
let i = ref (v.size - 1) in
@ -437,7 +461,7 @@ let of_array a =
let of_list l = match l with
| [] -> create()
| x::l' ->
| x::_ ->
let v = create_with ~capacity:(List.length l + 5) x in
List.iter (push v) l;
v
@ -464,6 +488,10 @@ let to_gen v =
Some x
) else None
(*$T
let v = (1--10) in to_list v = CCGen.to_list (to_gen v)
*)
let of_klist ?(init=create ()) l =
let rec aux l = match l() with
| `Nil -> init

2
core/CCVector.mli
View file

@ -90,7 +90,7 @@ val append_seq : ('a, rw) t -> 'a sequence -> unit
val equal : 'a equal -> ('a,_) t equal
val compare : 'a ord -> ('a,_) t ord
(** Lexicographic comparison *)
(** Total ordering on vectors: Lexicographic comparison. *)
val pop : ('a, rw) t -> 'a option
(** Remove last element, or [None] *)

3
core/META
View file

@ -1,7 +1,8 @@
# OASIS_START
# DO NOT EDIT (digest: caeabec618f289bbaa0522b65bf421f3)
# DO NOT EDIT (digest: e4ab50f4ef28e5ea06e4145c3414c218)
version = "0.4.1"
description = "A modular standard library focused on data structures."
requires = "cppo"
archive(byte) = "containers.cma"
archive(byte, plugin) = "containers.cma"
archive(native) = "containers.cmxa"

3
core/containers.mldylib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: f5cc3719f4c5e3e210a649e32f08ebde)
# DO NOT EDIT (digest: ce5ac7ea3a03a61e3ed7dc10a551b94e)
CCVector
CCDeque
CCGen
@ -30,4 +30,5 @@ CCString
CCHashtbl
CCFlatHashtbl
CCSexp
CCMap
# OASIS_STOP

3
core/containers.mllib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: f5cc3719f4c5e3e210a649e32f08ebde)
# DO NOT EDIT (digest: ce5ac7ea3a03a61e3ed7dc10a551b94e)
CCVector
CCDeque
CCGen
@ -30,4 +30,5 @@ CCString
CCHashtbl
CCFlatHashtbl
CCSexp
CCMap
# OASIS_STOP

159
misc/actionMan.ml
View file

@ -1,159 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {6 Action Language for command line} *)
module Action = struct
type trigger = string
type _ t =
| Return : 'a -> 'a t
| Bind : 'a t * ('a -> 'b t) -> 'b t
| Ignore : ('a t * 'b t) -> 'b t
| Any : string t
| ReadInt : (int -> 'a t) -> 'a t
| ReadString : (string -> 'a t) -> 'a t
| ReadBool : (bool -> 'a t) -> 'a t
| Choice : 'a t list -> 'a t
| Fail : string -> 'a t
let return x = Return x
let (>>=) x f = Bind (x, f)
let (>>) x f = Bind (x, (fun _ -> f ()))
let ( *>) a b = Ignore (a, b)
let ignore x = x *> return ()
let any = Any
let accept trigger =
Any >>= fun x ->
if x = trigger
then return ()
else Fail ("expected trigger \"" ^ trigger ^ "\"")
let with_string ?trigger f =
match trigger with
| None -> ReadString f
| Some t -> accept t *> ReadString f
let with_int ?trigger f =
match trigger with
| None -> ReadInt f
| Some t -> accept t *> ReadInt f
let with_bool ?trigger f =
match trigger with
| None -> ReadBool f
| Some t -> accept t *> ReadBool f
let choice l = Choice l
let repeat act =
let rec try_next acc =
choice
[ act >>= (fun x -> try_next (x::acc))
; return acc
]
in
(try_next []) >>= (fun l -> return (List.rev l))
let opt act =
choice [ act >>= (fun x -> return (Some x)); return None ]
let fail msg = Fail msg
end
type 'a result =
| Ok of 'a
| Error of string
type 'a partial_result =
| POk of 'a * int (* value and position in args *)
| PError of string (* error message *)
let parse_args args (act : 'a Action.t) : 'a result =
let module A = Action in
(* interpret recursively, with backtracking. Returns partial result *)
let rec interpret : type a. string array -> int -> a Action.t -> a partial_result
= fun args i act ->
let n = Array.length args in
match act with
| A.Return x -> POk (x, i)
| A.Bind (x, f) ->
begin match interpret args i x with
| POk (x, i') -> interpret args i' (f x)
| PError msg -> PError msg
end
| A.Ignore (a, b) ->
begin match interpret args i a with
| POk (_, i') -> interpret args i' b
| PError msg -> PError msg
end
| A.Any when i >= n -> mk_error i "expected [any], reached end"
| A.Any -> POk (args.(i), i+1)
| A.ReadInt f when i >= n -> mk_error i "expected [int], reached end"
| A.ReadInt f ->
begin try
let j = int_of_string args.(i) in
interpret args (i+1) (f j)
with Failure _ -> mk_error i "expected [int]"
end
| A.ReadString _ when i >= n -> mk_error i "expected [string], reached end"
| A.ReadString f -> interpret args (i+1) (f args.(i))
| A.ReadBool _ -> failwith "not implemented: read bool" (* TODO *)
| A.Fail msg -> mk_error i msg
| A.Choice l -> try_choices args i [] l
(* try the actions remaining in [l], whenre [errors] is the list
of errors in already tried branches *)
and try_choices : type a. string array -> int -> string list -> a Action.t list -> a partial_result
= fun args i errors l ->
match l with
| [] ->
let msg = Printf.sprintf "choice failed: [%s]" (String.concat " | " errors) in
mk_error i msg
| act::l' ->
begin match interpret args i act with
| POk _ as res -> res (* success! *)
| PError msg ->
try_choices args i (msg :: errors) l'
end
(* report error *)
and mk_error : type a. int -> string -> a partial_result
= fun i msg ->
PError (Printf.sprintf "at arg %d: %s" i msg)
in
match interpret args 1 act with
| POk (x,_) -> Ok x
| PError msg -> Error msg
let parse act = parse_args Sys.argv act
let print_doc oc act =
failwith "print_doc: not implemented"

94
misc/actionMan.mli
View file

@ -1,94 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {6 Action Language for command line} *)
(** {2 Command-line Actions} *)
module Action : sig
type 'a t
(** Action returning a 'a *)
type trigger = string
(** Trigger a given action, based on the next token *)
val return : 'a -> 'a t
(** Return a pure value *)
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** CCSequence of arguments *)
val (>>) : 'a t -> (unit -> 'b t) -> 'b t
(** Same as {! (>>=)}, but ignores the result of left side *)
val ( *>) : 'a t -> 'b t -> 'b t
(** Accept left, then returns right *)
val accept : trigger -> unit t
(** Accept the given trigger, fails otherwise *)
val any : string t
(** Any token *)
val with_string : ?trigger:trigger -> (string -> 'a t) -> 'a t
(** Command that takes a string *)
val with_int : ?trigger:trigger -> (int -> 'a t) -> 'a t
(** Command that takes an integer *)
val with_bool : ?trigger:trigger -> (bool -> 'a t) -> 'a t
val opt : 'a t -> 'a option t
(** Optional action *)
val repeat : 'a t -> 'a list t
(** Repeated action *)
val choice : 'a t list -> 'a t
(** Choice between options. The first option of the list that
does not fail will be the result (backtracking is used!) *)
val ignore : 'a t -> unit t
(** Ignore result *)
val fail : string -> 'a t
(** Fail with given message *)
end
(** {2 Main interface} *)
type 'a result =
| Ok of 'a
| Error of string
val parse_args : string array -> 'a Action.t -> 'a result
(** Parse given command line *)
val parse : 'a Action.t -> 'a result
(** Parse Sys.argv *)
val print_doc : out_channel -> 'a Action.t -> unit
(** Print documentation on given channel *)

363
misc/bencode.ml
View file

@ -1,363 +0,0 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {6 B-encoding} *)
module SMap = Map.Make(String)
type t =
| I of int
| S of string
| L of t list
| D of t SMap.t
let rec eq t1 t2 = match t1, t2 with
| I i1, I i2 -> i1 = i2
| S s1, S s2 -> s1 = s2
| L l1, L l2 ->
(try List.for_all2 eq l1 l2 with Invalid_argument _ -> false)
| D d1, D d2 ->
SMap.equal eq d1 d2
| _ -> false
let hash t = Hashtbl.hash t
let dict_of_list l =
let d = List.fold_left
(fun d (k, v) -> SMap.add k v d)
SMap.empty l
in
D d
(** {2 Serialization (encoding)} *)
(* length of an encoded int, in bytes *)
let _len_int i =
match i with
| 0 -> 1
| _ when i < 0 -> 2 + int_of_float (log10 (float_of_int ~-i))
| _ -> 1 + int_of_float (log10 (float_of_int i))
(* length of an encoded string, in bytes *)
let _len_str s =
_len_int (String.length s) + 1 + String.length s
let rec size t = match t with
| I i -> 2 + _len_int i
| S s -> _len_str s
| L l -> List.fold_left (fun acc i -> acc + size i) 2 l
| D map -> SMap.fold (fun k v acc -> acc + _len_str k + size v) map 2
let write_in_string t buf o =
let pos = ref o in
let rec append t = match t with
| I i -> write_char 'i'; write_int i; write_char 'e'
| S s -> write_str s
| L l ->
write_char 'l';
List.iter append l;
write_char 'e';
| D m ->
write_char 'd';
SMap.iter (fun key t' -> write_str key; append t') m;
write_char 'e'
and write_int i =
let s = string_of_int i in
String.blit s 0 buf !pos (String.length s);
pos := !pos + String.length s
and write_str s =
write_int (String.length s);
write_char ':';
String.blit s 0 buf !pos (String.length s);
pos := !pos + String.length s
and write_char c =
buf.[!pos] <- c;
incr pos
in
append t
let to_string t =
let len = size t in
let s = String.create len in
write_in_string t s 0;
s
let to_buf buf t =
Buffer.add_string buf (to_string t)
let to_chan ch t =
let b = Buffer.create 25 in
to_buf b t;
Buffer.output_buffer ch b
let fmt formatter t =
let b = Buffer.create 25 in
to_buf b t;
Format.pp_print_string formatter (Buffer.contents b)
let rec pretty fmt t = match t with
| I i -> Format.fprintf fmt "%d" i
| S s -> Format.fprintf fmt "@[<h>\"%s\"@]" s
| L l ->
Format.fprintf fmt "@[<hov 2>[@,";
List.iteri (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '); pretty fmt t') l;
Format.fprintf fmt "]@]";
| D d ->
Format.fprintf fmt "@[<hov 2>{@,";
SMap.iter
(fun k t' -> Format.fprintf fmt "%a -> %a@ " pretty (S k) pretty t')
d;
Format.fprintf fmt "}@]";
()
let pretty_to_str t =
let b = Buffer.create 15 in
Format.fprintf (Format.formatter_of_buffer b) "%a@?" pretty t;
Buffer.contents b
(** {2 Deserialization (decoding)} *)
(** Deserialization is based on the {! decoder} type. Parsing can be
incremental, in which case the input is provided chunk by chunk and
the decoder contains the parsing state. Once a B-encoded value
has been parsed, other values can still be read. *)
type decoder = {
mutable buf : string; (* buffer *)
mutable i : int; (* index in buf *)
mutable len : int; (* length of substring to read *)
mutable c : int; (* line *)
mutable l : int; (* column *)
mutable state : parse_result;
mutable stack : partial_state list;
}
(** Result of parsing *)
and parse_result =
| ParseOk of t
| ParseError of string
| ParsePartial
(** Partial state of the parser *)
and partial_state =
| PS_I of bool * int (* sign and integer *)
| PS_S of int ref * string (* index in string, plus string *)
| PS_L of t list
| PS_D of t SMap.t (* in dictionary *)
| PS_D_key of string * t SMap.t (* parsed key, wait for value *)
| PS_return of t (* bottom of stack *)
| PS_error of string (* error *)
let mk_decoder () =
let dec = {
buf = "";
i = 0;
len = 0;
c = 0;
l = 0;
state = ParsePartial;
stack = [];
} in
dec
let is_empty dec = dec.len = 0
let cur dec = dec.buf.[dec.i]
let junk dec =
(* update line/column *)
(if cur dec = '\n'
then (dec.c <- 0; dec.l <- dec.l + 1)
else dec.c <- dec.c + 1);
dec.i <- dec.i + 1;
dec.len <- dec.len - 1
let next dec =
let c = cur dec in
junk dec;
c
(* parse value *)
let rec parse_rec dec =
match dec.stack with
| [PS_return v] -> (* return value *)
dec.stack <- [];
dec.state <- ParseOk v;
dec.state
| [PS_error s] -> (* failure *)
dec.stack <- [];
dec.state <- ParseError s;
dec.state
| _ ->
if is_empty dec then ParsePartial (* wait *)
else begin
let c = next dec in
(match dec.stack, c with
| (PS_I (sign, i)) :: stack, '0' .. '9' ->
dec.stack <- PS_I (sign, (Char.code c - Char.code '0') + 10 * i) :: stack;
| (PS_I (_, 0)) :: stack, '-' ->
dec.stack <- PS_I (false, 0) :: stack (* negative number *)
| (PS_I (sign, i)) :: stack, 'e' ->
dec.stack <- stack;
push_value dec (I (if sign then i else ~- i))
| ((PS_D _ | PS_D_key _ | PS_L _) :: _ | []), '0' .. '9' ->
(* initial length of string *)
dec.stack <- (PS_I (true, Char.code c - Char.code '0')) :: dec.stack
| (PS_I (sign, i)) :: stack, ':' ->
if i < 0
then error dec "string length cannot be negative"
else if i = 0 then (* empty string *)
let _ = dec.stack <- stack in
push_value dec (S "")
else (* prepare to parse a string *)
dec.stack <- (PS_S (ref 0, String.create i)) :: stack;
| (PS_S (n, s)) :: stack, _ ->
s.[!n] <- c;
incr n;
(* value completed *)
(if !n = String.length s
then
let _ = dec.stack <- stack in
push_value dec (S s));
| stack, 'i' ->
dec.stack <- (PS_I (true, 0)) :: stack
| stack, 'l' ->
dec.stack <- PS_L [] :: stack;
| stack, 'd' ->
dec.stack <- PS_D SMap.empty :: stack
| (PS_L l) :: stack, 'e' -> (* end of list *)
dec.stack <- stack;
push_value dec (L (List.rev l))
| (PS_D d) :: stack, 'e' -> (* end of dict *)
dec.stack <- stack;
push_value dec (D d)
| (PS_D_key _) :: _, 'e' -> (* error *)
error dec "missing value in dict"
| _ -> (* generic error *)
error dec (Printf.sprintf "expected value, got %c" c));
parse_rec dec
end
(* When a value is parsed, push it on the stack (possibly collapsing it) *)
and push_value dec v =
match v, dec.stack with
| _, [] ->
dec.stack <- [PS_return v] (* finished *)
| _, (PS_L l) :: stack ->
(* add to list *)
dec.stack <- (PS_L (v :: l)) :: stack;
| S key, ((PS_D d) :: stack) ->
(* new key for the map *)
dec.stack <- (PS_D_key (key, d)) :: stack;
| _, ((PS_D d) :: _) ->
(* error: key must be string *)
error dec "dict keys must be strings"
| _, (PS_D_key (key, d)) :: stack ->
(* new binding for the map *)
dec.stack <- (PS_D (SMap.add key v d)) :: stack;
| _ -> assert false
(* signal error *)
and error dec msg =
let msg = Printf.sprintf "Bencode: error at line %d, column %d: %s"
dec.l dec.c msg in
dec.stack <- [PS_error msg]
(* exported parse function *)
let parse dec s i len =
(if i < 0 || i+len > String.length s
then invalid_arg "Bencode.parse: not a valid substring");
(* add the input to [dec] *)
if dec.len = 0
then begin
dec.buf <- String.copy s;
dec.i <- i;
dec.len <- len;
end else begin
(* use a buffer to merge the stored input and the new input *)
let buf' = String.create (dec.len + len - dec.i) in
String.blit dec.buf dec.i buf' 0 dec.len;
String.blit s i buf' dec.len len;
dec.buf <- buf';
dec.i <- 0;
dec.len <- dec.len + len - dec.i;
end;
(* state machine *)
parse_rec dec
let parse_resume d = parse_rec d
let reset dec =
dec.l <- 0;
dec.c <- 0;
dec.i <- 0;
dec.len <- 0;
dec.state <- ParsePartial;
dec.stack <- [];
()
let state dec = dec.state
let rest dec =
String.sub dec.buf dec.i dec.len
let rest_size dec =
dec.len
let parse_string s =
let dec = mk_decoder () in
parse dec s 0 (String.length s)
let of_string s =
match parse_string s with
| ParseOk t -> t
| ParsePartial -> invalid_arg "Bencode: partial parse"
| ParseError msg -> invalid_arg msg
(** {2 Iterator} *)
type 'a sequence = ('a -> unit) -> unit
let of_seq seq =
fun k ->
let decoder = mk_decoder () in
(* read a string *)
let rec read_chunk str =
match parse decoder str 0 (String.length str) with
| ParseOk v ->
k v; (* yield, and parse the rest of the string *)
resume ()
| ParseError e -> raise (Invalid_argument e)
| ParsePartial -> () (* wait for next chunk *)
and resume () = match parse_resume decoder with
| ParseOk v ->
k v;
resume ()
| ParseError e -> raise (Invalid_argument e)
| ParsePartial -> () (* wait for next chunk *)
in
seq read_chunk
let to_seq seq =
fun k -> seq (fun b -> k (to_string b))

130
misc/bencode.mli
View file

@ -1,130 +0,0 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {6 B-encoding} *)
(** This implements encoding and decoding using the {i B-encode} format.
See {{: http://en.wikipedia.org/wiki/Bencode} wikipedia} for more details
*)
module SMap : Map.S with type key = string
type t =
| I of int
| S of string
| L of t list
| D of t SMap.t
val eq : t -> t -> bool
val hash : t -> int
val dict_of_list : (string * t) list -> t
(** {2 Serialization (encoding)} *)
val size : t -> int
(** Size needed for serialization *)
val write_in_string : t -> string -> int -> unit
(** [write_in_string v buf o] writes the value [v] in the string,
starting at offset [o]. The portion of the string starting from [o]
must be big enough (ie >= [size v]) *)
val to_buf : Buffer.t -> t -> unit
val to_string : t -> string
val to_chan : out_channel -> t -> unit
val fmt : Format.formatter -> t -> unit
val pretty : Format.formatter -> t -> unit
(** Print the tree itself, not its encoding *)
val pretty_to_str : t -> string
(** Print the tree into a string *)
(** {2 Deserialization (decoding)} *)
(** Deserialization is based on the {! decoder} type. Parsing can be
incremental, in which case the input is provided chunk by chunk and
the decoder contains the parsing state. Once a B-encoded value
has been parsed, other values can still be read.
This implementation does accept leading zeros, because it simplifies
the code. *)
type decoder
(** Decoding state *)
val mk_decoder : unit -> decoder
(** Create a new decoder *)
type parse_result =
| ParseOk of t
| ParseError of string
| ParsePartial
val parse : decoder -> string -> int -> int -> parse_result
(** [parse dec s i len] uses the partial state stored in [dec] and
the substring of [s] starting at index [i] with length [len].
It can return an error, a value or just [ParsePartial] if
more input is needed *)
val parse_resume : decoder -> parse_result
(** Resume where the previous call to {!parse} stopped (may have
returned a value while some input is not processed) *)
val reset : decoder -> unit
(** Reset the decoder to its pristine state, ready to parse something
different. Before that, {! rest} and {! rest_size} can be used
to recover the part of the input that has not been consumed yet. *)
val state : decoder -> parse_result
(** Current state of the decoder *)
val rest : decoder -> string
(** What remains after parsing (the additional, unused input) *)
val rest_size : decoder -> int
(** Length of [rest d]. 0 indicates that the whole input has been consumed. *)
val parse_string : string -> parse_result
(** Parse a full value from this string. *)
val of_string : string -> t
(** Parse the string. @raise Invalid_argument if it fails to parse. *)
(** {2 Iterator} *)
type 'a sequence = ('a -> unit) -> unit
val of_seq : string sequence -> t sequence
(** Given a sequence of strings into Bencode values. Strings can be
the result of {!Unix.read}, for instance, they don't need to be
valid bencode individually; Only their concatenation should
be a valid stream of Bencode values.
@raise Invalid_argument if a parsing error occurs. *)
val to_seq : t sequence -> string sequence
(** Serialize each value in the sequence of Bencode values *)

136
misc/bencodeOnDisk.ml
View file

@ -1,136 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Serialize Bencode on disk with persistency guarantees}
This module provides an append-only interface to some file, with
synchronized access and fsync() called after every write.
It currently uses [Unix.O_SYNC] to guarantee that writes are saved to
the disk, so {b WRITES ARE SLOW}. On the other hand, several
processes can access the same file and append data without risks of
losing written values or race conditions.
Similarly, reads are atomic (require locking) and provide only
a fold interface.
*)
type t = {
file : Unix.file_descr;
lock_file : Unix.file_descr;
}
let open_out ?lock filename =
let lock = match lock with
| None -> filename
| Some l -> l
in
let lock_file = Unix.openfile lock [Unix.O_CREAT; Unix.O_WRONLY] 0o644 in
let file = Unix.openfile filename
[Unix.O_CREAT; Unix.O_APPEND; Unix.O_WRONLY; Unix.O_SYNC] 0o644
in
{ file; lock_file; }
let close_out out =
Unix.close out.file
let write_string out s =
Unix.lockf out.lock_file Unix.F_LOCK 0;
try
(* go to the end of the file *)
ignore (Unix.lseek out.file 0 Unix.SEEK_END);
(* call write() until everything is written *)
let rec write_all n =
if n >= String.length s
then ()
else
let n' = n + Unix.write out.file s n (String.length s - n) in
write_all n'
in
write_all 0;
Unix.lockf out.lock_file Unix.F_ULOCK 0;
with e ->
(* unlock in any case *)
Unix.lockf out.lock_file Unix.F_ULOCK 0;
raise e
let write out b =
let s = Bencode.to_string b in
write_string out s
let write_batch out l =
let buf = Buffer.create 255 in
List.iter (fun b -> Bencode.to_buf buf b) l;
let s = Buffer.contents buf in
write_string out s
type 'a result =
| Ok of 'a
| Error of string
let read ?lock filename acc f =
let lock = match lock with
| None -> filename
| Some l -> l
in
(* lock file before reading, to observe a consistent state *)
let lock_file = Unix.openfile lock [Unix.O_CREAT; Unix.O_RDONLY] 0o644 in
Unix.lockf lock_file Unix.F_RLOCK 0;
try
let file = Unix.openfile filename [Unix.O_RDONLY] 0o644 in
(* read bencode values *)
let decoder = Bencode.mk_decoder () in
let len = 256 in
let buf = String.create len in
(* read a chunk of input and parse it *)
let rec next_val acc =
let n = Unix.read file buf 0 len in
if n = 0
then Ok acc (* finished *)
else match Bencode.parse decoder buf 0 n with
| Bencode.ParseOk v ->
let acc = f acc v in
resume acc
| Bencode.ParseError e -> Error e
| Bencode.ParsePartial -> next_val acc
(* consume what remains of input *)
and resume acc = match Bencode.parse_resume decoder with
| Bencode.ParseOk v ->
let acc = f acc v in
resume acc
| Bencode.ParseError e -> Error e
| Bencode.ParsePartial -> next_val acc
in
let res = next_val acc in
(* cleanup *)
Unix.close file;
Unix.lockf lock_file Unix.F_ULOCK 0;
Unix.close lock_file;
res
with e ->
Unix.lockf lock_file Unix.F_ULOCK 0;
Unix.close lock_file;
raise e

156
misc/bencodeStream.ml
View file

@ -1,156 +0,0 @@
(*
copyright (c) 2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Full-Streaming API of Bencode} *)
type token =
| Int of int
| String of string
| BeginDict
| BeginList
| End
module Encode = struct
type sink =
[ `File of string
| `Out of out_channel
| `Buf of Buffer.t
]
type t = {
write_string : string -> unit;
write_char : char -> unit;
on_close : unit -> unit;
}
let nop() = ()
let create = function
| `Out o ->
{ write_string=output_string o
; write_char=output_char o
; on_close = nop
}
| `File f ->
let o = open_out f in
{ write_string=output_string o
; write_char=output_char o
; on_close = (fun () -> close_out o)
}
| `Buf b ->
{ write_string=Buffer.add_string b
; write_char=Buffer.add_char b
; on_close =nop
}
let push out tok = match tok with
| Int i ->
out.write_char 'i';
out.write_string (string_of_int i);
out.write_char 'e'
| String s ->
out.write_string (string_of_int (String.length s));
out.write_char ':';
out.write_string s
| BeginDict ->
out.write_char 'd'
| End ->
out.write_char 'e'
| BeginList ->
out.write_char 'l'
end
module Decode = struct
type result =
| Yield of token
| Error of string
| Await (** The user needs to call {!feed} with some input *)
type state =
| Start
| ParsingInt of int
| ParsingString of string
type t = {
mutable buf : string; (* buffer *)
mutable i : int; (* index in buf *)
mutable len : int; (* length of substring to read *)
mutable c : int; (* line *)
mutable l : int; (* column *)
mutable state : state;
}
let create () = {
buf = "";
i = 0;
len = 0;
c = 0;
l = 0;
state = Start;
}
let is_empty dec = dec.len = 0
let cur dec = dec.buf.[dec.i]
let junk dec =
(* update line/column *)
(if cur dec = '\n'
then (dec.c <- 0; dec.l <- dec.l + 1)
else dec.c <- dec.c + 1);
dec.i <- dec.i + 1;
dec.len <- dec.len - 1
let next dec =
let c = cur dec in
junk dec;
c
(*
(* parse value *)
let rec parse_rec dec =
if is_empty dec then Await (* wait *)
else begin
let c = next dec in
match dec.state, c with
| Start, 'l' ->
Yield StartList
| Start, 'd' ->
Yield StartDict
| Start, 'e' ->
Yield End
| Start, 'i' ->
dec.state <- ParsingInt 0
| ParsingString i, 'e' ->
dec.state <- Start;
Yield (Int i)
|
*)
let feed dec = assert false
let next dec = assert false
end

13
misc/bencode_write_par.sh
View file

@ -1,13 +0,0 @@
#!/bin/sh
# call n instances of ./bencode_write.native on the same file
N=$1
FILE=$2
echo "call script $N times on file $FILE"
for i in `seq $N` ; do
./bencode_write.native "$FILE" &
done
wait

136
misc/bij.ml
View file

@ -105,139 +105,3 @@ let hashtbl ma mb =
List.iter (fun (k,v) -> Hashtbl.add h k v) l;
h)
(list_ (pair ma mb))
(** {2 Translations} *)
module TrBencode = struct
module B = Bencode
let rec encode: type a. bij:a t -> a -> B.t =
fun ~bij x -> match bij, x with
| Unit, () -> B.I 0
| String, s -> B.S s
| Int, i -> B.I i
| Float, f -> B.S (string_of_float f)
| Bool, b -> B.I (if b then 1 else 0)
| List bij', l ->
let l' = List.map (fun x -> encode ~bij:bij' x) l in
B.L l'
| Many bij', [] -> raise (EncodingError "many: got empty list")
| Many bij', l ->
let l' = List.map (fun x -> encode ~bij:bij' x) l in
B.L l'
| Opt bij', None -> B.L []
| Opt bij', Some x -> B.L [encode ~bij:bij' x]
| Pair (bija, bijb), (a, b) ->
B.L [encode ~bij:bija a; encode ~bij:bijb b]
| Triple (bija, bijb, bijc), (a, b, c) ->
B.L [encode ~bij:bija a; encode ~bij:bijb b; encode ~bij:bijc c]
| Quad (bija, bijb, bijc, bijd), (a, b, c, d) ->
B.L [encode ~bij:bija a; encode ~bij:bijb b;
encode ~bij:bijc c; encode ~bij:bijd d]
| Quint (bija, bijb, bijc, bijd, bije), (a, b, c, d, e) ->
B.L [encode ~bij:bija a; encode ~bij:bijb b;
encode ~bij:bijc c; encode ~bij:bijd d;
encode ~bij:bije e]
| Guard (check, bij'), x ->
if not (check x) then raise (EncodingError "check failed");
encode ~bij:bij' x
| Map (inject, _, bij'), x ->
encode ~bij:bij' (inject x)
| Switch (inject, _), x ->
let key, BranchTo (bij',y) = inject x in
B.D (B.SMap.singleton key (encode ~bij:bij' y))
let rec decode: type a. bij:a t -> B.t -> a
= fun ~bij b -> match bij, b with
| Unit, B.I 0 -> ()
| String, B.S s -> s
| Int, B.I i -> i
| Float, B.S s ->
begin try
let f = float_of_string s in
f
with Failure _ ->
raise (DecodingError "expected float")
end
| Bool, B.I 0 -> false
| Bool, B.I _ -> true
| List bij', B.L l ->
List.map (fun b -> decode ~bij:bij' b) l
| Many bij', B.L [] ->
raise (DecodingError "expected nonempty list")
| Many bij', B.L l ->
List.map (fun b -> decode ~bij:bij' b) l
| Opt bij', B.L [] -> None
| Opt bij', B.L [x] -> Some (decode ~bij:bij' x)
| Opt bij', B.L _ ->
raise (DecodingError "expected [] or [_]")
| Pair (bija, bijb), B.L [a; b] ->
decode ~bij:bija a, decode ~bij:bijb b
| Triple (bija, bijb, bijc), B.L [a; b; c] ->
decode ~bij:bija a, decode ~bij:bijb b, decode ~bij:bijc c
| Quad (bija, bijb, bijc, bijd), B.L [a; b; c; d] ->
decode ~bij:bija a, decode ~bij:bijb b,
decode ~bij:bijc c, decode ~bij:bijd d
| Quint (bija, bijb, bijc, bijd, bije), B.L [a; b; c; d; e] ->
decode ~bij:bija a, decode ~bij:bijb b,
decode ~bij:bijc c, decode ~bij:bijd d,
decode ~bij:bije e
| Guard (check, bij'), x ->
let y = decode ~bij:bij' x in
if not (check y) then raise (DecodingError "check failed");
y
| Map (_, extract, bij'), b ->
let x = decode ~bij:bij' b in
extract x
| Switch (_, extract), B.D d when B.SMap.cardinal d = 1 ->
let key, value = B.SMap.choose d in
let BranchFrom (bij', convert) = extract key in
convert (decode ~bij:bij' value)
| _ -> raise (DecodingError "bad case")
let to_string ~bij x = B.to_string (encode ~bij x)
let of_string ~bij s =
let b = B.of_string s in
decode ~bij b
let read ~bij ic =
let d = B.mk_decoder () in
let buf = String.create 256 in
let rec read_chunk() =
let n = input ic buf 0 (String.length buf) in
if n = 0
then raise (DecodingError "unexpected EOF")
else match B.parse d buf 0 n with
| B.ParsePartial -> read_chunk()
| B.ParseError s -> raise (DecodingError s)
| B.ParseOk b -> decode ~bij b
in
read_chunk()
let read_stream ~bij ic =
let d = B.mk_decoder () in
let buf = String.create 256 in
let rec try_parse n = match B.parse d buf 0 n with
| B.ParsePartial -> read_chunk()
| B.ParseError s -> raise (DecodingError s)
| B.ParseOk b -> Some (decode ~bij b)
and read_chunk() =
let n = input ic buf 0 (String.length buf) in
if n = 0
then match B.parse_resume d with
| B.ParsePartial -> None
| B.ParseError s -> raise (DecodingError s)
| B.ParseOk b -> Some (decode ~bij b)
else try_parse n
in
Stream.from (fun _ -> read_chunk())
let write ~bij oc x =
let b = encode ~bij x in
B.to_chan oc b;
flush oc
let write_stream ~bij oc str =
Stream.iter (fun x -> write ~bij oc x) str
end

22
misc/bij.mli
View file

@ -163,25 +163,3 @@ exception EncodingError of string
exception DecodingError of string
(** Raised when decoding is impossible *)
(** {2 Translations} *)
module TrBencode : sig
val encode : bij:'a t -> 'a -> Bencode.t
val decode : bij:'a t -> Bencode.t -> 'a
val to_string : bij:'a t -> 'a -> string
val of_string : bij:'a t -> string -> 'a
val read : bij:'a t -> in_channel -> 'a
(** Read a single value from the channel *)
val read_stream : bij:'a t -> in_channel -> 'a Stream.t
val write : bij:'a t -> out_channel -> 'a -> unit
val write_stream : bij:'a t -> out_channel -> 'a Stream.t -> unit
end

8
misc/containers_misc.mlpack
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 9851db0fe3105f1a9f67c941d62c467a)
# DO NOT EDIT (digest: 77c9e2e3233437cee692be334bdaa224)
Cache
FHashtbl
FlatHashtbl
@ -14,14 +14,11 @@ SplayMap
Univ
Bij
PiCalculus
Bencode
RAL
UnionFind
SmallSet
AbsSet
CSM
ActionMan
BencodeOnDisk
TTree
PrintBox
HGraph
@ -31,9 +28,6 @@ Bidir
Iteratee
BTree
Ty
Tell
BencodeStream
RatTerm
Cause
AVL
ParseReact

4
misc/json.ml
View file

@ -79,7 +79,6 @@ let parse chars =
read_list (t::acc) (* next *)
| Some (Genlex.Kwd "]") ->
read_list (t::acc) (* next *)
| Some (Genlex.Kwd "]") -> List.rev acc (* yield *)
| _ -> raise (Stream.Error "expected ','"))
and read_pairs acc =
match peek tokens with
@ -163,7 +162,8 @@ let rec pp fmt t =
let to_string t =
let buf = Buffer.create 16 in
Format.bprintf buf "%a@?" pp t;
let fmt = Format.formatter_of_buffer buf in
Format.fprintf fmt "%a@?" pp t;
Buffer.contents buf
(** {2 Utils *)

28
misc/printBox.ml
View file

@ -36,7 +36,7 @@ let _minus pos1 pos2 = _move pos1 (- pos2.x) (- pos2.y)
let _move_x pos x = _move pos x 0
let _move_y pos y = _move pos 0 y
let _string_len = ref String.length
let _string_len = ref Bytes.length
let set_string_len f = _string_len := f
@ -61,11 +61,11 @@ module Output = struct
mutable buf_len : int;
}
and buf_line = {
mutable bl_str : string;
mutable bl_str : Bytes.t;
mutable bl_len : int;
}
let _make_line _ = {bl_str=""; bl_len=0}
let _make_line _ = {bl_str=Bytes.empty; bl_len=0}
let _ensure_lines buf i =
if i >= Array.length buf.buf_lines
@ -78,8 +78,8 @@ module Output = struct
let _ensure_line line i =
if i >= !_string_len line.bl_str
then (
let str' = String.make (2 * i + 5) ' ' in
String.blit line.bl_str 0 str' 0 line.bl_len;
let str' = Bytes.make (2 * i + 5) ' ' in
Bytes.blit line.bl_str 0 str' 0 line.bl_len;
line.bl_str <- str';
)
@ -88,7 +88,7 @@ module Output = struct
_ensure_line buf.buf_lines.(pos.y) pos.x;
buf.buf_len <- max buf.buf_len (pos.y+1);
let line = buf.buf_lines.(pos.y) in
line.bl_str.[pos.x] <- c;
Bytes.set line.bl_str pos.x c;
line.bl_len <- max line.bl_len (pos.x+1)
let _buf_put_sub_string buf pos s s_i s_len =
@ -100,7 +100,7 @@ module Output = struct
line.bl_len <- max line.bl_len (pos.x+s_len)
let _buf_put_string buf pos s =
_buf_put_sub_string buf pos s 0 (!_string_len s)
_buf_put_sub_string buf pos s 0 (!_string_len (Bytes.unsafe_of_string s))
(* create a new buffer *)
let make_buffer () =
@ -121,7 +121,7 @@ module Output = struct
for i = 0 to buf.buf_len - 1 do
for k = 1 to indent do Buffer.add_char buffer ' ' done;
let line = buf.buf_lines.(i) in
Buffer.add_substring buffer line.bl_str 0 line.bl_len;
Buffer.add_substring buffer (Bytes.unsafe_to_string line.bl_str) 0 line.bl_len;
Buffer.add_char buffer '\n';
done;
Buffer.contents buffer
@ -238,7 +238,7 @@ module Box = struct
| Empty -> origin
| Text l ->
let width = List.fold_left
(fun acc line -> max acc (!_string_len line)) 0 l
(fun acc line -> max acc (!_string_len (Bytes.unsafe_of_string line))) 0 l
in
{ x=width; y=List.length l; }
| Frame t ->
@ -337,7 +337,7 @@ let tree ?(indent=1) node children =
let children =
List.filter
(function
| {Box.shape=Box.Empty} -> false
| {Box.shape=Box.Empty; _} -> false
| _ -> true
) children
in
@ -384,10 +384,10 @@ let rec _render ?(offset=origin) ?expected_size ~out b pos =
Output.put_char out (_move pos (x+1) (y+1)) '+';
Output.put_char out (_move pos 0 (y+1)) '+';
Output.put_char out (_move pos (x+1) 0) '+';
_write_hline out (_move_x pos 1) x;
_write_hline out (_move pos 1 (y+1)) x;
_write_vline out (_move_y pos 1) y;
_write_vline out (_move pos (x+1) 1) y;
_write_hline ~out (_move_x pos 1) x;
_write_hline ~out (_move pos 1 (y+1)) x;
_write_vline ~out (_move_y pos 1) y;
_write_vline ~out (_move pos (x+1) 1) y;
_render ~out b' (_move pos 1 1)
| Box.Pad (dim, b') ->
let expected_size = Box.size b in

2
misc/printBox.mli
View file

@ -72,7 +72,7 @@ we go toward the bottom (same order as a printer) *)
val origin : position
(** Initial position *)
val set_string_len : (string -> int) -> unit
val set_string_len : (Bytes.t -> int) -> unit
(** Set which function is used to compute string length. Typically
to be used with a unicode-sensitive length function *)

111
misc/tell.ml
View file

@ -1,111 +0,0 @@
(*
copyright (c) 2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Hierarchic logging} *)
module BS = BencodeStream
type t = {
name : string;
out : out_channel;
encoder : BS.Encode.t;
cleanup : bool;
mutable context : string list;
}
let __new_name =
let r = ref 0 in
fun () ->
let name = Printf.sprintf "Tell.log_%d" !r in
incr r;
name
let to_chan ?(cleanup=false) o = {
name = __new_name ();
out = o;
encoder = BS.Encode.create (`Out o);
cleanup;
context = [];
}
let to_file filename =
let o = open_out filename in
to_chan ~cleanup:true o
let close log =
if log.cleanup
then close_out log.out
let step log msg =
BS.Encode.push log.encoder BS.BeginDict;
BS.Encode.push log.encoder (BS.String "step");
BS.Encode.push log.encoder (BS.String msg);
BS.Encode.push log.encoder BS.End
let enter log =
BS.Encode.push log.encoder BS.BeginList
let exit log =
BS.Encode.push log.encoder BS.End
let within ~log f =
BS.Encode.push log.encoder BS.BeginDict;
BS.Encode.push log.encoder (BS.String "section");
try
let x = f () in
BS.Encode.push log.encoder BS.End;
x
with e ->
BS.Encode.push log.encoder BS.End;
raise e
module B = struct
let step ~log format =
exit log;
let b = Buffer.create 24 in
Printf.kbprintf
(fun b ->
BS.Encode.push log.encoder (BS.String (Buffer.contents b)))
b format
let enter ~log format =
let b = Buffer.create 24 in
let x = Printf.kbprintf
(fun b ->
BS.Encode.push log.encoder (BS.String (Buffer.contents b)))
b format
in
enter log;
x
let exit ~log format =
exit log;
let b = Buffer.create 24 in
Printf.kbprintf
(fun b ->
BS.Encode.push log.encoder (BS.String (Buffer.contents b)))
b format
end

73
misc/tell.mli
View file

@ -1,73 +0,0 @@
(*
copyright (c) 2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Hierarchic logging} *)
type t
val to_file : string -> t
(** Create a logger that outputs to the given file *)
val to_chan : ?cleanup:bool -> out_channel -> t
(** Obtain a logger that outputs to the given channel.
@param cleanup if true, will close the channel on exit;
if false or not explicited, won't do anything. *)
(** {2 Raw functions} *)
val step : t -> string -> unit
val close : t -> unit
(** Close the logger. It will be unusable afterwards. *)
(** {2 Hierarchy} *)
val enter : t -> unit
(** Enter a new subsection *)
val exit : t -> unit
(** Exit the current subsection *)
val within : log:t -> (unit -> 'a) -> 'a
(** Enter a new subsection, evaluate the given function,
exit the subsection and return the function's result.
Also protects against exceptions. *)
(** {2 Buffer-formatting output}
The following functions use a {!Buffer.t} to create the message,
then send it to their logger. *)
module B : sig
val enter : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a
(** Enter a new (sub-)section with the given message *)
val exit : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a
(** Exit (close) the current sub-section. *)
val step : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a
(** Unit step within the current section *)
end

133
myocamlbuild.ml
View file

@ -1,5 +1,5 @@
(* OASIS_START *)
(* DO NOT EDIT (digest: 2ec2194dcebadfa4593677936942ece3) *)
(* DO NOT EDIT (digest: 533979157febab9fa15b0b406be9633e) *)
module OASISGettext = struct
(* # 22 "src/oasis/OASISGettext.ml" *)
@ -249,6 +249,9 @@ module MyOCamlbuildFindlib = struct
*)
open Ocamlbuild_plugin
type conf =
{ no_automatic_syntax: bool;
}
(* these functions are not really officially exported *)
let run_and_read =
@ -315,7 +318,7 @@ module MyOCamlbuildFindlib = struct
(* This lists all supported packages. *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list"))
(* Mock to list available syntaxes. *)
@ -338,7 +341,7 @@ module MyOCamlbuildFindlib = struct
]
let dispatch =
let dispatch conf =
function
| After_options ->
(* By using Before_options one let command line options have an higher
@ -357,31 +360,39 @@ module MyOCamlbuildFindlib = struct
* -linkpkg *)
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter
begin fun pkg ->
let base_args = [A"-package"; A pkg] in
(* TODO: consider how to really choose camlp4o or camlp4r. *)
let syn_args = [A"-syntax"; A "camlp4o"] in
let args =
(* Heuristic to identify syntax extensions: whether they end in
".syntax"; some might not.
*)
if Filename.check_suffix pkg "syntax" ||
List.mem pkg well_known_syntax then
syn_args @ base_args
else
base_args
in
flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
end
(find_packages ());
if not (conf.no_automatic_syntax) then begin
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter
begin fun pkg ->
let base_args = [A"-package"; A pkg] in
(* TODO: consider how to really choose camlp4o or camlp4r. *)
let syn_args = [A"-syntax"; A "camlp4o"] in
let (args, pargs) =
(* Heuristic to identify syntax extensions: whether they end in
".syntax"; some might not.
*)
if Filename.check_suffix pkg "syntax" ||
List.mem pkg well_known_syntax then
(syn_args @ base_args, syn_args)
else
(base_args, [])
in
flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
(* TODO: Check if this is allowed for OCaml < 3.12.1 *)
flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs;
flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs;
flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs;
flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs;
end
(find_packages ());
end;
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
@ -546,12 +557,13 @@ module MyOCamlbuildBase = struct
(* When ocaml link something that use the C library, then one
need that file to be up to date.
This holds both for programs and for libraries.
*)
dep ["link"; "ocaml"; "program"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["link"; "ocaml"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["compile"; "ocaml"; "program"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["compile"; "ocaml"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
(* TODO: be more specific about what depends on headers *)
(* Depends on .h files *)
@ -580,18 +592,18 @@ module MyOCamlbuildBase = struct
()
let dispatch_default t =
let dispatch_default conf t =
dispatch_combine
[
dispatch t;
MyOCamlbuildFindlib.dispatch;
MyOCamlbuildFindlib.dispatch conf;
]
end
# 594 "myocamlbuild.ml"
# 606 "myocamlbuild.ml"
open Ocamlbuild_plugin;;
let package_default =
{
@ -613,6 +625,7 @@ let package_default =
("threads", ["core"]);
("tests/lwt", ["core"; "lwt"]);
("tests", ["core"; "misc"; "string"]);
("qtest", ["core"; "misc"; "string"]);
("pervasives", ["core"]);
("misc", ["core"]);
("lwt", ["core"; "misc"]);
@ -625,8 +638,54 @@ let package_default =
}
;;
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
# 631 "myocamlbuild.ml"
let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
# 646 "myocamlbuild.ml"
(* OASIS_STOP *)
Ocamlbuild_plugin.dispatch dispatch_default;;
dispatch
(MyOCamlbuildBase.dispatch_combine [
begin function
| After_rules ->
(* replace with Ocamlbuild_cppo.dispatch when 4.00 is not supported
anymore *)
let dep = "%(name).cppo.ml" in
let prod1 = "%(name: <*> and not <*.cppo>).ml" in
let prod2 = "%(name: <**/*> and not <**/*.cppo>).ml" in
let f prod env _build =
let dep = env dep in
let prod = env prod in
let tags = tags_of_pathname prod ++ "cppo" in
Cmd (S[A "cppo"; T tags; S [A "-o"; P prod]; P dep ])
in
rule "cppo1" ~dep ~prod:prod1 (f prod1) ;
rule "cppo2" ~dep ~prod:prod2 (f prod2) ;
pflag ["cppo"] "cppo_D" (fun s -> S [A "-D"; A s]) ;
pflag ["cppo"] "cppo_U" (fun s -> S [A "-U"; A s]) ;
pflag ["cppo"] "cppo_I" (fun s ->
if Pathname.is_directory s then S [A "-I"; P s]
else S [A "-I"; P (Pathname.dirname s)]
) ;
pdep ["cppo"] "cppo_I" (fun s ->
if Pathname.is_directory s then [] else [s]) ;
flag ["cppo"; "cppo_q"] (A "-q") ;
flag ["cppo"; "cppo_s"] (A "-s") ;
flag ["cppo"; "cppo_n"] (A "-n") ;
pflag ["cppo"] "cppo_x" (fun s -> S [A "-x"; A s]);
(* end replace *)
let major, minor = Scanf.sscanf Sys.ocaml_version "%d.%d.%d"
(fun major minor patchlevel -> major, minor)
in
let ocaml_major = "OCAML_MAJOR " ^ string_of_int major in
let ocaml_minor = "OCAML_MINOR " ^ string_of_int minor in
flag ["cppo"] & S[A"-D"; A ocaml_major; A"-D"; A ocaml_minor]
| _ -> ()
end;
dispatch_default
])

7
pervasives/CCPervasives.ml
View file

@ -35,6 +35,11 @@ This module is meant to be opened if one doesn't want to use both, say,
]}
@since 0.4
Changed [Opt] to [Option] to better reflect that this module is about the
['a option] type, with [module Option = CCOpt].
@since NEXT_RELEASE
*)
module Array = struct include Array include CCArray end
@ -43,7 +48,7 @@ module Error = CCError
module Fun = CCFun
module Int = CCInt
module List = struct include List include CCList end
module Opt = CCOpt
module Option = CCOpt
module Pair = CCPair
module String = struct include String include CCString end
module Vector = CCVector

1
sequence/.merlin
View file

@ -6,3 +6,4 @@ B _build/tests/
B _build/bench/
PKG oUnit
PKG benchmark
FLAG -safe-string

8
sequence/.ocamlinit
View file

@ -1,5 +1,9 @@
#directory "_build";;
#load "sequence.cma";;
open Sequence.Infix;;
(* vim:syntax=ocaml
*)
#directory "_build/bigarray/";;
#load "bigarray.cma";;
(* vim:syntax=ocaml *)

8
sequence/CHANGELOG.md
View file

@ -1,5 +1,11 @@
# Changelog
## 0.5.4
- depend on `bytes`
- compliance with `-safe-string`
- `sequence.bigarray`
## 0.5.3
- bugfix: interaction between `take` and `is_empty`
@ -76,4 +82,4 @@
- `zip`, `unzip` and `zip_i` to convert between `t` and `t2`
- added `scan` combinator
note: git log --no-merges previous_version..HEAD --pretty=%s
note: git log --no-merges --pretty=%s previous_version..HEAD

18
sequence/META
View file

@ -1,14 +1,15 @@
# OASIS_START
# DO NOT EDIT (digest: 99194977427ba82f5912e81125f6cac0)
version = "0.5.3"
# DO NOT EDIT (digest: 0c501104bbf1dfc40db58200fdbfdd57)
version = "0.5.4"
description = "Simple sequence (iterator) datatype and combinators"
requires = "bytes"
archive(byte) = "sequence.cma"
archive(byte, plugin) = "sequence.cma"
archive(native) = "sequence.cmxa"
archive(native, plugin) = "sequence.cmxs"
exists_if = "sequence.cma"
package "invert" (
version = "0.5.3"
version = "0.5.4"
description = "Simple sequence (iterator) datatype and combinators"
requires = "sequence delimcc"
archive(byte) = "invert.cma"
@ -17,5 +18,16 @@ package "invert" (
archive(native, plugin) = "invert.cmxs"
exists_if = "invert.cma"
)
package "bigarray" (
version = "0.5.4"
description = "Simple sequence (iterator) datatype and combinators"
requires = "sequence bigarray"
archive(byte) = "bigarray.cma"
archive(byte, plugin) = "bigarray.cma"
archive(native) = "bigarray.cmxa"
archive(native, plugin) = "bigarray.cmxs"
exists_if = "bigarray.cma"
)
# OASIS_STOP

6
sequence/Makefile
View file

@ -59,9 +59,11 @@ push_stable: all
VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis)
SOURCE=*.ml *.mli invert/*.ml invert/*.mli bigarray/*.ml bigarray/*.mli
update_next_tag:
@echo "update version to $(VERSION)..."
sed -i "s/NEXT_VERSION/$(VERSION)/g" *.ml *.mli
sed -i "s/NEXT_RELEASE/$(VERSION)/g" *.ml *.mli
sed -i "s/NEXT_VERSION/$(VERSION)/g" $(SOURCE)
sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(SOURCE)
.PHONY: benchs tests examples update_next_tag push_doc push_stable

16
sequence/_oasis
View file

@ -1,6 +1,6 @@
OASISFormat: 0.4
Name: sequence
Version: 0.5.3
Version: 0.5.4
Homepage: https://github.com/c-cube/sequence
Authors: Simon Cruanes
License: BSD-2-clause
@ -23,9 +23,14 @@ Flag invert
Description: build sequence.invert (requires Delimcc)
Default: false
Flag bigarray
Description: build sequence.bigarray (requires bigarray)
Default: true
Library "sequence"
Path: .
Modules: Sequence
BuildDepends: bytes
Library "invert"
Path: invert
@ -36,6 +41,15 @@ Library "invert"
FindlibParent: sequence
BuildDepends: sequence,delimcc
Library "bigarray"
Path: bigarray
Build$: flag(bigarray)
Install$: flag(bigarray)
Modules: SequenceBigarray
FindlibName: bigarray
FindlibParent: sequence
BuildDepends: sequence,bigarray
Document sequence
Title: Sequence docs
Type: ocamlbuild (0.3)

28
sequence/_tags
View file

@ -1,8 +1,9 @@
# OASIS_START
# DO NOT EDIT (digest: e8d5fe31ff471d3c0ec54943fe50d011)
# DO NOT EDIT (digest: 29e0c9fc65daf16caa16466d6ff32bac)
# Ignore VCS directories, you can use the same kind of rule outside
# OASIS_START/STOP if you want to exclude directories that contains
# useless stuff for the build process
true: annot, bin_annot
<**/.svn>: -traverse
<**/.svn>: not_hygienic
".bzr": -traverse
@ -15,25 +16,38 @@
"_darcs": not_hygienic
# Library sequence
"sequence.cmxs": use_sequence
<*.ml{,i,y}>: pkg_bytes
# Library invert
"invert/invert.cmxs": use_invert
<invert/*.ml{,i}>: pkg_delimcc
<invert/*.ml{,i}>: use_sequence
<invert/*.ml{,i,y}>: pkg_bytes
<invert/*.ml{,i,y}>: pkg_delimcc
<invert/*.ml{,i,y}>: use_sequence
# Library bigarray
"bigarray/bigarray.cmxs": use_bigarray
<bigarray/*.ml{,i,y}>: pkg_bigarray
<bigarray/*.ml{,i,y}>: pkg_bytes
<bigarray/*.ml{,i,y}>: use_sequence
# Executable run_tests
"tests/run_tests.native": pkg_bytes
"tests/run_tests.native": pkg_oUnit
"tests/run_tests.native": use_sequence
<tests/*.ml{,i}>: pkg_oUnit
<tests/*.ml{,i}>: use_sequence
<tests/*.ml{,i,y}>: pkg_bytes
<tests/*.ml{,i,y}>: pkg_oUnit
<tests/*.ml{,i,y}>: use_sequence
# Executable benchs
"bench/benchs.native": pkg_benchmark
"bench/benchs.native": pkg_bytes
"bench/benchs.native": use_sequence
# Executable bench_persistent
"bench/bench_persistent.native": pkg_benchmark
"bench/bench_persistent.native": pkg_bytes
"bench/bench_persistent.native": use_sequence
# Executable bench_persistent_read
"bench/bench_persistent_read.native": pkg_benchmark
"bench/bench_persistent_read.native": pkg_bytes
"bench/bench_persistent_read.native": use_sequence
<bench/*.ml{,i}>: pkg_benchmark
<bench/*.ml{,i}>: use_sequence
<bench/*.ml{,i,y}>: pkg_benchmark
<bench/*.ml{,i,y}>: pkg_bytes
<bench/*.ml{,i,y}>: use_sequence
# OASIS_STOP
true: bin_annot

4
sequence/bigarray/bigarray.mldylib Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: dca476c3b57e859aa3b1c75ec0959ed9)
SequenceBigarray
# OASIS_STOP

4
sequence/bigarray/bigarray.mllib Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: dca476c3b57e859aa3b1c75ec0959ed9)
SequenceBigarray
# OASIS_STOP

45
sequence/bigarray/sequenceBigarray.ml Normal file
View file

@ -0,0 +1,45 @@
(*
Copyright (c) 2014, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Interface and Helpers for bigarrays} *)
let of_bigarray b yield =
let len = Bigarray.Array1.dim b in
for i=0 to len-1 do
yield b.{i}
done
let mmap filename =
fun yield ->
let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in
let len = Unix.lseek fd 0 Unix.SEEK_END in
let _ = Unix.lseek fd 0 Unix.SEEK_SET in
let b = Bigarray.Array1.map_file fd Bigarray.Char Bigarray.C_layout false len in
try
of_bigarray b yield;
Unix.close fd
with e ->
Unix.close fd;
raise e

53
misc/bencodeStream.mli → sequence/bigarray/sequenceBigarray.mli
View file

@ -1,13 +1,12 @@
(*
copyright (c) 2014, simon cruanes
all rights reserved.
Copyright (c) 2014, Simon Cruanes
All rights reserved.
redistribution and use in source and binary forms, with or without
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
@ -24,42 +23,12 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Full-Streaming API of Bencode} *)
(** {1 Interface and Helpers for bigarrays}
type token =
| Int of int
| String of string
| BeginDict
| BeginList
| End
@since 0.5.4 *)
module Encode : sig
type t
val of_bigarray : ('a, _, _) Bigarray.Array1.t -> 'a Sequence.t
(** Iterate on the elements of a 1-D array *)
type sink =
[ `File of string
| `Out of out_channel
| `Buf of Buffer.t
]
val create : sink -> t
val push : t -> token -> unit
end
module Decode : sig
type t
val create : unit -> t
(** Create a new decoder with the given source. *)
val feed : t -> string -> unit
(** For manual mode, provide some input *)
type result =
| Yield of token
| Error of string (** Invalid B-encode *)
| Await (** The user needs to call {!feed} with some input *)
val next : t -> result
end
val mmap : string -> char Sequence.t
(** Map the file into memory, and read the characters. *)

94
sequence/myocamlbuild.ml
View file

@ -1,5 +1,5 @@
(* OASIS_START *)
(* DO NOT EDIT (digest: c4bb6d2ca42efb069d5612eb2bbcf244) *)
(* DO NOT EDIT (digest: 2ea21bad023bcdcb9626e204d039d0d2) *)
module OASISGettext = struct
(* # 22 "src/oasis/OASISGettext.ml" *)
@ -249,6 +249,9 @@ module MyOCamlbuildFindlib = struct
*)
open Ocamlbuild_plugin
type conf =
{ no_automatic_syntax: bool;
}
(* these functions are not really officially exported *)
let run_and_read =
@ -315,7 +318,7 @@ module MyOCamlbuildFindlib = struct
(* This lists all supported packages. *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list"))
(* Mock to list available syntaxes. *)
@ -338,7 +341,7 @@ module MyOCamlbuildFindlib = struct
]
let dispatch =
let dispatch conf =
function
| After_options ->
(* By using Before_options one let command line options have an higher
@ -357,31 +360,39 @@ module MyOCamlbuildFindlib = struct
* -linkpkg *)
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter
begin fun pkg ->
let base_args = [A"-package"; A pkg] in
(* TODO: consider how to really choose camlp4o or camlp4r. *)
let syn_args = [A"-syntax"; A "camlp4o"] in
let args =
(* Heuristic to identify syntax extensions: whether they end in
".syntax"; some might not.
*)
if Filename.check_suffix pkg "syntax" ||
List.mem pkg well_known_syntax then
syn_args @ base_args
else
base_args
in
flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
end
(find_packages ());
if not (conf.no_automatic_syntax) then begin
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter
begin fun pkg ->
let base_args = [A"-package"; A pkg] in
(* TODO: consider how to really choose camlp4o or camlp4r. *)
let syn_args = [A"-syntax"; A "camlp4o"] in
let (args, pargs) =
(* Heuristic to identify syntax extensions: whether they end in
".syntax"; some might not.
*)
if Filename.check_suffix pkg "syntax" ||
List.mem pkg well_known_syntax then
(syn_args @ base_args, syn_args)
else
(base_args, [])
in
flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
(* TODO: Check if this is allowed for OCaml < 3.12.1 *)
flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs;
flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs;
flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs;
flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs;
end
(find_packages ());
end;
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
@ -546,12 +557,13 @@ module MyOCamlbuildBase = struct
(* When ocaml link something that use the C library, then one
need that file to be up to date.
This holds both for programs and for libraries.
*)
dep ["link"; "ocaml"; "program"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["link"; "ocaml"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["compile"; "ocaml"; "program"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["compile"; "ocaml"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
(* TODO: be more specific about what depends on headers *)
(* Depends on .h files *)
@ -580,31 +592,37 @@ module MyOCamlbuildBase = struct
()
let dispatch_default t =
let dispatch_default conf t =
dispatch_combine
[
dispatch t;
MyOCamlbuildFindlib.dispatch;
MyOCamlbuildFindlib.dispatch conf;
]
end
# 594 "myocamlbuild.ml"
# 606 "myocamlbuild.ml"
open Ocamlbuild_plugin;;
let package_default =
{
MyOCamlbuildBase.lib_ocaml =
[("sequence", [], []); ("invert", ["invert"], [])];
[
("sequence", [], []);
("invert", ["invert"], []);
("bigarray", ["bigarray"], [])
];
lib_c = [];
flags = [];
includes = []
}
;;
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
# 609 "myocamlbuild.ml"
let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
# 627 "myocamlbuild.ml"
(* OASIS_STOP *)
Ocamlbuild_plugin.dispatch dispatch_default;;

17
sequence/sequence.ml
View file

@ -751,7 +751,7 @@ module IO = struct
fun k ->
let ic = open_in_gen flags mode filename in
try
let buf = String.create size in
let buf = Bytes.create size in
let n = ref 0 in
let stop = ref false in
while not !stop do
@ -763,22 +763,29 @@ module IO = struct
if n' = 0 then stop := true else n := !n + n';
done;
if !n > 0
then k (String.sub buf 0 !n)
then k (Bytes.sub_string buf 0 !n)
done;
close_in ic
with e ->
close_in_noerr ic;
raise e
let write_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq =
let write_bytes_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq =
let oc = open_out_gen flags mode filename in
try
seq (fun s -> output oc s 0 (String.length s));
seq (fun s -> output oc s 0 (Bytes.length s));
close_out oc
with e ->
close_out oc;
raise e
let write_to ?mode ?flags filename seq =
write_bytes_to ?mode ?flags filename (map Bytes.unsafe_of_string seq)
let write_bytes_lines ?mode ?flags filename seq =
let ret = Bytes.unsafe_of_string "\n" in
write_bytes_to ?mode ?flags filename (snoc (intersperse ret seq) ret)
let write_lines ?mode ?flags filename seq =
write_to ?mode ?flags filename (snoc (intersperse "\n" seq) "\n")
write_bytes_lines ?mode ?flags filename (map Bytes.unsafe_of_string seq)
end

18
sequence/sequence.mli
View file

@ -558,6 +558,12 @@ By chunks of [4096] bytes:
Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");;
]}
Read the lines of a file into a list:
{[
Sequence.IO.lines "a" |> Sequence.to_list
]}
@since 0.5.1 *)
module IO : sig
@ -580,13 +586,21 @@ module IO : sig
different iterations might return different results *)
val write_to : ?mode:int -> ?flags:open_flag list ->
string -> string t -> unit
string -> string t -> unit
(** [write_to filename seq] writes all strings from [seq] into the given
file. It takes care of opening and closing the file.
@param mode default [0o644]
@param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *)
val write_bytes_to : ?mode:int -> ?flags:open_flag list ->
string -> Bytes.t t -> unit
(** @since 0.5.4 *)
val write_lines : ?mode:int -> ?flags:open_flag list ->
string -> string t -> unit
string -> string t -> unit
(** Same as {!write_to}, but intercales ['\n'] between each string *)
val write_bytes_lines : ?mode:int -> ?flags:open_flag list ->
string -> Bytes.t t -> unit
(** @since 0.5.4 *)
end

244
sequence/setup.ml
View file

@ -1,9 +1,9 @@
(* setup.ml generated for the first time by OASIS v0.4.4 *)
(* OASIS_START *)
(* DO NOT EDIT (digest: 1c260750474eb19b8e9212954217b6fd) *)
(* DO NOT EDIT (digest: 99b277a969b94ce64e720af9e5ba6929) *)
(*
Regenerated by OASIS v0.4.4
Regenerated by OASIS v0.4.5
Visit http://oasis.forge.ocamlcore.org for more information and
documentation about functions used in this file.
*)
@ -242,11 +242,9 @@ module OASISString = struct
let replace_chars f s =
let buf = String.make (String.length s) 'X' in
for i = 0 to String.length s - 1 do
buf.[i] <- f s.[i]
done;
buf
let buf = Buffer.create (String.length s) in
String.iter (fun c -> Buffer.add_char buf (f c)) s;
Buffer.contents buf
end
@ -1729,6 +1727,13 @@ module OASISFeatures = struct
(fun () ->
s_ "Allows the OASIS section comments and digest to be omitted in \
generated files.")
let no_automatic_syntax =
create "no_automatic_syntax" alpha
(fun () ->
s_ "Disable the automatic inclusion of -syntax camlp4o for packages \
that matches the internal heuristic (if a dependency ends with \
a .syntax or is a well known syntax).")
end
module OASISUnixPath = struct
@ -2099,16 +2104,6 @@ module OASISLibrary = struct
lst
in
(* The headers that should be compiled along *)
let headers =
if lib.lib_pack then
[]
else
find_modules
lib.lib_modules
"cmi"
in
(* The .cmx that be compiled along *)
let cmxs =
let should_be_built =
@ -2134,12 +2129,32 @@ module OASISLibrary = struct
[]
in
(* The headers and annot/cmt files that should be compiled along *)
let headers =
let sufx =
if lib.lib_pack
then [".cmti"; ".cmt"; ".annot"]
else [".cmi"; ".cmti"; ".cmt"; ".annot"]
in
List.map
begin
List.fold_left
begin fun accu s ->
let dot = String.rindex s '.' in
let base = String.sub s 0 dot in
List.map ((^) base) sufx @ accu
end
[]
end
(find_modules lib.lib_modules "cmi")
in
(* Compute what libraries should be built *)
let acc_nopath =
(* Add the packed header file if required *)
let add_pack_header acc =
if lib.lib_pack then
[cs.cs_name^".cmi"] :: acc
[cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc
else
acc
in
@ -2499,13 +2514,13 @@ module OASISFindlib = struct
in
let library_name_of_findlib_name =
Lazy.lazy_from_fun
(fun () ->
(* Revert findlib_name_of_library_name. *)
MapString.fold
(fun k v mp -> MapString.add v k mp)
fndlb_name_of_lib_name
MapString.empty)
lazy begin
(* Revert findlib_name_of_library_name. *)
MapString.fold
(fun k v mp -> MapString.add v k mp)
fndlb_name_of_lib_name
MapString.empty
end
in
let library_name_of_findlib_name fndlb_nm =
try
@ -2875,7 +2890,7 @@ module OASISFileUtil = struct
end
# 2878 "setup.ml"
# 2893 "setup.ml"
module BaseEnvLight = struct
(* # 22 "src/base/BaseEnvLight.ml" *)
@ -2980,7 +2995,7 @@ module BaseEnvLight = struct
end
# 2983 "setup.ml"
# 2998 "setup.ml"
module BaseContext = struct
(* # 22 "src/base/BaseContext.ml" *)
@ -5391,7 +5406,7 @@ module BaseSetup = struct
end
# 5394 "setup.ml"
# 5409 "setup.ml"
module InternalConfigurePlugin = struct
(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *)
@ -5827,6 +5842,17 @@ module InternalInstallPlugin = struct
lst
in
let make_fnames modul sufx =
List.fold_right
begin fun sufx accu ->
(String.capitalize modul ^ sufx) ::
(String.uncapitalize modul ^ sufx) ::
accu
end
sufx
[]
in
(** Install all libraries *)
let install_libs pkg =
@ -5847,27 +5873,29 @@ module InternalInstallPlugin = struct
OASISHostPath.of_unix bs.bs_path
in
List.fold_left
(fun acc modul ->
try
List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
[modul^".mli";
modul^".ml";
String.uncapitalize modul^".mli";
String.capitalize modul^".mli";
String.uncapitalize modul^".ml";
String.capitalize modul^".ml"])
:: acc
with Not_found ->
begin
warning
(f_ "Cannot find source header for module %s \
in library %s")
modul cs.cs_name;
acc
end)
begin fun acc modul ->
begin
try
[List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".mli"; ".ml"]))]
with Not_found ->
warning
(f_ "Cannot find source header for module %s \
in library %s")
modul cs.cs_name;
[]
end
@
List.filter
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".annot";".cmti";".cmt"]))
@ acc
end
acc
lib.lib_modules
in
@ -5915,27 +5943,29 @@ module InternalInstallPlugin = struct
OASISHostPath.of_unix bs.bs_path
in
List.fold_left
(fun acc modul ->
try
List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
[modul^".mli";
modul^".ml";
String.uncapitalize modul^".mli";
String.capitalize modul^".mli";
String.uncapitalize modul^".ml";
String.capitalize modul^".ml"])
:: acc
with Not_found ->
begin
warning
(f_ "Cannot find source header for module %s \
in object %s")
modul cs.cs_name;
acc
end)
begin fun acc modul ->
begin
try
[List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".mli"; ".ml"]))]
with Not_found ->
warning
(f_ "Cannot find source header for module %s \
in object %s")
modul cs.cs_name;
[]
end
@
List.filter
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".annot";".cmti";".cmt"]))
@ acc
end
acc
obj.obj_modules
in
@ -6240,7 +6270,7 @@ module InternalInstallPlugin = struct
end
# 6243 "setup.ml"
# 6273 "setup.ml"
module OCamlbuildCommon = struct
(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
@ -6298,6 +6328,11 @@ module OCamlbuildCommon = struct
else
[];
if bool_of_string (tests ()) then
["-tag"; "tests"]
else
[];
if bool_of_string (profile ()) then
["-tag"; "profile"]
else
@ -6613,7 +6648,7 @@ module OCamlbuildDocPlugin = struct
end
# 6616 "setup.ml"
# 6651 "setup.ml"
module CustomPlugin = struct
(* # 22 "src/plugins/custom/CustomPlugin.ml" *)
@ -6761,7 +6796,7 @@ module CustomPlugin = struct
end
# 6764 "setup.ml"
# 6799 "setup.ml"
open OASISTypes;;
let setup_t =
@ -6826,7 +6861,7 @@ let setup_t =
alpha_features = [];
beta_features = [];
name = "sequence";
version = "0.5.3";
version = "0.5.4";
license =
OASISLicense.DEP5License
(OASISLicense.DEP5Unit
@ -6906,6 +6941,17 @@ let setup_t =
Some "build sequence.invert (requires Delimcc)";
flag_default = [(OASISExpr.EBool true, false)]
});
Flag
({
cs_name = "bigarray";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
flag_description =
Some "build sequence.bigarray (requires bigarray)";
flag_default = [(OASISExpr.EBool true, true)]
});
Library
({
cs_name = "sequence";
@ -6917,7 +6963,7 @@ let setup_t =
bs_install = [(OASISExpr.EBool true, true)];
bs_path = ".";
bs_compiled_object = Best;
bs_build_depends = [];
bs_build_depends = [FindlibPackage ("bytes", None)];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
bs_data_files = [];
@ -6978,6 +7024,48 @@ let setup_t =
lib_findlib_name = Some "invert";
lib_findlib_containers = []
});
Library
({
cs_name = "bigarray";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "bigarray", true)
];
bs_install =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "bigarray", true)
];
bs_path = "bigarray";
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "sequence";
FindlibPackage ("bigarray", None)
];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
bs_data_files = [];
bs_ccopt = [(OASISExpr.EBool true, [])];
bs_cclib = [(OASISExpr.EBool true, [])];
bs_dlllib = [(OASISExpr.EBool true, [])];
bs_dllpath = [(OASISExpr.EBool true, [])];
bs_byteopt = [(OASISExpr.EBool true, [])];
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{
lib_modules = ["SequenceBigarray"];
lib_pack = false;
lib_internal_modules = [];
lib_findlib_parent = Some "sequence";
lib_findlib_name = Some "bigarray";
lib_findlib_containers = []
});
Doc
({
cs_name = "sequence";
@ -7191,8 +7279,8 @@ let setup_t =
plugin_data = []
};
oasis_fn = Some "_oasis";
oasis_version = "0.4.4";
oasis_digest = Some "\214\tqh\b\169>\243\237\213\012\180\162\155`L";
oasis_version = "0.4.5";
oasis_digest = Some "\143pX\233\t\217\232\\d\023B\027\020*\019W";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false
@ -7200,6 +7288,6 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
# 7204 "setup.ml"
# 7292 "setup.ml"
(* OASIS_STOP *)
let () = setup ();;

242
setup.ml
View file

@ -1,9 +1,9 @@
(* setup.ml generated for the first time by OASIS v0.4.4 *)
(* OASIS_START *)
(* DO NOT EDIT (digest: dcc76292b95f99702b08209614903f90) *)
(* DO NOT EDIT (digest: 8965d4f752d8126e982e660646a7ec33) *)
(*
Regenerated by OASIS v0.4.4
Regenerated by OASIS v0.4.5
Visit http://oasis.forge.ocamlcore.org for more information and
documentation about functions used in this file.
*)
@ -242,11 +242,9 @@ module OASISString = struct
let replace_chars f s =
let buf = String.make (String.length s) 'X' in
for i = 0 to String.length s - 1 do
buf.[i] <- f s.[i]
done;
buf
let buf = Buffer.create (String.length s) in
String.iter (fun c -> Buffer.add_char buf (f c)) s;
Buffer.contents buf
end
@ -1729,6 +1727,13 @@ module OASISFeatures = struct
(fun () ->
s_ "Allows the OASIS section comments and digest to be omitted in \
generated files.")
let no_automatic_syntax =
create "no_automatic_syntax" alpha
(fun () ->
s_ "Disable the automatic inclusion of -syntax camlp4o for packages \
that matches the internal heuristic (if a dependency ends with \
a .syntax or is a well known syntax).")
end
module OASISUnixPath = struct
@ -2099,16 +2104,6 @@ module OASISLibrary = struct
lst
in
(* The headers that should be compiled along *)
let headers =
if lib.lib_pack then
[]
else
find_modules
lib.lib_modules
"cmi"
in
(* The .cmx that be compiled along *)
let cmxs =
let should_be_built =
@ -2134,12 +2129,32 @@ module OASISLibrary = struct
[]
in
(* The headers and annot/cmt files that should be compiled along *)
let headers =
let sufx =
if lib.lib_pack
then [".cmti"; ".cmt"; ".annot"]
else [".cmi"; ".cmti"; ".cmt"; ".annot"]
in
List.map
begin
List.fold_left
begin fun accu s ->
let dot = String.rindex s '.' in
let base = String.sub s 0 dot in
List.map ((^) base) sufx @ accu
end
[]
end
(find_modules lib.lib_modules "cmi")
in
(* Compute what libraries should be built *)
let acc_nopath =
(* Add the packed header file if required *)
let add_pack_header acc =
if lib.lib_pack then
[cs.cs_name^".cmi"] :: acc
[cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc
else
acc
in
@ -2499,13 +2514,13 @@ module OASISFindlib = struct
in
let library_name_of_findlib_name =
Lazy.lazy_from_fun
(fun () ->
(* Revert findlib_name_of_library_name. *)
MapString.fold
(fun k v mp -> MapString.add v k mp)
fndlb_name_of_lib_name
MapString.empty)
lazy begin
(* Revert findlib_name_of_library_name. *)
MapString.fold
(fun k v mp -> MapString.add v k mp)
fndlb_name_of_lib_name
MapString.empty
end
in
let library_name_of_findlib_name fndlb_nm =
try
@ -2875,7 +2890,7 @@ module OASISFileUtil = struct
end
# 2878 "setup.ml"
# 2893 "setup.ml"
module BaseEnvLight = struct
(* # 22 "src/base/BaseEnvLight.ml" *)
@ -2980,7 +2995,7 @@ module BaseEnvLight = struct
end
# 2983 "setup.ml"
# 2998 "setup.ml"
module BaseContext = struct
(* # 22 "src/base/BaseContext.ml" *)
@ -5391,7 +5406,7 @@ module BaseSetup = struct
end
# 5394 "setup.ml"
# 5409 "setup.ml"
module InternalConfigurePlugin = struct
(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *)
@ -5827,6 +5842,17 @@ module InternalInstallPlugin = struct
lst
in
let make_fnames modul sufx =
List.fold_right
begin fun sufx accu ->
(String.capitalize modul ^ sufx) ::
(String.uncapitalize modul ^ sufx) ::
accu
end
sufx
[]
in
(** Install all libraries *)
let install_libs pkg =
@ -5847,27 +5873,29 @@ module InternalInstallPlugin = struct
OASISHostPath.of_unix bs.bs_path
in
List.fold_left
(fun acc modul ->
try
List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
[modul^".mli";
modul^".ml";
String.uncapitalize modul^".mli";
String.capitalize modul^".mli";
String.uncapitalize modul^".ml";
String.capitalize modul^".ml"])
:: acc
with Not_found ->
begin
warning
(f_ "Cannot find source header for module %s \
in library %s")
modul cs.cs_name;
acc
end)
begin fun acc modul ->
begin
try
[List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".mli"; ".ml"]))]
with Not_found ->
warning
(f_ "Cannot find source header for module %s \
in library %s")
modul cs.cs_name;
[]
end
@
List.filter
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".annot";".cmti";".cmt"]))
@ acc
end
acc
lib.lib_modules
in
@ -5915,27 +5943,29 @@ module InternalInstallPlugin = struct
OASISHostPath.of_unix bs.bs_path
in
List.fold_left
(fun acc modul ->
try
List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
[modul^".mli";
modul^".ml";
String.uncapitalize modul^".mli";
String.capitalize modul^".mli";
String.uncapitalize modul^".ml";
String.capitalize modul^".ml"])
:: acc
with Not_found ->
begin
warning
(f_ "Cannot find source header for module %s \
in object %s")
modul cs.cs_name;
acc
end)
begin fun acc modul ->
begin
try
[List.find
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".mli"; ".ml"]))]
with Not_found ->
warning
(f_ "Cannot find source header for module %s \
in object %s")
modul cs.cs_name;
[]
end
@
List.filter
OASISFileUtil.file_exists_case
(List.map
(Filename.concat path)
(make_fnames modul [".annot";".cmti";".cmt"]))
@ acc
end
acc
obj.obj_modules
in
@ -6240,7 +6270,7 @@ module InternalInstallPlugin = struct
end
# 6243 "setup.ml"
# 6273 "setup.ml"
module OCamlbuildCommon = struct
(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
@ -6298,6 +6328,11 @@ module OCamlbuildCommon = struct
else
[];
if bool_of_string (tests ()) then
["-tag"; "tests"]
else
[];
if bool_of_string (profile ()) then
["-tag"; "profile"]
else
@ -6613,7 +6648,7 @@ module OCamlbuildDocPlugin = struct
end
# 6616 "setup.ml"
# 6651 "setup.ml"
module CustomPlugin = struct
(* # 22 "src/plugins/custom/CustomPlugin.ml" *)
@ -6761,7 +6796,7 @@ module CustomPlugin = struct
end
# 6764 "setup.ml"
# 6799 "setup.ml"
open OASISTypes;;
let setup_t =
@ -6899,7 +6934,8 @@ let setup_t =
build_type = (`Build, "ocamlbuild", Some "0.4");
build_custom =
{
pre_command = [(OASISExpr.EBool true, None)];
pre_command =
[(OASISExpr.EBool true, Some (("make", ["qtest-gen"])))];
post_command = [(OASISExpr.EBool true, None)]
};
install_type = (`Install, "internal", Some "0.4");
@ -6993,7 +7029,7 @@ let setup_t =
bs_install = [(OASISExpr.EBool true, true)];
bs_path = "core";
bs_compiled_object = Best;
bs_build_depends = [];
bs_build_depends = [FindlibPackage ("bytes", None)];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
bs_data_files = [];
@ -7036,7 +7072,8 @@ let setup_t =
"CCString";
"CCHashtbl";
"CCFlatHashtbl";
"CCSexp"
"CCSexp";
"CCMap"
];
lib_pack = false;
lib_internal_modules = [];
@ -7177,14 +7214,11 @@ let setup_t =
"Univ";
"Bij";
"PiCalculus";
"Bencode";
"RAL";
"UnionFind";
"SmallSet";
"AbsSet";
"CSM";
"ActionMan";
"BencodeOnDisk";
"TTree";
"PrintBox";
"HGraph";
@ -7194,9 +7228,6 @@ let setup_t =
"Iteratee";
"BTree";
"Ty";
"Tell";
"BencodeStream";
"RatTerm";
"Cause";
"AVL";
"ParseReact"
@ -7687,6 +7718,40 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{exec_custom = false; exec_main_is = "test_Future.ml"});
Executable
({
cs_name = "run_qtest";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "tests", true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "qtest/";
bs_compiled_object = Native;
bs_build_depends =
[
InternalLibrary "containers";
InternalLibrary "containers_misc";
InternalLibrary "containers_string";
FindlibPackage ("oUnit", None);
FindlibPackage ("QTest2Lib", None)
];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
bs_data_files = [];
bs_ccopt = [(OASISExpr.EBool true, [])];
bs_cclib = [(OASISExpr.EBool true, [])];
bs_dlllib = [(OASISExpr.EBool true, [])];
bs_dllpath = [(OASISExpr.EBool true, [])];
bs_byteopt = [(OASISExpr.EBool true, [])];
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{exec_custom = false; exec_main_is = "run_qtest.ml"});
Executable
({
cs_name = "run_tests";
@ -7745,13 +7810,16 @@ let setup_t =
(OASISExpr.EFlag "tests", false);
(OASISExpr.EAnd
(OASISExpr.EFlag "tests",
OASISExpr.EFlag "tests"),
OASISExpr.EAnd
(OASISExpr.EFlag "tests",
OASISExpr.EFlag "misc")),
true)
];
test_tools =
[
ExternalTool "ocamlbuild";
InternalExecutable "run_tests"
InternalExecutable "run_tests";
InternalExecutable "run_qtest"
]
});
Executable
@ -7871,8 +7939,8 @@ let setup_t =
plugin_data = []
};
oasis_fn = Some "_oasis";
oasis_version = "0.4.4";
oasis_digest = Some "\002\239\018\128\253~\185m\250\241H\193\205iK\000";
oasis_version = "0.4.5";
oasis_digest = Some "\191L\228>\028\226\240\230.\000\185\131\240[~4";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false
@ -7880,6 +7948,6 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
# 7884 "setup.ml"
# 7952 "setup.ml"
(* OASIS_STOP *)
let () = setup ();;

12
string/levenshtein.ml
View file

@ -98,7 +98,7 @@ module type S = sig
(** Add a pair string/value to the index. If a value was already present
for this string it is replaced. *)
val remove : 'b t -> string_ -> 'b -> 'b t
val remove : 'b t -> string_ -> 'b t
(** Remove a string (and its associated value, if any) from the index. *)
val retrieve : limit:int -> 'b t -> string_ -> 'b klist
@ -338,7 +338,7 @@ module Make(Str : STRING) = struct
let rec get_transitions_for_any nda acc transitions =
match transitions with
| NDA.Upon (NDA.Char _, i, j) :: transitions' ->
| NDA.Upon (NDA.Char _, _, _) :: transitions' ->
get_transitions_for_any nda acc transitions'
| NDA.Upon (NDA.Any, i, j) :: transitions' ->
let acc = NDAStateSet.add (i,j) acc in
@ -558,7 +558,7 @@ module Make(Str : STRING) = struct
(function
| Node (_, m) -> Node (Some value, m))
let remove trie s value =
let remove trie s =
goto_leaf s trie
(function
| Node (_, m) -> Node (None, m))
@ -643,9 +643,9 @@ include Make(struct
let length = String.length
let get = String.get
let of_list l =
let s = String.make (List.length l) ' ' in
List.iteri (fun i c -> s.[i] <- c) l;
s
let buf = Buffer.create (List.length l) in
List.iter (fun c -> Buffer.add_char buf c) l;
Buffer.contents buf
end)
let debug_print = debug_print output_char

2
string/levenshtein.mli
View file

@ -142,7 +142,7 @@ module type S = sig
(** Add a pair string/value to the index. If a value was already present
for this string it is replaced. *)
val remove : 'b t -> string_ -> 'b -> 'b t
val remove : 'b t -> string_ -> 'b t
(** Remove a string (and its associated value, if any) from the index. *)
val retrieve : limit:int -> 'b t -> string_ -> 'b klist

3
tests/run_tests.ml
View file

@ -6,11 +6,9 @@ let suite =
"all_tests" >:::
[ Test_pHashtbl.suite;
Test_PersistentHashtbl.suite;
Test_bencode.suite;
Test_bv.suite;
Test_PiCalculus.suite;
Test_splayMap.suite;
Test_bij.suite;
Test_CCHeap.suite;
Test_cc.suite;
Test_puf.suite;
@ -29,7 +27,6 @@ let props =
QCheck.flatten
[ Test_PersistentHashtbl.props
; Test_bv.props
; Test_bencode.props
; Test_vector.props
]

71
tests/test_bencode.ml
View file

@ -1,71 +0,0 @@
open OUnit
open Containers_misc
module B = Bencode
let test1 () =
let s = "li42ei0ei-200ee" in
match B.parse_string s with
| B.ParseError msg ->
OUnit.assert_failure (Printf.sprintf "should parse, got %s" msg)
| B.ParsePartial ->
OUnit.assert_failure "should parse, got partial"
| B.ParseOk b ->
OUnit.assert_equal (B.L [B.I 42; B.I 0; B.I ~-200]) b
let test2 () =
let b =
B.dict_of_list [
"foo", B.I 42;
"bar", B.L [B.I 0; B.S "caramba si"];
"", B.S "";
]
in
let s = B.to_string b in
(* Printf.printf "serialized to %s\n" s; *)
let b' = B.of_string s in
OUnit.assert_equal ~cmp:B.eq ~printer:B.to_string b b'
let test3 () =
let b = B.dict_of_list [
"a", B.I 1;
"b", B.S "bbbb";
"l", B.L [B.I 0; B.I 0; B.S "zero\n\t \x00"];
"d", B.dict_of_list ["foo", B.S "bar"];
] in
let s = B.to_string b in
(* Printf.printf "serialized to %s\n" s; *)
let b' = B.of_string s in
OUnit.assert_equal ~cmp:B.eq ~printer:B.to_string b b'
let suite =
"test_bencode" >:::
[ "test1" >:: test1;
"test2" >:: test2;
"test3" >:: test3;
]
open QCheck
let check_decode_encode =
let gen = Arbitrary.(
let base = choose
[ lift (fun i -> B.I i) small_int
; lift (fun s -> B.S s) string
]
in
fix ~max:3 ~base (fun sub ->
choose
[ lift B.dict_of_list (list (pair string sub))
; lift (fun l -> B.L l) (list sub)
; sub
]))
in
let prop b = B.eq (B.of_string (B.to_string b)) b in
let name = "bencode_decode_encode_bij" in
mk_test ~name gen prop
let props =
[ check_decode_encode
]

91
tests/test_bij.ml
View file

@ -1,91 +0,0 @@
open OUnit
open Containers_misc
module Sequence = CCSequence
let pp_int_list l =
let b = Buffer.create 4 in
CCList.pp CCInt.pp b l;
Buffer.contents b
let test_intlist n () =
let bij = Bij.(list_ int_) in
let l = Sequence.to_list (Sequence.int_range ~start:0 ~stop:n) in
let s = Bij.TrBencode.to_string ~bij l in
let l' = Bij.TrBencode.of_string ~bij s in
OUnit.assert_equal ~printer:pp_int_list l l'
type term =
| Const of string
| Int of int
| App of term list
let bij_term =
let bij = Bij.fix
(fun bij ->
Bij.switch
~inject:(function
| Const s -> "const", Bij.(BranchTo (string_, s))
| Int i -> "int", Bij.(BranchTo (int_, i))
| App l -> "app", Bij.(BranchTo (list_ (Lazy.force bij), l)))
~extract:(function
| "const" -> Bij.(BranchFrom (string_, fun x -> Const x))
| "int" -> Bij.BranchFrom (Bij.int_, fun x -> Int x)
| "app" -> Bij.(BranchFrom (list_ (Lazy.force bij), fun l -> App l))
| _ -> raise Bij.(DecodingError "unexpected case switch"))
)
in
bij
let test_rec () =
let t = App [Const "foo"; App [Const "bar"; Int 1; Int 2]; Int 3; Const "hello"] in
let s = Bij.TrBencode.to_string ~bij:bij_term t in
(* Printf.printf "to: %s\n" s; *)
let t' = Bij.TrBencode.of_string ~bij:bij_term s in
OUnit.assert_equal t t'
let random_str len =
let s = String.make len ' ' in
for i = 0 to len - 1 do
s.[i] <- "abcdefghijklmnopqrstuvwxyz".[Random.int 26]
done;
s
let rec random_term depth =
if depth = 0
then if Random.bool ()
then Const (random_str (1 + Random.int 5))
else Int (Random.int 20)
else
let len = Random.int (1 + Random.int 10) in
let seq = Sequence.map (fun _ -> random_term (depth-1))
(Sequence.int_range ~start:1 ~stop:len) in
App (Sequence.to_list seq)
let test_term_random ?(depth=5) n () =
for i = 0 to n - 1 do
let t = random_term depth in
let s = Bij.TrBencode.to_string ~bij:bij_term t in
let t' = Bij.TrBencode.of_string ~bij:bij_term s in
OUnit.assert_equal t t'
done
let test_complicated () =
let bij = Bij.(triple int_ (pair bool_ (many float_))
(map ~inject:(fun (a,b) -> (b,a)) ~extract:(fun (b,a) -> a,b) (pair int_ bool_))) in
let x = (1, (true, [1.; 2.; 3.]), (false, 42)) in
let s = Bij.TrBencode.to_string ~bij x in
let x' = Bij.TrBencode.of_string ~bij s in
OUnit.assert_equal x x'
let suite =
"test_bij" >:::
[ "test_intlist10" >:: test_intlist 10
; "test_intlist100" >:: test_intlist 100
; "test_intlist10_000" >:: test_intlist 10_000
; "test_rec" >:: test_rec
; "test_term_random100" >:: test_term_random 100
; "test_term_random100_depth10" >:: test_term_random ~depth:10 100
; "test_complicated" >:: test_complicated
]

6
tests/test_levenshtein.ml
View file

@ -26,10 +26,10 @@ let test_mutation =
return (s,i,c)
) in
let test (s,i,c) =
let s' = String.copy s in
s'.[i] <- c;
let s' = Bytes.of_string s in
Bytes.set s' i c;
let a = Levenshtein.of_string ~limit:1 s in
Levenshtein.match_with a s'
Levenshtein.match_with a (Bytes.to_string s')
in
let name = "mutating s.[i] into s' still accepted by automaton(s)" in
QCheck.mk_test ~name ~size:(fun (s,_,_)->String.length s) gen test