simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2026-01-25 02:26:42 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

version 0.9 (merge from master)

Browse source
This commit is contained in:
Simon Cruanes 2015-02-27 14:41:09 +01:00
commit 8054a9f256
39 changed files with 2902 additions and 260 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.header
View file

@ -1,5 +1,5 @@
(*
copyright (c) 2013-2014, simon cruanes
copyright (c) 2013-2015, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without

20
CHANGELOG.md
View file

@ -1,5 +1,25 @@
# Changelog
## 0.9
- add `Float`, `Ref`, `Set`, `Format` to `CCPervasives`
- `CCRingBuffer.append` (simple implementation)
- `containers.data` now depends on bytes
- new `CCRingBuffer` module, imperative deque with batch (blit) operations,
mostly done by Carmelo Piccione
- new `Lwt_pipe` and `Lwt_klist` streams for Lwt, respectively (un)bounded
synchronized queues and lazy lists
- `CCKTree.print`, a simple S-expressions printer for generic trees
- Add `CCMixmap` in containers.data (close #40), functional alternative to `CCMixtbl`
- remove old META file
- simplified `CCTrie` implementation
- use "compiledObject: best" in `_oasis` for binaries
- document some invariants in `CCCache` (see #38)
- tests for `CCCache.lru`
- fix `CCFormat.seq` combinator
- add `CCSet` module in core/
- add `CCRef` module in core/
## 0.8
- add `@Emm` to authors

44
META
View file

@ -1,44 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 9f5c18246e625c62ccb7bf59b1670289)
version = "0.1"
description = "A bunch of modules, including polymorphic containers."
requires = "unix"
archive(byte) = "containers.cma"
archive(byte, plugin) = "containers.cma"
archive(native) = "containers.cmxa"
archive(native, plugin) = "containers.cmxs"
exists_if = "containers.cma"
package "thread" (
version = "0.1"
description = "A bunch of modules, including polymorphic containers."
requires = "containers threads lwt"
archive(byte) = "containers_thread.cma"
archive(byte, plugin) = "containers_thread.cma"
archive(native) = "containers_thread.cmxa"
archive(native, plugin) = "containers_thread.cmxs"
exists_if = "containers_thread.cma"
)
package "lwt" (
version = "0.1"
description = "A bunch of modules, including polymorphic containers."
requires = "containers lwt lwt.unix"
archive(byte) = "containers_lwt.cma"
archive(byte, plugin) = "containers_lwt.cma"
archive(native) = "containers_lwt.cmxa"
archive(native, plugin) = "containers_lwt.cmxs"
exists_if = "containers_lwt.cma"
)
package "cgi" (
version = "0.1"
description = "A bunch of modules, including polymorphic containers."
requires = "containers CamlGI"
archive(byte) = "containers_cgi.cma"
archive(byte, plugin) = "containers_cgi.cma"
archive(native) = "containers_cgi.cmxa"
archive(native, plugin) = "containers_cgi.cmxs"
exists_if = "containers_cgi.cma"
)
# OASIS_STOP

17
Makefile
View file

@ -70,10 +70,16 @@ QTESTABLE=$(filter-out $(DONTTEST), \
$(wildcard src/bigarray/*.mli) \
)
QTESTABLE_LWT=$(filter-out $(DONTTEST), \
$(wildcard src/lwt/*.ml) \
$(wildcard src/lwt/*.mli) \
)
qtest-clean:
@rm -rf qtest/
QTEST_PREAMBLE='open CCFun;; '
QTEST_LWT_PREAMBLE=$(QTEST_PREAMBLE)
#qtest-build: qtest-clean build
# @mkdir -p qtest
@ -84,7 +90,7 @@ QTEST_PREAMBLE='open CCFun;; '
# -I core -I misc -I string \
# qtest/qtest_all.native
qtest-gen: qtest-clean
qtest-gen:
@mkdir -p qtest
@if which qtest > /dev/null ; then \
qtest extract --preamble $(QTEST_PREAMBLE) \
@ -93,6 +99,15 @@ qtest-gen: qtest-clean
else touch qtest/run_qtest.ml ; \
fi
qtest-lwt-gen:
@mkdir -p qtest/lwt/
@if which qtest > /dev/null ; then \
qtest extract --preamble $(QTEST_LWT_PREAMBLE) \
-o qtest/lwt/run_qtest_lwt.ml \
$(QTESTABLE_LWT) 2> /dev/null ; \
else touch qtest/lwt/run_qtest_lwt.ml ; \
fi
push-stable:
git checkout stable
git merge master -m 'merge from master'

13
README.md
View file

@ -172,16 +172,11 @@ The `Bij` module requires OCaml `>= 4.00` because of GADTs. Type:
$ make
To build and run tests (requires `oUnit` and `qtest`):
To build and run tests (requires `oUnit`, `qtest`, and `qcheck`):
$ opam install oUnit
$ make tests
$ ./tests.native
and
$ opam install qtest
$ make qtest
$ opam install oUnit qtest qcheck
$ ./configure --enable-tests
$ make test
To build the small benchmarking suite (requires `benchmark`):

41
_oasis
View file

@ -1,6 +1,6 @@
OASISFormat: 0.4
Name: containers
Version: 0.8
Version: 0.9
Homepage: https://github.com/c-cube/ocaml-containers
Authors: Simon Cruanes
License: BSD-2-clause
@ -48,7 +48,7 @@ Flag "advanced"
Library "containers"
Path: src/core
Modules: CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair,
CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray,
CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet,
CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat
BuildDepends: bytes
@ -69,7 +69,9 @@ Library "containers_sexp"
Library "containers_data"
Path: src/data
Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache,
CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl
CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl,
CCMixmap, CCRingBuffer
BuildDepends: bytes
FindlibParent: containers
FindlibName: data
@ -131,7 +133,7 @@ Library "containers_thread"
Library "containers_lwt"
Path: src/lwt
Modules: Lwt_automaton, Lwt_actor
Modules: Lwt_automaton, Lwt_actor, Lwt_klist, Lwt_pipe
Pack: true
FindlibName: lwt
FindlibParent: containers
@ -157,7 +159,7 @@ Document containers
Executable run_benchs
Path: benchs/
Install: false
CompiledObject: native
CompiledObject: best
Build$: flag(bench) && flag(misc)
MainIs: run_benchs.ml
BuildDepends: containers, containers.misc, containers.advanced,
@ -167,7 +169,7 @@ Executable run_benchs
Executable bench_hash
Path: benchs/
Install: false
CompiledObject: native
CompiledObject: best
Build$: flag(bench) && flag(misc)
MainIs: bench_hash.ml
BuildDepends: containers, containers.misc
@ -185,23 +187,33 @@ Test future
TestTools: run_test_future
Run$: flag(tests) && flag(thread)
PreBuildCommand: make qtest-gen
PreBuildCommand: make qtest-gen ; make qtest-lwt-gen
Executable run_qtest
Path: qtest/
Install: false
CompiledObject: native
CompiledObject: best
MainIs: run_qtest.ml
Build$: flag(tests)
Build$: flag(tests) && flag(bigarray)
BuildDepends: containers, containers.misc, containers.string, containers.iter,
containers.io, containers.advanced, containers.sexp,
containers.bigarray,
sequence, gen, oUnit, QTest2Lib
Executable run_qtest_lwt
Path: qtest/lwt/
Install: false
CompiledObject: best
MainIs: run_qtest_lwt.ml
Build$: flag(tests) && flag(lwt)
BuildDepends: containers, containers.lwt, lwt, lwt.unix,
sequence, gen, oUnit, QTest2Lib
Executable run_tests
Path: tests/
Install: false
CompiledObject: native
CompiledObject: best
MainIs: run_tests.ml
Build$: flag(tests) && flag(misc)
BuildDepends: containers, containers.data, oUnit, sequence, gen,
@ -212,9 +224,14 @@ Test all
TestTools: run_tests, run_qtest
Run$: flag(tests) && flag(misc)
Test lwt
Command: echo "test lwt"; ./run_qtest_lwt.native
Run$: flag(tests) && flag(lwt)
Executable lambda
Path: examples/
Install: false
CompiledObject: best
MainIs: lambda.ml
Build$: flag(misc)
BuildDepends: containers, containers.misc
@ -222,7 +239,7 @@ Executable lambda
Executable id_sexp
Path: examples/
Install: false
CompiledObject: native
CompiledObject: best
MainIs: id_sexp.ml
Build$: flag(misc)
BuildDepends: containers.sexp
@ -230,7 +247,7 @@ Executable id_sexp
Executable id_sexp2
Path: examples/
Install: false
CompiledObject: native
CompiledObject: best
MainIs: id_sexp2.ml
Build$: flag(misc)
BuildDepends: containers.sexp

120
_tags
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 2b3148849efeea95c2f260b7cce3b77e)
# DO NOT EDIT (digest: 4bc9d475d595a814a666d126274b25b1)
# 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
@ -25,6 +25,7 @@ true: annot, bin_annot
<src/sexp/*.ml{,i,y}>: package(bytes)
# Library containers_data
"src/data/containers_data.cmxs": use_containers_data
<src/data/*.ml{,i,y}>: package(bytes)
# Library containers_iter
"src/iter/containers_iter.cmxs": use_containers_iter
# Library containers_string
@ -76,22 +77,24 @@ true: annot, bin_annot
"src/lwt/containers_lwt.cmxs": use_containers_lwt
"src/lwt/lwt_automaton.cmx": for-pack(Containers_lwt)
"src/lwt/lwt_actor.cmx": for-pack(Containers_lwt)
"src/lwt/lwt_klist.cmx": for-pack(Containers_lwt)
"src/lwt/lwt_pipe.cmx": for-pack(Containers_lwt)
<src/lwt/*.ml{,i,y}>: package(bytes)
<src/lwt/*.ml{,i,y}>: package(lwt)
<src/lwt/*.ml{,i,y}>: use_containers
<src/lwt/*.ml{,i,y}>: use_containers_data
<src/lwt/*.ml{,i,y}>: use_containers_misc
# Executable run_benchs
"benchs/run_benchs.native": package(benchmark)
"benchs/run_benchs.native": package(bytes)
"benchs/run_benchs.native": package(gen)
"benchs/run_benchs.native": package(sequence)
"benchs/run_benchs.native": use_containers
"benchs/run_benchs.native": use_containers_advanced
"benchs/run_benchs.native": use_containers_data
"benchs/run_benchs.native": use_containers_iter
"benchs/run_benchs.native": use_containers_misc
"benchs/run_benchs.native": use_containers_string
<benchs/run_benchs.{native,byte}>: package(benchmark)
<benchs/run_benchs.{native,byte}>: package(bytes)
<benchs/run_benchs.{native,byte}>: package(gen)
<benchs/run_benchs.{native,byte}>: package(sequence)
<benchs/run_benchs.{native,byte}>: use_containers
<benchs/run_benchs.{native,byte}>: use_containers_advanced
<benchs/run_benchs.{native,byte}>: use_containers_data
<benchs/run_benchs.{native,byte}>: use_containers_iter
<benchs/run_benchs.{native,byte}>: use_containers_misc
<benchs/run_benchs.{native,byte}>: use_containers_string
<benchs/*.ml{,i,y}>: package(benchmark)
<benchs/*.ml{,i,y}>: package(gen)
<benchs/*.ml{,i,y}>: package(sequence)
@ -99,10 +102,10 @@ true: annot, bin_annot
<benchs/*.ml{,i,y}>: use_containers_iter
<benchs/*.ml{,i,y}>: use_containers_string
# Executable bench_hash
"benchs/bench_hash.native": package(bytes)
"benchs/bench_hash.native": use_containers
"benchs/bench_hash.native": use_containers_data
"benchs/bench_hash.native": use_containers_misc
<benchs/bench_hash.{native,byte}>: package(bytes)
<benchs/bench_hash.{native,byte}>: use_containers
<benchs/bench_hash.{native,byte}>: use_containers_data
<benchs/bench_hash.{native,byte}>: use_containers_misc
<benchs/*.ml{,i,y}>: package(bytes)
<benchs/*.ml{,i,y}>: use_containers
<benchs/*.ml{,i,y}>: use_containers_data
@ -121,21 +124,21 @@ true: annot, bin_annot
<tests/threads/*.ml{,i,y}>: use_containers
<tests/threads/*.ml{,i,y}>: use_containers_thread
# Executable run_qtest
"qtest/run_qtest.native": package(QTest2Lib)
"qtest/run_qtest.native": package(bigarray)
"qtest/run_qtest.native": package(bytes)
"qtest/run_qtest.native": package(gen)
"qtest/run_qtest.native": package(oUnit)
"qtest/run_qtest.native": package(sequence)
"qtest/run_qtest.native": use_containers
"qtest/run_qtest.native": use_containers_advanced
"qtest/run_qtest.native": use_containers_bigarray
"qtest/run_qtest.native": use_containers_data
"qtest/run_qtest.native": use_containers_io
"qtest/run_qtest.native": use_containers_iter
"qtest/run_qtest.native": use_containers_misc
"qtest/run_qtest.native": use_containers_sexp
"qtest/run_qtest.native": use_containers_string
<qtest/run_qtest.{native,byte}>: package(QTest2Lib)
<qtest/run_qtest.{native,byte}>: package(bigarray)
<qtest/run_qtest.{native,byte}>: package(bytes)
<qtest/run_qtest.{native,byte}>: package(gen)
<qtest/run_qtest.{native,byte}>: package(oUnit)
<qtest/run_qtest.{native,byte}>: package(sequence)
<qtest/run_qtest.{native,byte}>: use_containers
<qtest/run_qtest.{native,byte}>: use_containers_advanced
<qtest/run_qtest.{native,byte}>: use_containers_bigarray
<qtest/run_qtest.{native,byte}>: use_containers_data
<qtest/run_qtest.{native,byte}>: use_containers_io
<qtest/run_qtest.{native,byte}>: use_containers_iter
<qtest/run_qtest.{native,byte}>: use_containers_misc
<qtest/run_qtest.{native,byte}>: use_containers_sexp
<qtest/run_qtest.{native,byte}>: use_containers_string
<qtest/*.ml{,i,y}>: package(QTest2Lib)
<qtest/*.ml{,i,y}>: package(bigarray)
<qtest/*.ml{,i,y}>: package(bytes)
@ -151,16 +154,39 @@ true: annot, bin_annot
<qtest/*.ml{,i,y}>: use_containers_misc
<qtest/*.ml{,i,y}>: use_containers_sexp
<qtest/*.ml{,i,y}>: use_containers_string
# Executable run_qtest_lwt
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(QTest2Lib)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(bytes)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(gen)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(lwt)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(lwt.unix)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(oUnit)
<qtest/lwt/run_qtest_lwt.{native,byte}>: package(sequence)
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers_data
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers_lwt
<qtest/lwt/run_qtest_lwt.{native,byte}>: use_containers_misc
<qtest/lwt/*.ml{,i,y}>: package(QTest2Lib)
<qtest/lwt/*.ml{,i,y}>: package(bytes)
<qtest/lwt/*.ml{,i,y}>: package(gen)
<qtest/lwt/*.ml{,i,y}>: package(lwt)
<qtest/lwt/*.ml{,i,y}>: package(lwt.unix)
<qtest/lwt/*.ml{,i,y}>: package(oUnit)
<qtest/lwt/*.ml{,i,y}>: package(sequence)
<qtest/lwt/*.ml{,i,y}>: use_containers
<qtest/lwt/*.ml{,i,y}>: use_containers_data
<qtest/lwt/*.ml{,i,y}>: use_containers_lwt
<qtest/lwt/*.ml{,i,y}>: use_containers_misc
# Executable run_tests
"tests/run_tests.native": package(bytes)
"tests/run_tests.native": package(gen)
"tests/run_tests.native": package(oUnit)
"tests/run_tests.native": package(qcheck)
"tests/run_tests.native": package(sequence)
"tests/run_tests.native": use_containers
"tests/run_tests.native": use_containers_data
"tests/run_tests.native": use_containers_misc
"tests/run_tests.native": use_containers_string
<tests/run_tests.{native,byte}>: package(bytes)
<tests/run_tests.{native,byte}>: package(gen)
<tests/run_tests.{native,byte}>: package(oUnit)
<tests/run_tests.{native,byte}>: package(qcheck)
<tests/run_tests.{native,byte}>: package(sequence)
<tests/run_tests.{native,byte}>: use_containers
<tests/run_tests.{native,byte}>: use_containers_data
<tests/run_tests.{native,byte}>: use_containers_misc
<tests/run_tests.{native,byte}>: use_containers_string
<tests/*.ml{,i,y}>: package(bytes)
<tests/*.ml{,i,y}>: package(gen)
<tests/*.ml{,i,y}>: package(oUnit)
@ -171,19 +197,19 @@ true: annot, bin_annot
<tests/*.ml{,i,y}>: use_containers_misc
<tests/*.ml{,i,y}>: use_containers_string
# Executable lambda
"examples/lambda.byte": package(bytes)
"examples/lambda.byte": use_containers
"examples/lambda.byte": use_containers_data
"examples/lambda.byte": use_containers_misc
<examples/lambda.{native,byte}>: package(bytes)
<examples/lambda.{native,byte}>: use_containers
<examples/lambda.{native,byte}>: use_containers_data
<examples/lambda.{native,byte}>: use_containers_misc
<examples/*.ml{,i,y}>: use_containers
<examples/*.ml{,i,y}>: use_containers_data
<examples/*.ml{,i,y}>: use_containers_misc
# Executable id_sexp
"examples/id_sexp.native": package(bytes)
"examples/id_sexp.native": use_containers_sexp
<examples/id_sexp.{native,byte}>: package(bytes)
<examples/id_sexp.{native,byte}>: use_containers_sexp
# Executable id_sexp2
"examples/id_sexp2.native": package(bytes)
"examples/id_sexp2.native": use_containers_sexp
<examples/id_sexp2.{native,byte}>: package(bytes)
<examples/id_sexp2.{native,byte}>: use_containers_sexp
<examples/*.ml{,i,y}>: package(bytes)
<examples/*.ml{,i,y}>: use_containers_sexp
# OASIS_STOP

8
containers.odocl
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 2892d9c53521db701e90ccd56fbdc99a)
# DO NOT EDIT (digest: 98c09c3ae4c860914660bcfa48ec375f)
src/core/CCVector
src/core/CCPrint
src/core/CCError
@ -13,6 +13,8 @@ src/core/CCInt
src/core/CCBool
src/core/CCFloat
src/core/CCArray
src/core/CCRef
src/core/CCSet
src/core/CCOrd
src/core/CCRandom
src/core/CCString
@ -44,6 +46,8 @@ src/data/CCDeque
src/data/CCFQueue
src/data/CCBV
src/data/CCMixtbl
src/data/CCMixmap
src/data/CCRingBuffer
src/string/KMP
src/string/Levenshtein
src/pervasives/CCPervasives
@ -58,4 +62,6 @@ src/sexp/CCSexpStream
src/sexp/CCSexpM
src/lwt/Lwt_automaton
src/lwt/Lwt_actor
src/lwt/Lwt_klist
src/lwt/Lwt_pipe
# OASIS_STOP

5
doc/build_deps.ml
View file

@ -18,9 +18,12 @@ let odoc_files =
|> Gen.to_list
;;
let out = "deps.dot";;
let cmd =
"ocamldoc -dot -o deps.dot " ^ String.concat " " odoc_files
"ocamldoc -dot -o " ^ out ^ " " ^ String.concat " " odoc_files
;;
print_endline ("run: " ^ cmd);;
Unix.system cmd;;
print_endline ("output in " ^ out);;

14
doc/intro.txt
View file

@ -40,6 +40,8 @@ CCOrd
CCPair
CCPrint
CCRandom
CCRef
CCSet
CCString
CCVector
}
@ -66,10 +68,12 @@ CCBV
CCCache
CCFQueue
CCFlatHashtbl
CCMixmap
CCMixtbl
CCMultiMap
CCMultiSet
CCPersistentHashtbl
CCRingBuffer
CCTrie
}
@ -129,6 +133,16 @@ UnionFind
Univ
}
{4 Lwt}
Utils for Lwt (including experimental stuff)
{!modules:
Lwt_actor
Lwt_klist
Lwt_pipe
}
{4 Others}
{!modules:

5
myocamlbuild.ml
View file

@ -1,5 +1,5 @@
(* OASIS_START *)
(* DO NOT EDIT (digest: 8dc70d44b47f905c72a130921147d104) *)
(* DO NOT EDIT (digest: fb8dea068c03b0d63bc05634c5db1689) *)
module OASISGettext = struct
(* # 22 "src/oasis/OASISGettext.ml" *)
@ -634,6 +634,7 @@ let package_default =
("src/lwt", ["src/core"; "src/misc"]);
("src/bigarray", ["src/core"]);
("src/advanced", ["src/core"]);
("qtest/lwt", ["src/core"; "src/lwt"]);
("qtest",
[
"src/advanced";
@ -663,7 +664,7 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
# 667 "myocamlbuild.ml"
# 668 "myocamlbuild.ml"
(* OASIS_STOP *)
let doc_intro = "doc/intro.txt" ;;

159
setup.ml
View file

@ -1,7 +1,7 @@
(* setup.ml generated for the first time by OASIS v0.4.4 *)
(* OASIS_START *)
(* DO NOT EDIT (digest: 798266c533c11324b314d4c4bacd9a0c) *)
(* DO NOT EDIT (digest: d2414bb4ed47c14d1e696e080da28357) *)
(*
Regenerated by OASIS v0.4.5
Visit http://oasis.forge.ocamlcore.org for more information and
@ -6830,6 +6830,18 @@ let setup_t =
[(OASISExpr.EBool true, ("make", ["test-all"]))];
cmd_clean = [(OASISExpr.EBool true, None)];
cmd_distclean = [(OASISExpr.EBool true, None)]
});
("lwt",
CustomPlugin.Test.main
{
CustomPlugin.cmd_main =
[
(OASISExpr.EBool true,
("echo",
["\"test"; "lwt\";"; "./run_qtest_lwt.native"]))
];
cmd_clean = [(OASISExpr.EBool true, None)];
cmd_distclean = [(OASISExpr.EBool true, None)]
})
];
doc =
@ -6875,6 +6887,18 @@ let setup_t =
[(OASISExpr.EBool true, ("make", ["test-all"]))];
cmd_clean = [(OASISExpr.EBool true, None)];
cmd_distclean = [(OASISExpr.EBool true, None)]
});
("lwt",
CustomPlugin.Test.clean
{
CustomPlugin.cmd_main =
[
(OASISExpr.EBool true,
("echo",
["\"test"; "lwt\";"; "./run_qtest_lwt.native"]))
];
cmd_clean = [(OASISExpr.EBool true, None)];
cmd_distclean = [(OASISExpr.EBool true, None)]
})
];
clean_doc =
@ -6918,6 +6942,18 @@ let setup_t =
[(OASISExpr.EBool true, ("make", ["test-all"]))];
cmd_clean = [(OASISExpr.EBool true, None)];
cmd_distclean = [(OASISExpr.EBool true, None)]
});
("lwt",
CustomPlugin.Test.distclean
{
CustomPlugin.cmd_main =
[
(OASISExpr.EBool true,
("echo",
["\"test"; "lwt\";"; "./run_qtest_lwt.native"]))
];
cmd_clean = [(OASISExpr.EBool true, None)];
cmd_distclean = [(OASISExpr.EBool true, None)]
})
];
distclean_doc = [];
@ -6929,7 +6965,7 @@ let setup_t =
alpha_features = ["ocamlbuild_more_args"];
beta_features = [];
name = "containers";
version = "0.8";
version = "0.9";
license =
OASISLicense.DEP5License
(OASISLicense.DEP5Unit
@ -6961,7 +6997,12 @@ let setup_t =
build_custom =
{
pre_command =
[(OASISExpr.EBool true, Some (("make", ["qtest-gen"])))];
[
(OASISExpr.EBool true,
Some
(("make",
["qtest-gen"; ";"; "make"; "qtest-lwt-gen"])))
];
post_command = [(OASISExpr.EBool true, None)]
};
install_type = (`Install, "internal", Some "0.4");
@ -7093,6 +7134,8 @@ let setup_t =
"CCBool";
"CCFloat";
"CCArray";
"CCRef";
"CCSet";
"CCOrd";
"CCRandom";
"CCString";
@ -7177,7 +7220,7 @@ let setup_t =
bs_install = [(OASISExpr.EBool true, true)];
bs_path = "src/data";
bs_compiled_object = Best;
bs_build_depends = [];
bs_build_depends = [FindlibPackage ("bytes", None)];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
bs_data_files = [];
@ -7200,7 +7243,9 @@ let setup_t =
"CCDeque";
"CCFQueue";
"CCBV";
"CCMixtbl"
"CCMixtbl";
"CCMixmap";
"CCRingBuffer"
];
lib_pack = false;
lib_internal_modules = [];
@ -7507,7 +7552,13 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{
lib_modules = ["Lwt_automaton"; "Lwt_actor"];
lib_modules =
[
"Lwt_automaton";
"Lwt_actor";
"Lwt_klist";
"Lwt_pipe"
];
lib_pack = true;
lib_internal_modules = [];
lib_findlib_parent = Some "containers";
@ -7571,7 +7622,7 @@ let setup_t =
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "benchs/";
bs_compiled_object = Native;
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "containers";
@ -7612,7 +7663,7 @@ let setup_t =
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "benchs/";
bs_compiled_object = Native;
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "containers";
@ -7719,11 +7770,14 @@ let setup_t =
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "tests", true)
(OASISExpr.EAnd
(OASISExpr.EFlag "tests",
OASISExpr.EFlag "bigarray"),
true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "qtest/";
bs_compiled_object = Native;
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "containers";
@ -7750,6 +7804,46 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{exec_custom = false; exec_main_is = "run_qtest.ml"});
Executable
({
cs_name = "run_qtest_lwt";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EAnd
(OASISExpr.EFlag "tests",
OASISExpr.EFlag "lwt"),
true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "qtest/lwt/";
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "containers";
InternalLibrary "containers_lwt";
FindlibPackage ("lwt", None);
FindlibPackage ("lwt.unix", None);
FindlibPackage ("sequence", None);
FindlibPackage ("gen", None);
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_lwt.ml"});
Executable
({
cs_name = "run_tests";
@ -7767,7 +7861,7 @@ let setup_t =
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "tests/";
bs_compiled_object = Native;
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "containers";
@ -7824,6 +7918,39 @@ let setup_t =
InternalExecutable "run_qtest"
]
});
Test
({
cs_name = "lwt";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
test_type = (`Test, "custom", Some "0.4");
test_command =
[
(OASISExpr.EBool true,
("echo",
["\"test"; "lwt\";"; "./run_qtest_lwt.native"]))
];
test_custom =
{
pre_command = [(OASISExpr.EBool true, None)];
post_command = [(OASISExpr.EBool true, None)]
};
test_working_directory = None;
test_run =
[
(OASISExpr.ENot (OASISExpr.EFlag "tests"), false);
(OASISExpr.EFlag "tests", false);
(OASISExpr.EAnd
(OASISExpr.EFlag "tests",
OASISExpr.EAnd
(OASISExpr.EFlag "tests",
OASISExpr.EFlag "lwt")),
true)
];
test_tools = [ExternalTool "ocamlbuild"]
});
Executable
({
cs_name = "lambda";
@ -7838,7 +7965,7 @@ let setup_t =
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "examples/";
bs_compiled_object = Byte;
bs_compiled_object = Best;
bs_build_depends =
[
InternalLibrary "containers";
@ -7869,7 +7996,7 @@ let setup_t =
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "examples/";
bs_compiled_object = Native;
bs_compiled_object = Best;
bs_build_depends = [InternalLibrary "containers_sexp"];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
@ -7896,7 +8023,7 @@ let setup_t =
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "examples/";
bs_compiled_object = Native;
bs_compiled_object = Best;
bs_build_depends = [InternalLibrary "containers_sexp"];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
@ -7936,7 +8063,7 @@ let setup_t =
};
oasis_fn = Some "_oasis";
oasis_version = "0.4.5";
oasis_digest = Some "\164\188^\018\173\181\135}#\017\164\201S\134\171+";
oasis_digest = Some "\180\018\197c\134\002\173(\245'\138\144\0262\197z";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false
@ -7944,6 +8071,6 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
# 7948 "setup.ml"
# 8075 "setup.ml"
(* OASIS_STOP *)
let () = setup ();;

5
src/core/CCFormat.ml
View file

@ -82,7 +82,10 @@ let seq ?(start="[") ?(stop="]") ?(sep=", ") pp fmt seq =
Format.pp_print_string fmt start;
let first = ref true in
seq (fun x ->
(if !first then first := false else Format.pp_print_string fmt sep);
(if !first then first := false else (
Format.pp_print_string fmt sep;
Format.pp_print_cut fmt ();
));
pp fmt x);
Format.pp_print_string fmt stop

58
src/core/CCRef.ml Normal file
View file

@ -0,0 +1,58 @@
(*
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 References}
@since 0.9 *)
type 'a print = Format.formatter -> 'a -> unit
type 'a pp = Buffer.t -> 'a -> unit
type 'a ord = 'a -> 'a -> int
type 'a eq = 'a -> 'a -> bool
type 'a sequence = ('a -> unit) -> unit
type 'a t = 'a ref
let create x = ref x
let map f r = ref (f !r)
let iter f r = f !r
let update f r = r := (f !r)
let compare f r1 r2 = f !r1 !r2
let equal f r1 r2 = f !r1 !r2
let to_list r = [!r]
let to_seq r yield = yield !r
let print pp_x fmt r = pp_x fmt !r
let pp pp_x buf r = pp_x buf !r

60
src/core/CCRef.mli Normal file
View file

@ -0,0 +1,60 @@
(*
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 References}
@since 0.9 *)
type 'a print = Format.formatter -> 'a -> unit
type 'a pp = Buffer.t -> 'a -> unit
type 'a ord = 'a -> 'a -> int
type 'a eq = 'a -> 'a -> bool
type 'a sequence = ('a -> unit) -> unit
type 'a t = 'a ref
val map : ('a -> 'b) -> 'a t -> 'b t
(** Transform the value *)
val create : 'a -> 'a t
(** Alias to {!ref} *)
val iter : ('a -> unit) -> 'a t -> unit
(** Call the function on the content of the reference *)
val update : ('a -> 'a) -> 'a t -> unit
(** Update the reference's content with the given function *)
val compare : 'a ord -> 'a t ord
val equal : 'a eq -> 'a t eq
val to_list : 'a t -> 'a list
val to_seq : 'a t -> 'a sequence
val print : 'a print -> 'a t print
val pp : 'a pp -> 'a t pp

86
src/core/CCSet.ml Normal file
View file

@ -0,0 +1,86 @@
(*
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 Wrapper around Set} *)
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 Set.S
val of_seq : elt sequence -> t
val to_seq : t -> elt sequence
val of_list : elt list -> t
val to_list : t -> elt list
val pp : ?start:string -> ?stop:string -> ?sep:string ->
elt printer -> t printer
val print : ?start:string -> ?stop:string -> ?sep:string ->
elt formatter -> t formatter
end
module Make(O : Map.OrderedType) = struct
include Set.Make(O)
let of_seq s =
let set = ref empty in
s (fun x -> set := add x !set);
!set
let to_seq s yield = iter yield s
let of_list l = List.fold_left (fun set x -> add x set) empty l
let to_list = elements
let pp ?(start="{") ?(stop="}") ?(sep=", ") pp_x buf m =
let first = ref true in
Buffer.add_string buf start;
iter
(fun x ->
if !first then first := false else Buffer.add_string buf sep;
pp_x buf x;
) m;
Buffer.add_string buf stop
let print ?(start="[") ?(stop="]") ?(sep=", ") pp_x fmt m =
Format.pp_print_string fmt start;
let first = ref true in
iter
(fun x ->
if !first then first := false else Format.pp_print_string fmt sep;
pp_x fmt x;
Format.pp_print_cut fmt ()
) m;
Format.pp_print_string fmt stop
end

55
src/core/CCSet.mli Normal file
View file

@ -0,0 +1,55 @@
(*
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 Wrapper around Set}
@since 0.9 *)
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 Set.S
val of_seq : elt sequence -> t
val to_seq : t -> elt sequence
val of_list : elt list -> t
val to_list : t -> elt list
val pp : ?start:string -> ?stop:string -> ?sep:string ->
elt printer -> t printer
val print : ?start:string -> ?stop:string -> ?sep:string ->
elt formatter -> t formatter
end
module Make(O : Set.OrderedType) : S
with type t = Set.Make(O).t
and type elt = O.t

27
src/core/META
View file

@ -1,6 +1,6 @@
# OASIS_START
# DO NOT EDIT (digest: 705ba14648d64b87e0e63d055ec5c801)
version = "0.8"
# DO NOT EDIT (digest: 71114627b2165c5eaff8d7c614d71974)
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "bytes"
archive(byte) = "containers.cma"
@ -9,7 +9,7 @@ archive(native) = "containers.cmxa"
archive(native, plugin) = "containers.cmxs"
exists_if = "containers.cma"
package "thread" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "containers threads"
archive(byte) = "containers_thread.cma"
@ -20,7 +20,7 @@ package "thread" (
)
package "string" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
archive(byte) = "containers_string.cma"
archive(byte, plugin) = "containers_string.cma"
@ -30,7 +30,7 @@ package "string" (
)
package "sexp" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "bytes"
archive(byte) = "containers_sexp.cma"
@ -41,7 +41,7 @@ package "sexp" (
)
package "pervasives" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "containers"
archive(byte) = "containers_pervasives.cma"
@ -52,7 +52,7 @@ package "pervasives" (
)
package "misc" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "containers containers.data"
archive(byte) = "containers_misc.cma"
@ -63,7 +63,7 @@ package "misc" (
)
package "lwt" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "containers lwt containers.misc"
archive(byte) = "containers_lwt.cma"
@ -74,7 +74,7 @@ package "lwt" (
)
package "iter" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
archive(byte) = "containers_iter.cma"
archive(byte, plugin) = "containers_iter.cma"
@ -84,7 +84,7 @@ package "iter" (
)
package "io" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "bytes"
archive(byte) = "containers_io.cma"
@ -95,8 +95,9 @@ package "io" (
)
package "data" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "bytes"
archive(byte) = "containers_data.cma"
archive(byte, plugin) = "containers_data.cma"
archive(native) = "containers_data.cmxa"
@ -105,7 +106,7 @@ package "data" (
)
package "bigarray" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "containers bigarray bytes"
archive(byte) = "containers_bigarray.cma"
@ -116,7 +117,7 @@ package "bigarray" (
)
package "advanced" (
version = "0.8"
version = "0.9"
description = "A modular standard library focused on data structures."
requires = "containers sequence"
archive(byte) = "containers_advanced.cma"

4
src/core/containers.mldylib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 3d72facd851c70180466c198284f087a)
# DO NOT EDIT (digest: 5c58c781604360016ba544a7c9d0c597)
CCVector
CCPrint
CCError
@ -13,6 +13,8 @@ CCInt
CCBool
CCFloat
CCArray
CCRef
CCSet
CCOrd
CCRandom
CCString

4
src/core/containers.mllib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 3d72facd851c70180466c198284f087a)
# DO NOT EDIT (digest: 5c58c781604360016ba544a7c9d0c597)
CCVector
CCPrint
CCError
@ -13,6 +13,8 @@ CCInt
CCBool
CCFloat
CCArray
CCRef
CCSet
CCOrd
CCRandom
CCString

27
src/data/CCCache.ml
View file

@ -33,6 +33,13 @@ let default_hash_ = Hashtbl.hash
(** {2 Value interface} *)
(** Invariants:
- after [cache.set x y], [get cache x] must return [y] or raise [Not_found]
- [cache.set x y] is only called if [get cache x] fails, never if [x] is already bound
- [cache.size()] must be positive and correspond to the number of items in [cache.iter]
- [cache.iter f] calls [f x y] with every [x] such that [cache.get x = y]
- after [cache.clear()], [cache.get x] fails for every [x]
*)
type ('a,'b) t = {
set : 'a -> 'b -> unit;
get : 'a -> 'b; (* or raise Not_found *)
@ -293,6 +300,24 @@ let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
iter=L.iter c;
}
(*$T
let eq (i1,_)(i2,_) = i1=i2 and hash (i,_) = CCInt.hash i in \
let c = lru ~eq ~hash 2 in \
ignore (with_cache c CCFun.id (1, true)); \
ignore (with_cache c CCFun.id (1, false)); \
with_cache c CCFun.id (1, false) = (1, true)
*)
(*$T
let f = (let r = ref 0 in fun _ -> incr r; !r) in \
let c = lru 2 in \
let res1 = with_cache c f 1 in \
let res2 = with_cache c f 2 in \
let res3 = with_cache c f 3 in \
let res1_bis = with_cache c f 1 in \
res1 <> res2 && res2 <> res3 && res3 <> res1_bis && res1_bis <> res1
*)
module UNBOUNDED(X:HASH) = struct
module H = Hashtbl.Make(X)
@ -305,7 +330,7 @@ module UNBOUNDED(X:HASH) = struct
let get c x = H.find c x
let set c x y = H.replace c x y
let size c () = H.length c
let iter c f = H.iter f c

162
src/data/CCMixmap.ml Normal file
View file

@ -0,0 +1,162 @@
(*
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 Hash Table with Heterogeneous Keys} *)
type 'b injection = {
get : (unit -> unit) -> 'b option;
set : 'b -> (unit -> unit);
}
let create_inj () =
let r = ref None in
let get f =
r := None;
f ();
!r
and set v =
(fun () -> r := Some v)
in
{get;set}
module type S = sig
type key
type t
(** A map containing values of different types, indexed by {!key}. *)
val empty : t
(** Empty map *)
val get : inj:'a injection -> t -> key -> 'a option
(** Get the value corresponding to this key, if it exists and
belongs to the same key *)
val add : inj:'a injection -> t -> key -> 'a -> t
(** Bind the key to the value, using [inj] *)
val find : inj:'a injection -> t -> key -> 'a
(** Find the value for the given key, which must be of the right type.
@raise Not_found if either the key is not found, or if its value
doesn't belong to the right type *)
val cardinal : t -> int
(** Number of bindings *)
val remove : t -> key -> t
(** Remove the binding for this key *)
val mem : inj:_ injection-> t -> key -> bool
(** Is the given key in the map, with the right type? *)
val iter_keys : f:(key -> unit) -> t -> unit
(** Iterate on the keys of this map *)
val fold_keys : f:('a -> key -> 'a) -> x:'a -> t -> 'a
(** Fold over the keys *)
(** {2 Iterators} *)
type 'a sequence = ('a -> unit) -> unit
val keys_seq : t -> key sequence
(** All the keys *)
val bindings_of : inj:'a injection -> t -> (key * 'a) sequence
(** All the bindings that come from the corresponding injection *)
type value =
| Value : ('a injection -> 'a option) -> value
val bindings : t -> (key * value) sequence
(** Iterate on all bindings *)
end
module type ORD = sig
type t
val compare : t -> t -> int
end
module Make(X : ORD) : S with type key = X.t = struct
module M = Map.Make(X)
type key = X.t
type t = (unit -> unit) M.t
let empty = M.empty
let find ~inj map x =
match inj.get (M.find x map) with
| None -> raise Not_found
| Some v -> v
let get ~inj map x =
try inj.get (M.find x map)
with Not_found -> None
let add ~inj map x y =
M.add x (inj.set y) map
let cardinal = M.cardinal
let remove map x = M.remove x map
let mem ~inj map x =
try
inj.get (M.find x map) <> None
with Not_found -> false
let iter_keys ~f map =
M.iter (fun x _ -> f x) map
let fold_keys ~f ~x map =
M.fold (fun x _ acc -> f acc x) map x
(** {2 Iterators} *)
type 'a sequence = ('a -> unit) -> unit
let keys_seq map yield =
M.iter
(fun x _ -> yield x)
map
let bindings_of ~inj map yield =
M.iter
(fun k value ->
match inj.get value with
| None -> ()
| Some v -> yield (k, v)
) map
type value =
| Value : ('b injection -> 'b option) -> value
let bindings map yield =
M.iter
(fun x y -> yield (x, Value (fun inj -> inj.get y)))
map
end

102
src/data/CCMixmap.mli Normal file
View file

@ -0,0 +1,102 @@
(*
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 Maps with Heterogeneous Values}
{b status: experimental}
@since 0.9 *)
type 'a injection
(** An accessor for values of type 'a in any map. Values put
in the map using an key can only be retrieved using this
very same key. *)
val create_inj : unit -> 'a injection
(** Return a value that works for a given type of values. This function is
normally called once for each type of value. Several keys may be
created for the same type, but a value set with a given setter can only be
retrieved with the matching getter. The same key can be reused
across multiple maps (although not in a thread-safe way). *)
module type S = sig
type key
type t
(** A map containing values of different types, indexed by {!key}. *)
val empty : t
(** Empty map *)
val get : inj:'a injection -> t -> key -> 'a option
(** Get the value corresponding to this key, if it exists and
belongs to the same key *)
val add : inj:'a injection -> t -> key -> 'a -> t
(** Bind the key to the value, using [inj] *)
val find : inj:'a injection -> t -> key -> 'a
(** Find the value for the given key, which must be of the right type.
@raise Not_found if either the key is not found, or if its value
doesn't belong to the right type *)
val cardinal : t -> int
(** Number of bindings *)
val remove : t -> key -> t
(** Remove the binding for this key *)
val mem : inj:_ injection-> t -> key -> bool
(** Is the given key in the map, with the right type? *)
val iter_keys : f:(key -> unit) -> t -> unit
(** Iterate on the keys of this map *)
val fold_keys : f:('a -> key -> 'a) -> x:'a -> t -> 'a
(** Fold over the keys *)
(** {2 Iterators} *)
type 'a sequence = ('a -> unit) -> unit
val keys_seq : t -> key sequence
(** All the keys *)
val bindings_of : inj:'a injection -> t -> (key * 'a) sequence
(** All the bindings that come from the corresponding injection *)
type value =
| Value : ('a injection -> 'a option) -> value
val bindings : t -> (key * value) sequence
(** Iterate on all bindings *)
end
module type ORD = sig
type t
val compare : t -> t -> int
end
module Make(X : ORD) : S with type key = X.t

4
src/data/CCMixtbl.mli
View file

@ -82,8 +82,8 @@ val set : inj:'b injection -> 'a t -> 'a -> 'b -> unit
val find : inj:'b injection -> 'a t -> 'a -> 'b
(** Find the value for the given key, which must be of the right type.
raises Not_found if either the key is not found, or if its value
doesn't belong to the right type *)
@raise Not_found if either the key is not found, or if its value
doesn't belong to the right type *)
val length : 'a t -> int
(** Number of bindings *)

671
src/data/CCRingBuffer.ml Normal file
View file

@ -0,0 +1,671 @@
(*
* CCRingBuffer - Polymorphic circular buffer with
* deque semantics for accessing both the head and tail.
*
* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version,
* with the special exception on linking described in file LICENSE.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
(** Polymorphic Circular Buffer for IO *)
module Array = struct
(** The abstract type for arrays *)
module type S = sig
(** The element type *)
type elt
(** The type of an array instance *)
type t
val empty : t
(** The empty array *)
val make: int -> elt -> t
(** [make s e] makes an array of size [s] with [e] elements *)
val length: t -> int
(** [length t] gets the total number of elements currently in [t] *)
val get: t -> int -> elt
(** [get t i] gets the element at position [i] *)
val set: t -> int -> elt -> unit
(** [set t i e] sets the element at position [i] to [e] *)
val sub: t -> int -> int -> t
(** [sub t i len] gets the subarray of [t] from
position [i] to [i + len] *)
val copy : t -> t
(** [copy t] makes a fresh copy of the array [t] *)
val blit : t -> int -> t -> int -> int -> unit
(** [blit t s arr i len] copies [len] elements from [arr] starting at [i]
to position [s] from [t] *)
val iter : (elt -> unit) -> t -> unit
(** [iter f t] iterates over the array [t] invoking [f] with
the current element, in array order *)
end
module Byte :
S with type elt = char and type t = Bytes.t = struct
type elt = char
include Bytes
end
module Make(Elt:sig type t end) :
S with type elt = Elt.t and type t = Elt.t array = struct
type elt = Elt.t
type t = Elt.t array
let make = Array.make
let length = Array.length
let get = Array.get
let set = Array.set
let copy = Array.copy
let blit = Array.blit
let iter = Array.iter
let sub = Array.sub
let empty = Array.of_list []
end
end
module type S = sig
(** The module type of Array for this ring buffer *)
module Array : Array.S
(** Defines the ring buffer type, with both bounded and
unbounded flavors *)
type t
(** Raised in querying functions when the buffer is empty *)
exception Empty
val create : ?bounded:bool -> int -> t
(** [create ?bounded size] creates a new buffer with given size.
Defaults to [bounded=false]. *)
val copy : t -> t
(** Make a fresh copy of the buffer. *)
val capacity : t -> int
(** Length of the inner buffer. *)
val max_capacity : t -> int option
(** Maximum length of the inner buffer, or [None] if unbounded. *)
val length : t -> int
(** Number of elements currently stored in the buffer. *)
val blit_from : t -> Array.t -> int -> int -> unit
(** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from
a input buffer [from_buf] to the end of the buffer.
@raise Invalid_argument if [o,len] is not a valid slice of [s] *)
val blit_into : t -> Array.t -> int -> int -> int
(** [blit_into buf to_buf o len] copies at most [len] elements from [buf]
into [to_buf] starting at offset [o] in [s].
@return the number of elements actually copied ([min len (length buf)]).
@raise Invalid_argument if [o,len] is not a valid slice of [s] *)
val append : t -> into:t -> unit
(** [append b ~into] copies all data from [b] and adds it at the
end of [into] *)
val to_list : t -> Array.elt list
(** Extract the current content into a list *)
val clear : t -> unit
(** Clear the content of the buffer. Doesn't actually destroy the content. *)
val reset : t -> unit
(** Clear the content of the buffer, and also resize it to a default size *)
val is_empty :t -> bool
(** Is the buffer empty (i.e. contains no elements)? *)
val junk_front : t -> unit
(** Drop the front element from [t].
@raise Empty if the buffer is already empty. *)
val junk_back : t -> unit
(** Drop the back element from [t].
@raise Empty if the buffer is already empty. *)
val skip : t -> int -> unit
(** [skip b len] removes [len] elements from the front of [b].
@raise Invalid_argument if [len > length b]. *)
val iter : t -> f:(Array.elt -> unit) -> unit
(** [iter b ~f] calls [f i t] for each element [t] in [buf] *)
val iteri : t -> f:(int -> Array.elt -> unit) -> unit
(** [iteri b ~f] calls [f i t] for each element [t] in [buf], with [i]
being its relative index within [buf]. *)
val get_front : t -> int -> Array.elt
(** [get_front buf i] returns the [i]-th element of [buf] from the front, ie
the one returned by [take_front buf] after [i-1] calls to [junk_front buf].
@raise Invalid_argument if the index is invalid (> [length buf]) *)
val get_back : t -> int -> Array.elt
(** [get_back buf i] returns the [i]-th element of [buf] from the back, ie
the one returned by [take_back buf] after [i-1] calls to [junk_back buf].
@raise Invalid_argument if the index is invalid (> [length buf]) *)
val push_back : t -> Array.elt -> unit
(** Push value at the back of [t].
If [t.bounded=false], the buffer will grow as needed,
otherwise the oldest elements are replaced first. *)
val peek_front : t -> Array.elt
(** First value from front of [t].
@raise Empty if buffer is empty. *)
val peek_back : t -> Array.elt
(** Get the last value from back of [t].
@raise Empty if buffer is empty. *)
val take_back : t -> Array.elt option
(** Take the last value from back of [t], if any *)
val take_back_exn : t -> Array.elt
(** Take the last value from back of [t].
@raise Empty if buffer is already empty. *)
val take_front : t -> Array.elt option
(** Take the first value from front of [t], if any *)
val take_front_exn : t -> Array.elt
(** Take the first value from front of [t].
@raise Empty if buffer is already empty. *)
end
module MakeFromArray(Array:Array.S) = struct
module Array = Array
type t = {
mutable start : int;
mutable stop : int; (* excluded *)
mutable buf : Array.t;
bounded : bool;
size : int
}
exception Empty
let create ?(bounded=false) size =
{ start=0;
stop=0;
bounded;
size;
buf = Array.empty
}
let copy b =
{ b with buf=Array.copy b.buf; }
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
let b' = Byte.copy b in \
try Byte.iteri b (fun i c -> if Byte.get_front b' i <> c then raise Exit); true with Exit -> false)
*)
let capacity b =
let len = Array.length b.buf in
match len with 0 -> 0 | l -> l - 1
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
Byte.capacity b >= s_len)
*)
(*$Q
(Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
let i = abs i in \
let s_len = Bytes.length s in \
let b = Byte.create ~bounded:true i in \
Byte.blit_from b s 0 s_len; \
Byte.capacity b <= i)
*)
let max_capacity b = if b.bounded then Some b.size else None
(*$Q
Q.small_int (fun i -> \
let i = abs i in \
let b = Byte.create i in \
Byte.max_capacity b = None)
*)
(*$Q
Q.small_int (fun i -> \
let i = abs i in \
let b = Byte.create ~bounded:true i in \
Byte.max_capacity b = Some i)
*)
let length b =
if b.stop >= b.start
then b.stop - b.start
else (Array.length b.buf - b.start) + b.stop
(*$Q
(Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
let i = abs i in \
let s_len = Bytes.length s in \
let b = Byte.create i in \
Byte.blit_from b s 0 s_len; \
Byte.length b = s_len)
*)
(*$Q
(Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
let i = abs i in \
let s_len = Bytes.length s in \
let b = Byte.create ~bounded:true i in \
Byte.blit_from b s 0 s_len; \
Byte.length b >= 0 && Byte.length b <= i)
*)
(* resize [b] so that inner capacity is [cap] *)
let resize b cap elem =
assert (cap >= Array.length b.buf);
let buf' = Array.make cap elem in
(* copy into buf' *)
if b.stop >= b.start
then
Array.blit b.buf b.start buf' 0 (b.stop - b.start)
else begin
let len_end = Array.length b.buf - b.start in
Array.blit b.buf b.start buf' 0 len_end;
Array.blit b.buf 0 buf' len_end b.stop;
end;
b.buf <- buf'
let blit_from_bounded b from_buf o len =
let cap = capacity b - length b in
(* resize if needed, with a constant to amortize *)
if cap < len then (
let new_size =
let desired = Array.length b.buf + len + 24 in
min (b.size+1) desired in
resize b new_size from_buf.(0);
let good = capacity b = b.size || capacity b - length b >= len in
assert good;
);
let sub = Array.sub from_buf o len in
let iter x =
let capacity = Array.length b.buf in
Array.set b.buf b.stop x;
if b.stop = capacity-1 then b.stop <- 0 else b.stop <- b.stop + 1;
if b.start = b.stop then
if b.start = capacity-1 then b.start <- 0 else b.start <- b.start + 1
in
Array.iter iter sub
let blit_from_unbounded b from_buf o len =
let cap = capacity b - length b in
(* resize if needed, with a constant to amortize *)
if cap < len then resize b (max (b.size+1) (Array.length b.buf + len + 24)) from_buf.(0);
let good = capacity b - length b >= len in
assert good;
if b.stop >= b.start
then (* [_______ start xxxxxxxxx stop ______] *)
let len_end = Array.length b.buf - b.stop in
if len_end >= len
then (Array.blit from_buf o b.buf b.stop len;
b.stop <- b.stop + len)
else (Array.blit from_buf o b.buf b.stop len_end;
Array.blit from_buf (o+len_end) b.buf 0 (len-len_end);
b.stop <- len-len_end)
else begin (* [xxxxx stop ____________ start xxxxxx] *)
let len_middle = b.start - b.stop in
assert (len_middle >= len);
Array.blit from_buf o b.buf b.stop len;
b.stop <- b.stop + len
end;
()
let blit_from b from_buf o len =
if Array.length from_buf = 0 then () else
if b.bounded then
blit_from_bounded b from_buf o len
else
blit_from_unbounded b from_buf o len
(*$Q
(Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \
(let b = Byte.create 24 in \
Byte.blit_from b s 0 (Bytes.length s); \
Byte.blit_from b s' 0 (Bytes.length s'); \
Byte.length b = Bytes.length s + Bytes.length s'))
*)
(*$Q
(Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \
(let b = Byte.create ~bounded:true (Bytes.length s + Bytes.length s') in \
Byte.blit_from b s 0 (Bytes.length s); \
Byte.blit_from b s' 0 (Bytes.length s'); \
Byte.length b = Bytes.length s + Bytes.length s'))
*)
let blit_into b to_buf o len =
if o+len > Array.length to_buf
then invalid_arg "RingBuffer.blit_into";
if b.stop >= b.start
then
let n = min (b.stop - b.start) len in
let _ = Array.blit b.buf b.start to_buf o n in
n
else begin
let len_end = Array.length b.buf - b.start in
Array.blit b.buf b.start to_buf o (min len_end len);
if len_end >= len
then len (* done *)
else begin
let n = min b.stop (len - len_end) in
Array.blit b.buf 0 to_buf (o+len_end) n;
n + len_end
end
end
(*$Q
Q.printable_string (fun s -> \
let b = Byte.create (Bytes.length s) in \
Byte.blit_from b s 0 (Bytes.length s); \
let to_buf = Bytes.create (Bytes.length s) in \
let len = Byte.blit_into b to_buf 0 (Bytes.length s) in \
to_buf = s && len = Bytes.length s)
*)
let clear b =
b.stop <- 0;
b.start <- 0;
()
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
Byte.clear b; \
Byte.length b = 0)
*)
let reset b =
clear b;
b.buf <- Array.empty
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
Byte.reset b; \
Byte.length b = 0 && Byte.capacity b = 0)
*)
let is_empty b = b.start = b.stop
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
Byte.skip b s_len; \
Byte.is_empty b)
*)
let take_front_exn b =
if b.start = b.stop then raise Empty;
let c = b.buf.(b.start) in
if b.start + 1 = Array.length b.buf
then b.start <- 0
else b.start <- b.start + 1;
c
let take_front b = try Some (take_front_exn b) with Empty -> None
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try let front = Byte.take_front_exn b in \
front = Bytes.get s 0 with Byte.Empty -> s_len = 0)
*)
let take_back_exn b =
if b.start = b.stop then raise Empty;
if b.stop - 1 = 0
then b.stop <- Array.length b.buf - 1
else b.stop <- b.stop - 1;
b.buf.(b.stop)
let take_back b = try Some (take_back_exn b) with Empty -> None
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try let back = Byte.take_back_exn b in \
back = Bytes.get s (Bytes.length s - 1) with Byte.Empty -> s_len = 0)
*)
let junk_front b =
if b.start = b.stop then raise Empty;
if b.start + 1 = Array.length b.buf
then b.start <- 0
else b.start <- b.start + 1
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try let () = Byte.junk_front b in \
s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0)
*)
let junk_back b =
if b.start = b.stop then raise Empty;
if b.stop = 0
then b.stop <- Array.length b.buf - 1
else b.stop <- b.stop - 1
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try let () = Byte.junk_back b in \
s_len - 1 = Byte.length b with Byte.Empty -> s_len = 0)
*)
let skip b len =
if len > length b then
invalid_arg ("CCRingRingBuffer.skip: " ^ string_of_int len);
if b.stop >= b.start
then b.start <- b.start + len
else
let len_end = Array.length b.buf - b.start in
if len > len_end
then b.start <- len-len_end (* wrap to the beginning *)
else b.start <- b.start + len
(*$Q
(Q.pair Q.printable_string Q.printable_string) (fun (s,s') -> \
(let b = Byte.create 24 in \
Byte.blit_from b s 0 (Bytes.length s); \
Byte.blit_from b s' 0 (Bytes.length s'); \
Byte.blit_from b "hello world" 0 (Bytes.length "hello world"); (* big enough *) \
let l = Byte.length b in let l' = l/2 in Byte.skip b l'; \
Byte.length b + l' = l))
*)
let iter b ~f =
if b.stop >= b.start
then for i = b.start to b.stop - 1 do f b.buf.(i) done
else (
for i = b.start to Array.length b.buf -1 do f b.buf.(i) done;
for i = 0 to b.stop - 1 do f b.buf.(i) done;
)
let iteri b ~f =
if b.stop >= b.start
then for i = b.start to b.stop - 1 do f i b.buf.(i) done
else (
for i = b.start to Array.length b.buf -1 do f i b.buf.(i) done;
for i = 0 to b.stop - 1 do f i b.buf.(i) done;
)
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try Byte.iteri b (fun i c -> if Byte.get_front b i <> c then raise Exit); \
true with Exit -> false)
*)
let get b i =
if b.stop >= b.start
then
if i >= b.stop - b.start
then invalid_arg ("CCRingBuffer.get:" ^ string_of_int i)
else b.buf.(b.start + i)
else
let len_end = Array.length b.buf - b.start in
if i < len_end
then b.buf.(b.start + i)
else if i - len_end > b.stop
then invalid_arg ("CCRingBuffer.get: " ^ string_of_int i)
else b.buf.(i - len_end)
let get_front b i =
if is_empty b then
invalid_arg ("CCRingBuffer.get_front: " ^ string_of_int i)
else
get b i
(*$Q
(Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
let s = s ^ " " in \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
let index = abs (i mod Byte.length b) in \
let front = Byte.get_front b index in \
front = Bytes.get s index)
*)
let get_back b i =
let offset = ((length b) - i - 1) in
if offset < 0 then
raise (Invalid_argument ("CCRingBuffer.get_back:" ^ string_of_int i))
else get b offset
(*$Q
(Q.pair Q.small_int Q.printable_string) (fun (i, s) -> \
let s = s ^ " " in \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
let index = abs (i mod Byte.length b) in \
let back = Byte.get_back b index in \
back = Bytes.get s (s_len - index - 1))
*)
let to_list b =
let len = length b in
let rec build l i =
if i < 0 then l else
build ((get_front b i)::l) (i-1) in
build [] (len-1)
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
let l = Byte.to_list b in \
let explode s = let rec exp i l = \
if i < 0 then l else exp (i - 1) (s.[i] :: l) in \
exp (Bytes.length s - 1) [] in \
explode s = l)
*)
let push_back b e = blit_from b (Array.make 1 e) 0 1
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
Byte.push_back b 'X'; \
Byte.peek_back b = 'X')
*)
(* TODO: more efficient version *)
let append b ~into =
iter b ~f:(push_back into)
let peek_front b =
if is_empty b then raise Empty
else Array.get b.buf b.start
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try let back = Byte.peek_front b in \
back = Bytes.get s 0 with Byte.Empty -> s_len = 0)
*)
let peek_back b = if is_empty b
then raise Empty
else Array.get b.buf
(if b.stop = 0 then capacity b - 1 else b.stop-1)
(*$Q
Q.printable_string (fun s -> \
let s_len = Bytes.length s in \
let b = Byte.create s_len in \
Byte.blit_from b s 0 s_len; \
try let back = Byte.peek_back b in \
back = Bytes.get s (s_len - 1) with Byte.Empty -> s_len = 0)
*)
end
module Byte = MakeFromArray(Array.Byte)
module Make(Elt:sig type t end) = MakeFromArray(Array.Make(Elt))

204
src/data/CCRingBuffer.mli Normal file
View file

@ -0,0 +1,204 @@
(**
* CCRingBuffer - Polymorphic Circular Buffer
* Copyright (C) 2015 Simon Cruanes, Carmelo Piccione
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version,
* with the special exception on linking described in file LICENSE.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
(** {1 Circular Buffer (Deque)}
Useful for IO, or as a general-purpose alternative to {!Queue} when
batch operations are needed.
{b status: experimental}
@since 0.9
*)
(** {2 Underlying Array} *)
(** The abstract type for arrays *)
module Array : sig
module type S = sig
(** The element type *)
type elt
(** The type of an array instance *)
type t
val empty : t
(** The empty array *)
val make: int -> elt -> t
(** [make s e] makes an array of size [s] with [e] elements *)
val length: t -> int
(** [length t] gets the total number of elements currently in [t] *)
val get: t -> int -> elt
(** [get t i] gets the element at position [i] *)
val set: t -> int -> elt -> unit
(** [set t i e] sets the element at position [i] to [e] *)
val sub: t -> int -> int -> t
(** [sub t i len] gets the subarray of [t] from
position [i] to [i + len] *)
val copy : t -> t
(** [copy t] makes a fresh copy of the array [t] *)
val blit : t -> int -> t -> int -> int -> unit
(** [blit t s arr i len] copies [len] elements from [arr] starting at [i]
to position [s] from [t] *)
val iter : (elt -> unit) -> t -> unit
(** [iter f t] iterates over the array [t] invoking [f] with
the current element, in array order *)
end
(** Efficient array version for the [char] type *)
module Byte :
S with type elt = char and type t = Bytes.t
(** Makes an array given an arbitrary element type *)
module Make(Elt:sig type t end) :
S with type elt = Elt.t and type t = Elt.t array
end
(** {2 Ring Buffer}
The abstract ring buffer type, made concrete by choice of
[ARRAY] module implementation *)
module type S = sig
(** The module type of Array for this ring buffer *)
module Array : Array.S
(** Defines the ring buffer type, with both bounded and
unbounded flavors *)
type t
(** Raised in querying functions when the buffer is empty *)
exception Empty
val create : ?bounded:bool -> int -> t
(** [create ?bounded size] creates a new buffer with given size.
Defaults to [bounded=false]. *)
val copy : t -> t
(** Make a fresh copy of the buffer. *)
val capacity : t -> int
(** Length of the inner buffer. *)
val max_capacity : t -> int option
(** Maximum length of the inner buffer, or [None] if unbounded. *)
val length : t -> int
(** Number of elements currently stored in the buffer. *)
val blit_from : t -> Array.t -> int -> int -> unit
(** [blit_from buf from_buf o len] copies the slice [o, ... o + len - 1] from
a input buffer [from_buf] to the end of the buffer.
@raise Invalid_argument if [o,len] is not a valid slice of [s] *)
val blit_into : t -> Array.t -> int -> int -> int
(** [blit_into buf to_buf o len] copies at most [len] elements from [buf]
into [to_buf] starting at offset [o] in [s].
@return the number of elements actually copied ([min len (length buf)]).
@raise Invalid_argument if [o,len] is not a valid slice of [s] *)
val append : t -> into:t -> unit
(** [append b ~into] copies all data from [b] and adds it at the
end of [into] *)
val to_list : t -> Array.elt list
(** Extract the current content into a list *)
val clear : t -> unit
(** Clear the content of the buffer. Doesn't actually destroy the content. *)
val reset : t -> unit
(** Clear the content of the buffer, and also resize it to a default size *)
val is_empty :t -> bool
(** Is the buffer empty (i.e. contains no elements)? *)
val junk_front : t -> unit
(** Drop the front element from [t].
@raise Empty if the buffer is already empty. *)
val junk_back : t -> unit
(** Drop the back element from [t].
@raise Empty if the buffer is already empty. *)
val skip : t -> int -> unit
(** [skip b len] removes [len] elements from the front of [b].
@raise Invalid_argument if [len > length b]. *)
val iter : t -> f:(Array.elt -> unit) -> unit
(** [iter b ~f] calls [f i t] for each element [t] in [buf] *)
val iteri : t -> f:(int -> Array.elt -> unit) -> unit
(** [iteri b ~f] calls [f i t] for each element [t] in [buf], with [i]
being its relative index within [buf]. *)
val get_front : t -> int -> Array.elt
(** [get_front buf i] returns the [i]-th element of [buf] from the front, ie
the one returned by [take_front buf] after [i-1] calls to [junk_front buf].
@raise Invalid_argument if the index is invalid (> [length buf]) *)
val get_back : t -> int -> Array.elt
(** [get_back buf i] returns the [i]-th element of [buf] from the back, ie
the one returned by [take_back buf] after [i-1] calls to [junk_back buf].
@raise Invalid_argument if the index is invalid (> [length buf]) *)
val push_back : t -> Array.elt -> unit
(** Push value at the back of [t].
If [t.bounded=false], the buffer will grow as needed,
otherwise the oldest elements are replaced first. *)
val peek_front : t -> Array.elt
(** First value from front of [t].
@raise Empty if buffer is empty. *)
val peek_back : t -> Array.elt
(** Get the last value from back of [t].
@raise Empty if buffer is empty. *)
val take_back : t -> Array.elt option
(** Take the last value from back of [t], if any *)
val take_back_exn : t -> Array.elt
(** Take the last value from back of [t].
@raise Empty if buffer is already empty. *)
val take_front : t -> Array.elt option
(** Take the first value from front of [t], if any *)
val take_front_exn : t -> Array.elt
(** Take the first value from front of [t].
@raise Empty if buffer is already empty. *)
end
(** An efficient byte based ring buffer *)
module Byte : S with module Array = Array.Byte
(** Makes a ring buffer module with the given array type. *)
module MakeFromArray(A : Array.S) : S with module Array = A
(** Buffer using regular arrays *)
module Make(X : sig type t end) : S with type Array.elt = X.t

152
src/data/CCTrie.ml
View file

@ -125,7 +125,7 @@ module Make(W : WORD) = struct
type 'a t =
| Empty
| Path of char_ list * 'a t
| Cons of char_ * 'a t (* simple case *)
| Node of 'a option * 'a t M.t
(* invariants:
@ -136,7 +136,6 @@ module Make(W : WORD) = struct
let empty = Empty
let _invariant = function
| Path ([],_) -> false
| Node (None, map) when M.is_empty map -> false
| _ -> true
@ -164,10 +163,6 @@ module Make(W : WORD) = struct
let _seq_map map k =
M.iter (fun key v -> k (key,v)) map
let _is_path = function
| Path _ -> true
| _ -> false
(* return common prefix, and disjoint suffixes *)
let rec _merge_lists l1 l2 = match l1, l2 with
| [], _
@ -180,41 +175,28 @@ module Make(W : WORD) = struct
else
[], l1, l2
(* prefix [l] to the tree [t] *)
let _mk_path l t = match l, t with
| [], _ -> t
| _, Empty -> Empty
| _, Node _ -> Path (l, t)
| _, Path (l',t') ->
assert (not(_is_path t'));
Path (l@l', t')
let _mk_path_cons x t = match t with
| Empty -> Empty
| Node _ -> Path ([x], t)
| Path (l', t') ->
assert (not(_is_path t'));
Path (x::l', t')
(* sub-tree t prefixed with c *)
let _cons c t = Cons (c, t)
(* build a Node value *)
let _mk_node value map = match value with
| Some _ -> Node (value, map)
| None ->
if M.is_empty map then Empty
else
let high, t' = M.max_binding map in
let low, _ = M.min_binding map in
if W.compare low high = 0
then _mk_path [high] t' (* only one element *)
else Node (value,map)
if M.is_empty map then Empty
else
if M.cardinal map = 1
then
let c, sub = M.min_binding map in
_cons c sub
else Node (value,map)
let _remove_sub c t = match t with
(* remove key [c] from [t] *)
let _remove c t = match t with
| Empty -> t
| Path ([], _) -> assert false
| Path (c'::_, _) ->
if W.compare c c' = 0
then Empty
else t
| Cons (c', _) ->
if W.compare c c' = 0
then Empty
else t
| Node (value, map) ->
if M.mem c map
then
@ -223,29 +205,23 @@ module Make(W : WORD) = struct
else t
let update key f t =
(* [state]: current subtree and rebuild function; [x]: current char *)
(* first arg: current subtree and rebuild function; [c]: current char *)
let goto (t, rebuild) c =
match t with
| Empty -> (t, fun t -> rebuild (_mk_path_cons c t))
| Path ([], _) -> assert false
| Path (c'::l, t') ->
if W.compare c c' = 0
then
(* follow the path *)
_mk_path l t', (fun t -> rebuild (_mk_path_cons c t))
else
(* exit the path, so we have an empty tree. Upon rebuild we
potentially need to make a map *)
let rebuild' new_child =
rebuild (
if is_empty new_child then t
else
let map = M.singleton c new_child in
let map = M.add c' (_mk_path l t') map in
_mk_node None map
)
in
empty, rebuild'
| Empty -> empty, fun t -> rebuild (_cons c t)
| Cons (c', t') ->
if W.compare c c' = 0
then t', (fun t -> rebuild (_cons c t))
else
let rebuild' new_child =
rebuild (
if is_empty new_child then t
else
let map = M.singleton c new_child in
let map = M.add c' t' map in
_mk_node None map
) in
empty, rebuild'
| Node (value, map) ->
try
let t' = M.find c map in
@ -271,13 +247,11 @@ module Make(W : WORD) = struct
in
let finish (t,rebuild) = match t with
| Empty -> rebuild (_mk_node (f None) M.empty)
| Path ([], _) -> assert false
| Path (c::l', t') ->
rebuild (
match f None with
| None -> t (* TODO: raise exception & return original tree *)
| Some _ as v ->
_mk_node v (M.singleton c (_mk_path l' t'))
| Cons (c, t') ->
rebuild
(match f None with
| None -> t
| Some _ as v -> _mk_node v (M.singleton c t')
)
| Node (value, map) ->
let value' = f value in
@ -294,10 +268,9 @@ module Make(W : WORD) = struct
(* at subtree [t], and character [c] *)
let goto t c = match t with
| Empty -> raise Not_found
| Path ([], _) -> assert false
| Path (c'::l, t') ->
| Cons (c', t') ->
if W.compare c c' = 0
then _mk_path l t'
then t'
else raise Not_found
| Node (_, map) -> M.find c map
and finish t = match t with
@ -311,7 +284,6 @@ module Make(W : WORD) = struct
try Some (find_exn k t)
with Not_found -> None
let _difflist_append f l = fun l' -> f (l @ l')
let _difflist_add f x = fun l' -> f (x :: l')
(* fold that also keeps the path from the root, so as to provide the list
@ -319,7 +291,7 @@ module Make(W : WORD) = struct
a function that prepends a list to some suffix *)
let rec _fold f path t acc = match t with
| Empty -> acc
| Path (l, t') -> _fold f (_difflist_append path l) t' acc
| Cons (c, t') -> _fold f (_difflist_add path c) t' acc
| Node (v, map) ->
let acc = match v with
| None -> acc
@ -350,7 +322,7 @@ module Make(W : WORD) = struct
let rec fold_values f acc t = match t with
| Empty -> acc
| Path (_, t') -> fold_values f acc t'
| Cons (_, t') -> fold_values f acc t'
| Node (v, map) ->
let acc = match v with
| None -> acc
@ -365,29 +337,19 @@ module Make(W : WORD) = struct
let rec merge f t1 t2 = match t1, t2 with
| Empty, _ -> t2
| _, Empty -> t1
| Path (l1,t1'), Path (l2,t2') ->
let common, l1', l2' = _merge_lists l1 l2 in
begin match l1', l2' with
| c1::l1'', c2::l2'' ->
(* need to build a map here, to represent the choice
between [c1] and [c2] *)
assert (W.compare c1 c2 <> 0);
let map = M.add c1 (_mk_path l1'' t1') M.empty in
let map = M.add c2 (_mk_path l2'' t2') map in
_mk_path common (Node (None, map))
| _ ->
_mk_path common
(merge f
(_mk_path l1' t1')
(_mk_path l2' t2')
)
end
| Path ([], _), _ -> assert false
| Path (c1::l1, t1'), Node (value, map) ->
| Cons (c1,t1'), Cons (c2,t2') ->
if W.compare c1 c2 = 0
then _cons c1 (merge f t1' t2')
else
let map = M.add c1 t1' M.empty in
let map = M.add c2 t2' map in
_mk_node None map
| Cons (c1, t1'), Node (value, map) ->
begin try
(* collision *)
let t2' = M.find c1 map in
let new_t = merge f (_mk_path l1 t1') t2' in
let new_t = merge f t1' t2' in
let map' = if is_empty new_t
then M.remove c1 map
else M.add c1 new_t map
@ -396,9 +358,9 @@ module Make(W : WORD) = struct
with Not_found ->
(* no collision *)
assert (not(is_empty t1'));
Node (value, M.add c1 (_mk_path l1 t1') map)
Node (value, M.add c1 t1' map)
end
| Node _, Path _ -> merge f t2 t1 (* previous case *)
| Node _, Cons _ -> merge f t2 t1 (* previous case *)
| Node(v1, map1), Node (v2, map2) ->
let v = match v1, v2 with
| None, _ -> v2
@ -419,7 +381,7 @@ module Make(W : WORD) = struct
let rec size t = match t with
| Empty -> 0
| Path (_, t') -> size t'
| Cons (_, t') -> size t'
| Node (v, map) ->
let s = if v=None then 0 else 1 in
M.fold
@ -442,8 +404,7 @@ module Make(W : WORD) = struct
let _tree_node x l () = `Node (x,l) in
match t with
| Empty -> `Nil
| Path ([], _) -> assert false
| Path (c::l, t') -> `Node (`Char c, [to_tree (_mk_path l t')])
| Cons (c, t') -> `Node (`Char c, [to_tree t'])
| Node (v, map) ->
let x = match v with
| None -> `Switch
@ -464,10 +425,9 @@ module Make(W : WORD) = struct
match cur with
| None -> (None, alternatives)
| Some (Empty,_) -> (None, alternatives)
| Some (Path ([], _),_) -> assert false
| Some (Path (c'::l, t'), trail) ->
| Some (Cons (c', t'), trail) ->
if W.compare c c' = 0
then Some (_mk_path l t', _difflist_add trail c), alternatives
then Some (t', _difflist_add trail c), alternatives
else None, alternatives
| Some (Node (_, map), trail) ->
let alternatives =

4
src/data/containers_data.mldylib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 5103c22b99ffdda9689659d2fbcfc489)
# DO NOT EDIT (digest: 868cf65b04ece1e5b4b46f9a48586507)
CCMultiMap
CCMultiSet
CCTrie
@ -10,4 +10,6 @@ CCDeque
CCFQueue
CCBV
CCMixtbl
CCMixmap
CCRingBuffer
# OASIS_STOP

4
src/data/containers_data.mllib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 5103c22b99ffdda9689659d2fbcfc489)
# DO NOT EDIT (digest: 868cf65b04ece1e5b4b46f9a48586507)
CCMultiMap
CCMultiSet
CCTrie
@ -10,4 +10,6 @@ CCDeque
CCFQueue
CCBV
CCMixtbl
CCMixmap
CCRingBuffer
# OASIS_STOP

32
src/iter/CCKTree.ml
View file

@ -181,6 +181,38 @@ let find ?pset f t =
in
_find_kl f (bfs ?pset t)
(** {2 Pretty-printing} *)
let print pp_x fmt t =
(* at depth [lvl] *)
let rec pp fmt t = match t with
| `Nil -> ()
| `Node (x, children) ->
let children = filter children in
match children with
| [] -> pp_x fmt x
| _::_ ->
Format.fprintf fmt "@[<v2>(@[<hov0>%a@]%a)@]"
pp_x x pp_children children
and filter l =
let l = List.fold_left
(fun acc c -> match c() with
| `Nil -> acc
| `Node _ as sub -> sub :: acc
) [] l
in
List.rev l
and pp_children fmt children =
(* remove empty children *)
List.iter
(fun c ->
Format.fprintf fmt "@,";
pp fmt c
) children
in
pp fmt (t ());
()
(** {2 Pretty printing in the DOT (graphviz) format} *)
module Dot = struct

26
src/iter/CCKTree.mli
View file

@ -94,6 +94,32 @@ val bfs : ?pset:'a pset -> 'a t -> 'a klist
val find : ?pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option
(** Look for an element that maps to [Some _] *)
(** {2 Pretty-printing}
Example (tree of calls for naive Fibonacci function):
{[
let mk_fib n =
let rec fib' l r i =
if i=n then r else fib' r (l+r) (i+1)
in fib' 1 1 1;;
let rec fib n = match n with
| 0 | 1 -> CCKTree.singleton (`Cst n)
| _ -> CCKTree.node2 (`Plus (mk_fib n)) (fib (n-1)) (fib (n-2));;
let pp_node fmt = function
| `Cst n -> Format.fprintf fmt "%d" n
| `Plus n -> Format.fprintf fmt "%d" n;;
Format.printf "%a@." (CCKTree.print pp_node) (fib 8);;
]}
*)
val print : 'a formatter -> 'a t formatter
(** A pretty-printer using S-expressions and boxes to render the tree.
Empty nodes are not rendered; sharing is ignored.
@since 0.9 *)
(** {2 Pretty printing in the DOT (graphviz) format} *)
module Dot : sig

4
src/lwt/containers_lwt.mlpack
View file

@ -1,5 +1,7 @@
# OASIS_START
# DO NOT EDIT (digest: 90e18bcaee6d0b33210b35e709b0a41c)
# DO NOT EDIT (digest: 41ca039f453c9bf865bafe93b638ae8a)
Lwt_automaton
Lwt_actor
Lwt_klist
Lwt_pipe
# OASIS_STOP

218
src/lwt/lwt_klist.ml Normal file
View file

@ -0,0 +1,218 @@
(*
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 Functional streams for Lwt} *)
type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t
type 'a stream = 'a t
let (>>=) = Lwt.(>>=)
let (>|=) = Lwt.(>|=)
let empty = Lwt.return `Nil
let cons x l = Lwt.return (`Cons (x, l))
let rec create f : 'a t =
f () >|= function
| None -> `Nil
| Some x -> `Cons (x, create f)
let next l =
l >|= function
| `Nil -> None
| `Cons (x, tl) -> Some (x, tl)
let next_exn l =
l >>= function
| `Nil -> Lwt.fail Not_found
| `Cons (x, tl) -> Lwt.return (x, tl)
let rec map f l =
l >|= function
| `Nil -> `Nil
| `Cons (x, tl) -> `Cons (f x, map f tl)
let rec map_s (f:'a -> 'b Lwt.t) l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >|= fun y -> `Cons (y, map_s f tl)
let rec append l1 l2 =
l1 >>= function
| `Nil -> l2
| `Cons (x, tl1) -> Lwt.return (`Cons (x, append tl1 l2))
let rec flat_map f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) -> append (f x) (flat_map f tl)
let rec filter_map f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
match f x with
| None -> filter_map f tl
| Some y -> Lwt.return (`Cons (y, filter_map f tl))
let rec filter_map_s f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >>= function
| None -> filter_map_s f tl
| Some y -> Lwt.return (`Cons (y, filter_map_s f tl))
let rec iter f l =
l >>= function
| `Nil -> Lwt.return_unit
| `Cons (x, tl) -> f x; iter f tl
let rec iter_s f l =
l >>= function
| `Nil -> Lwt.return_unit
| `Cons (x, tl) -> f x >>= fun () -> iter_s f tl
let rec fold f acc l =
l >>= function
| `Nil -> Lwt.return acc
| `Cons (x, tl) ->
let acc = f acc x in
fold f acc tl
let rec fold_s f acc l =
l >>= function
| `Nil -> Lwt.return acc
| `Cons (x, tl) -> f acc x >>= fun acc -> fold_s f acc tl
let rec take n l = match n with
| 0 -> empty
| _ ->
l >>= function
| `Nil -> empty
| `Cons (x, tl) -> Lwt.return (`Cons (x, take (n-1) tl))
let rec take_while f l =
l >>= function
| `Cons (x, tl) when f x -> Lwt.return (`Cons (x, take_while f tl))
| `Nil
| `Cons _ -> empty
let rec take_while_s f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >>= function
| true -> Lwt.return (`Cons (x, take_while_s f tl))
| false -> empty
let rec drop n l = match n with
| 0 -> l
| _ ->
l >>= function
| `Nil -> empty
| `Cons (_, tl) -> drop (n-1) tl
let rec drop_while f l =
l >>= function
| `Nil -> empty
| `Cons (x, _) when f x -> l
| `Cons (_, tl) -> drop_while f tl
let rec drop_while_s f l =
l >>= function
| `Nil -> empty
| `Cons (x, tl) ->
f x >>= function
| false -> drop_while_s f tl
| true -> l
let merge a b =
let add_left = Lwt.map (fun y -> `Left y) in
let add_right = Lwt.map (fun y -> `Right y) in
let remove_side l =
l >|= function
| `Left x -> x
| `Right x -> x
in
let rec merge' l r =
Lwt.choose [l; r] >>= function
| `Left `Nil -> remove_side r
| `Left (`Cons (x, l')) ->
Lwt.return (`Cons (x, merge' (add_left l') r))
| `Right `Nil -> remove_side l
| `Right (`Cons (x, r')) ->
Lwt.return (`Cons (x, merge' l (add_right r')))
in
merge' (add_left a) (add_right b)
(** {2 Conversions} *)
type 'a gen = unit -> 'a option
let rec of_list l = match l with
| [] -> empty
| x :: tl -> Lwt.return (`Cons (x, of_list tl))
let rec of_array_rec a i =
if i = Array.length a
then empty
else Lwt.return (`Cons (a.(i), of_array_rec a (i+1)))
let of_array a = of_array_rec a 0
let rec of_gen g = match g () with
| None -> empty
| Some x -> Lwt.return (`Cons (x, of_gen g))
let rec of_gen_s g = match g() with
| None -> empty
| Some x ->
x >|= fun x -> `Cons (x, of_gen_s g)
let rec of_string_rec s i =
if i = String.length s
then empty
else Lwt.return (`Cons (String.get s i, of_string_rec s (i+1)))
let of_string s : char t = of_string_rec s 0
let to_string l =
let buf = Buffer.create 128 in
iter (fun c -> Buffer.add_char buf c) l >>= fun () ->
Lwt.return (Buffer.contents buf)
let to_rev_list l =
fold (fun acc x -> x :: acc) [] l
let to_list l = to_rev_list l >|= List.rev
(*$Q
(Q.list Q.int) (fun l -> Lwt_main.run (of_list l |> to_list) = l)
*)

108
src/lwt/lwt_klist.mli Normal file
View file

@ -0,0 +1,108 @@
(*
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 Functional streams for Lwt}
Functional streams, that is, lazy lists whose nodes are behind a
Lwt.t future. Such as list never mutates, it can be safely traversed
several times, but might eat memory.
{b status: experimental}
@since 0.9 *)
type 'a t = [ `Nil | `Cons of 'a * 'a t ] Lwt.t
type 'a stream = 'a t
val empty : 'a t
val cons : 'a -> 'a t -> 'a t
val create : (unit -> 'a option Lwt.t) -> 'a t
(** Create from a function that returns the next element *)
val next : 'a t -> ('a * 'a t) option Lwt.t
(** Obtain the next element *)
val next_exn : 'a t -> ('a * 'a t) Lwt.t
(** Obtain the next element or fail
@raise Not_found if the stream is empty (using {!Lwt.fail}) *)
val map : ('a -> 'b) -> 'a t -> 'b t
val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t
val append : 'a t -> 'a t -> 'a t
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t
val flat_map : ('a -> 'b t) -> 'a t -> 'b t
val iter : ('a -> unit) -> 'a t -> unit Lwt.t
val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t
val take : int -> 'a t -> 'a t
val take_while : ('a -> bool) -> 'a t -> 'a t
val take_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
val drop : int -> 'a t -> 'a t
val drop_while : ('a -> bool) -> 'a t -> 'a t
val drop_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
val merge : 'a t -> 'a t -> 'a t
(** Non-deterministic merge *)
(** {2 Conversions} *)
type 'a gen = unit -> 'a option
val of_list : 'a list -> 'a t
val of_array : 'a array -> 'a t
val of_gen : 'a gen -> 'a t
val of_gen_s : 'a Lwt.t gen -> 'a t
val of_string : string -> char t
val to_list : 'a t -> 'a list Lwt.t
val to_rev_list : 'a t -> 'a list Lwt.t
val to_string : char t -> string Lwt.t

459
src/lwt/lwt_pipe.ml Normal file
View file

@ -0,0 +1,459 @@
(*
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.
*)
type 'a or_error = [`Ok of 'a | `Error of string]
type 'a step = ['a or_error | `End]
let (>|=) = Lwt.(>|=)
let (>>=) = Lwt.(>>=)
module LwtErr = struct
type 'a t = 'a or_error Lwt.t
let return x = Lwt.return (`Ok x)
let return_unit = Lwt.return (`Ok ())
let fail msg = Lwt.return (`Error msg)
let (>>=) x f =
Lwt.bind x
(function
| `Error msg -> fail msg
| `Ok y -> f y
)
let (>|=) x f =
Lwt.map
(function
| `Error _ as e -> e
| `Ok x -> `Ok (f x)
) x
end
let (>>>=) = LwtErr.(>>=)
let (>>|=) = LwtErr.(>|=)
let ret_end = Lwt.return `End
exception Closed
type ('a, +'perm) t = {
close : unit Lwt.u;
closed : unit Lwt.t;
readers : 'a step Lwt.u Queue.t; (* readers *)
writers : 'a step Queue.t;
blocked_writers : ('a step * unit Lwt.u) Queue.t; (* blocked writers *)
max_size : int;
mutable keep : unit Lwt.t list; (* do not GC, and wait for completion *)
} constraint 'perm = [< `r | `w]
type ('a, 'perm) pipe = ('a, 'perm) t
let create ?(max_size=0) () =
let closed, close = Lwt.wait () in
{
close;
closed;
readers = Queue.create ();
writers = Queue.create ();
blocked_writers = Queue.create ();
max_size;
keep=[];
}
let keep p fut = p.keep <- fut :: p.keep
let is_closed p = not (Lwt.is_sleeping p.closed)
let close p =
if is_closed p then Lwt.return_unit
else (
Lwt.wakeup p.close (); (* evaluate *)
Lwt.join p.keep;
)
let close_async p = Lwt.async (fun () -> close p)
let wait p = Lwt.map (fun _ -> ()) p.closed
(* try to take next element from writers buffer *)
let try_read t =
if Queue.is_empty t.writers
then if Queue.is_empty t.blocked_writers
then None
else (
assert (t.max_size = 0);
let x, signal_done = Queue.pop t.blocked_writers in
Lwt.wakeup signal_done ();
Some x
)
else (
let x = Queue.pop t.writers in
(* some writer may unblock *)
if not (Queue.is_empty t.blocked_writers) && Queue.length t.writers < t.max_size then (
let y, signal_done = Queue.pop t.blocked_writers in
Queue.push y t.writers;
Lwt.wakeup signal_done ();
);
Some x
)
(* read next one *)
let read t = match try_read t with
| None when is_closed t -> ret_end (* end of stream *)
| None ->
let fut, send = Lwt.wait () in
Queue.push send t.readers;
fut
| Some x -> Lwt.return x
(* write a value *)
let write_step t x =
if is_closed t then Lwt.fail Closed
else if Queue.length t.readers > 0
then (
(* some reader waits, synchronize now *)
let send = Queue.pop t.readers in
Lwt.wakeup send x;
Lwt.return_unit
)
else if Queue.length t.writers < t.max_size
then (
Queue.push x t.writers;
Lwt.return_unit (* into buffer, do not wait *)
)
else (
(* block until the queue isn't full anymore *)
let is_done, signal_done = Lwt.wait () in
Queue.push (x, signal_done) t.blocked_writers;
is_done (* block *)
)
let rec connect_rec r w =
read r >>= function
| `End -> Lwt.return_unit
| `Error _ as step -> write_step w step
| `Ok _ as step ->
write_step w step >>= fun () ->
connect_rec r w
(* close a when b closes *)
let link_close p ~after =
Lwt.on_termination after.closed
(fun _ -> close_async p)
let connect ?(ownership=`None) a b =
let fut = connect_rec a b in
keep b fut;
match ownership with
| `None -> ()
| `InOwnsOut -> link_close b ~after:a
| `OutOwnsIn -> link_close a ~after:b
(* close a when every member of after closes *)
let link_close_l p ~after =
let n = ref (List.length after) in
List.iter
(fun p' -> Lwt.on_termination p'.closed
(fun _ ->
decr n;
if !n = 0 then close_async p
)
) after
let write_error t msg = write_step t (`Error msg)
let write t x = write_step t (`Ok x)
let rec write_list t l = match l with
| [] -> Lwt.return_unit
| x :: tail ->
write t x >>= fun () -> write_list t tail
module Writer = struct
type 'a t = ('a, [`w]) pipe
let map ~f a =
let b = create() in
let rec fwd () =
read b >>= function
| `Ok x -> write a (f x) >>= fwd
| `Error msg -> write_error a msg >>= fun _ -> close a
| `End -> Lwt.return_unit
in
keep b (fwd());
(* when a gets closed, close b too *)
link_close b ~after:a;
b
let send_all l =
if l = [] then invalid_arg "send_all";
let res = create () in
let rec fwd () =
read res >>= function
| `End -> Lwt.return_unit
| `Ok x -> Lwt_list.iter_p (fun p -> write p x) l >>= fwd
| `Error msg -> Lwt_list.iter_p (fun p -> write_error p msg) l >>= fwd
in
(* do not GC before res dies; close res when any outputx is closed *)
keep res (fwd ());
List.iter (fun out -> link_close res ~after:out) l;
res
let send_both a b = send_all [a; b]
end
module Reader = struct
type 'a t = ('a, [`r]) pipe
let map ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x -> write_step b (`Ok (f x)) >>= fwd
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let map_s ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x -> f x >>= fun y -> write_step b (`Ok y) >>= fwd
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let filter ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x -> if f x then write_step b (`Ok x) >>= fwd else fwd()
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let filter_map ~f a =
let b = create () in
let rec fwd () =
read a >>= function
| `Ok x ->
begin match f x with
| None -> fwd()
| Some y -> write_step b (`Ok y) >>= fwd
end
| (`Error _) as e -> write_step b e >>= fun _ -> close b
| `End -> close b
in
keep b (fwd());
b
let rec fold ~f ~x t =
read t >>= function
| `End -> LwtErr.return x
| `Error msg -> LwtErr.fail msg
| `Ok y -> fold ~f ~x:(f x y) t
let rec fold_s ~f ~x t =
read t >>= function
| `End -> LwtErr.return x
| `Error msg -> LwtErr.fail msg
| `Ok y ->
f x y >>= fun x -> fold_s ~f ~x t
let rec iter ~f t =
read t >>= function
| `End -> LwtErr.return_unit
| `Error msg -> LwtErr.fail msg
| `Ok x -> f x; iter ~f t
let rec iter_s ~f t =
read t >>= function
| `End -> LwtErr.return_unit
| `Error msg -> LwtErr.fail msg
| `Ok x -> f x >>= fun () -> iter_s ~f t
let iter_p ~f t =
let rec iter acc =
read t >>= function
| `End -> Lwt.join acc >|= fun () -> `Ok ()
| `Error msg -> LwtErr.fail msg
| `Ok x -> iter (f x :: acc)
in iter []
let merge_all l =
if l = [] then invalid_arg "merge_all";
let res = create () in
List.iter (fun p -> connect p res) l;
(* connect res' input to all members of l; close res when they all close *)
link_close_l res ~after:l;
res
let merge_both a b = merge_all [a; b]
let append a b =
let c = create () in
connect a c;
Lwt.on_success (wait a)
(fun () ->
connect b c;
link_close c ~after:b (* once a and b finished, c is too *)
);
c
end
(** {2 Conversions} *)
type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t
let of_list l : _ Reader.t =
let p = create ~max_size:0 () in
keep p (Lwt_list.iter_s (write p) l >>= fun () -> close p);
p
let of_array a =
let p = create ~max_size:0 () in
let rec send i =
if i = Array.length a then close p
else (
write p a.(i) >>= fun () ->
send (i+1)
)
in
keep p (send 0);
p
let of_string a =
let p = create ~max_size:0 () in
let rec send i =
if i = String.length a then close p
else (
write p (String.get a i) >>= fun () ->
send (i+1)
)
in
keep p (send 0);
p
let of_lwt_klist l =
let p = create ~max_size:0 () in
let rec next l =
l >>= function
| `Nil -> close p
| `Cons (x, tl) ->
write p x >>= fun () -> next tl
in
keep p (next l);
p
let to_list_rev r =
Reader.fold ~f:(fun acc x -> x :: acc) ~x:[] r
let to_list r = to_list_rev r >>|= List.rev
let to_list_exn r =
to_list r >>= function
| `Error msg -> Lwt.fail (Failure msg)
| `Ok x -> Lwt.return x
let to_buffer buf r =
Reader.iter ~f:(fun c -> Buffer.add_char buf c) r
let to_buffer_str ?(sep="") buf r =
let first = ref true in
Reader.iter r
~f:(fun s ->
if !first then first:= false else Buffer.add_string buf sep;
Buffer.add_string buf s
)
let to_string r =
let buf = Buffer.create 128 in
to_buffer buf r >>>= fun () -> LwtErr.return (Buffer.contents buf)
let join_strings ?sep r =
let buf = Buffer.create 128 in
to_buffer_str ?sep buf r >>>= fun () -> LwtErr.return (Buffer.contents buf)
let to_lwt_klist r =
let rec next () =
read r >>= function
| `End -> Lwt.return `Nil
| `Error _ -> Lwt.return `Nil
| `Ok x -> Lwt.return (`Cons (x, next ()))
in
next ()
(** {2 Basic IO wrappers} *)
module IO = struct
let read ?(bufsize=4096) ic : _ Reader.t =
let buf = Bytes.make bufsize ' ' in
let p = create ~max_size:0 () in
let rec send() =
Lwt_io.read_into ic buf 0 bufsize >>= fun n ->
if n = 0 then close p
else
write p (Bytes.sub_string buf 0 n) >>= fun () ->
send ()
in Lwt.async send;
p
let read_lines ic =
let p = create () in
let rec send () =
Lwt_io.read_line_opt ic >>= function
| None -> close p
| Some line -> write p line >>= fun () -> send ()
in
Lwt.async send;
p
let write oc =
let p = create () in
keep p (
Reader.iter_s ~f:(Lwt_io.write oc) p >>= fun _ ->
Lwt_io.flush oc >>= fun () ->
close p
);
p
let write_lines oc =
let p = create () in
keep p (
Reader.iter_s ~f:(Lwt_io.write_line oc) p >>= fun _ ->
Lwt_io.flush oc >>= fun () ->
close p
);
p
end

214
src/lwt/lwt_pipe.mli Normal file
View file

@ -0,0 +1,214 @@
(*
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 Pipes, Readers, Writers}
Stream processing using:
- Pipe: a possibly buffered channel that can act as a reader or as a writer
- Reader: accepts values, produces effects
- Writer: yield values
Examples:
{[
#require "containers.lwt";;
module P = Containers_lwt.Lwt_pipe;;
let p1 =
P.of_list CCList.(1 -- 100)
|> P.Reader.map ~f:string_of_int;;
Lwt_io.with_file ~mode:Lwt_io.output "/tmp/foo"
(fun oc ->
let p2 = P.IO.write_lines oc in
P.connect ~ownership:`InOwnsOut p1 p2;
P.wait p2
);;
]}
{b status: experimental}
@since 0.9
*)
type 'a or_error = [`Ok of 'a | `Error of string]
type 'a step = ['a or_error | `End]
module LwtErr : sig
type 'a t = 'a or_error Lwt.t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val return : 'a -> 'a t
val fail : string -> 'a t
end
exception Closed
type ('a, +'perm) t constraint 'perm = [< `r | `w]
(** A pipe between producers of values of type 'a, and consumers of values
of type 'a. *)
type ('a, 'perm) pipe = ('a, 'perm) t
val keep : _ t -> unit Lwt.t -> unit
(** [keep p fut] adds a pointer from [p] to [fut] so that [fut] is not
garbage-collected before [p] *)
val is_closed : _ t -> bool
val close : _ t -> unit Lwt.t
(** [close p] closes [p], which will not accept input anymore.
This sends [`End] to all readers connected to [p] *)
val close_async : _ t -> unit
(** Same as {!close} but closes in the background *)
val wait : _ t -> unit Lwt.t
(** Evaluates once the pipe closes *)
val create : ?max_size:int -> unit -> ('a, 'perm) t
(** Create a new pipe.
@param max_size size of internal buffer. Default 0. *)
val connect : ?ownership:[`None | `InOwnsOut | `OutOwnsIn] ->
('a, [>`r]) t -> ('a, [>`w]) t -> unit
(** [connect p1 p2] forwards every item output by [p1] into [p2]'s input
until [p1] is closed.
@param own determines which pipes owns which (the owner, when it
closes, also closes the ownee) *)
val link_close : _ t -> after:_ t -> unit
(** [link_close p ~after] will close [p] when [after] closes.
if [after] is closed already, closes [p] immediately *)
val read : ('a, [>`r]) t -> 'a step Lwt.t
(** Read the next value from a Pipe *)
val write : ('a, [>`w]) t -> 'a -> unit Lwt.t
(** @raise Pipe.Closed if the writer is closed *)
val write_list : ('a, [>`w]) t -> 'a list -> unit Lwt.t
(** @raise Pipe.Closed if the writer is closed *)
val write_error : (_, [>`w]) t -> string -> unit Lwt.t
(** @raise Pipe.Closed if the writer is closed *)
(** {2 Write-only Interface and Combinators} *)
module Writer : sig
type 'a t = ('a, [`w]) pipe
val map : f:('a -> 'b) -> ('b, [>`w]) pipe -> 'a t
(** Map values before writing them *)
val send_both : 'a t -> 'a t -> 'a t
(** [send_both a b] returns a writer [c] such that writing to [c]
writes to [a] and [b], and waits for those writes to succeed
before returning *)
val send_all : 'a t list -> 'a t
(** Generalized version of {!send_both}
@raise Invalid_argument if the list is empty *)
end
(** {2 Read-only Interface and Combinators} *)
module Reader : sig
type 'a t = ('a, [`r]) pipe
val map : f:('a -> 'b) -> ('a, [>`r]) pipe -> 'b t
val map_s : f:('a -> 'b Lwt.t) -> ('a, [>`r]) pipe -> 'b t
val filter : f:('a -> bool) -> ('a, [>`r]) pipe -> 'a t
val filter_map : f:('a -> 'b option) -> ('a, [>`r]) pipe -> 'b t
val fold : f:('acc -> 'a -> 'acc) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t
val fold_s : f:('acc -> 'a -> 'acc Lwt.t) -> x:'acc -> ('a, [>`r]) pipe -> 'acc LwtErr.t
val iter : f:('a -> unit) -> 'a t -> unit LwtErr.t
val iter_s : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t
val iter_p : f:('a -> unit Lwt.t) -> 'a t -> unit LwtErr.t
val merge_both : 'a t -> 'a t -> 'a t
(** Merge the two input streams in a non-specified order *)
val merge_all : 'a t list -> 'a t
(** Merge all the input streams
@raise Invalid_argument if the list is empty *)
val append : 'a t -> 'a t -> 'a t
(** [append a b] reads from [a] until [a] closes, then reads from [b]
and closes when [b] closes *)
end
(** {2 Conversions} *)
type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t
val of_list : 'a list -> 'a Reader.t
val of_array : 'a array -> 'a Reader.t
val of_string : string -> char Reader.t
val of_lwt_klist : 'a lwt_klist -> 'a Reader.t
val to_list_rev : ('a,[>`r]) t -> 'a list LwtErr.t
val to_list : ('a,[>`r]) t -> 'a list LwtErr.t
val to_list_exn : ('a,[>`r]) t -> 'a list Lwt.t
(** Same as {!to_list}, but can fail with
@raise Failure if some error is met *)
val to_buffer : Buffer.t -> (char ,[>`r]) t -> unit LwtErr.t
val to_buffer_str : ?sep:string -> Buffer.t -> (string, [>`r]) t -> unit LwtErr.t
val to_string : (char, [>`r]) t -> string LwtErr.t
val join_strings : ?sep:string -> (string, [>`r]) t -> string LwtErr.t
val to_lwt_klist : 'a Reader.t -> 'a lwt_klist
(** Iterates on the reader. Errors are ignored (but stop the list). *)
(** {2 Basic IO wrappers} *)
module IO : sig
val read : ?bufsize:int -> Lwt_io.input_channel -> string Reader.t
val read_lines : Lwt_io.input_channel -> string Reader.t
val write : Lwt_io.output_channel -> string Writer.t
val write_lines : Lwt_io.output_channel -> string Writer.t
end

8
src/pervasives/CCPervasives.ml
View file

@ -48,7 +48,13 @@ module Array = struct
end
module Bool = CCBool
module Error = CCError
module Float = CCFloat
module Format = struct
include Format
include CCFormat
end
module Fun = CCFun
module Hash = CCHash
module Int = CCInt
(* FIXME
module Hashtbl = struct
@ -72,6 +78,8 @@ module Random = struct
include Random
include CCRandom
end
module Ref = CCRef
module Set = CCSet
module String = struct
include String
include CCString

9
tests/quick/.common.ml
View file

@ -1,8 +1,9 @@
#use "topfind";;
#directory "_build/core/";;
#directory "_build/string";;
#directory "_build/misc";;
#directory "_build/lwt";;
#directory "_build/src/core/";;
#directory "_build/src/string";;
#directory "_build/src/misc";;
#directory "_build/src/io";;
#directory "_build/src/lwt";;
#require "unix";;

7
tests/quick/levenshtein_dict.ml
View file

@ -2,13 +2,12 @@
#use "tests/quick/.common.ml";;
#load "containers.cma";;
#load "containers_string.cma";;
#load "containers_io.cma";;
open Containers_string
let words = CCIO.(
(with_in "/usr/share/dict/cracklib-small" >>>= read_lines)
|> run_exn
)
let words =
CCIO.with_in "/usr/share/dict/words" CCIO.read_lines_l
let idx = List.fold_left
(fun idx s -> Levenshtein.Index.add idx s s)