diff --git a/.header b/.header index 71e61012..d5a14c50 100644 --- a/.header +++ b/.header @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md index 87f5dcbe..c05947a4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/META b/META deleted file mode 100644 index bdfc3a8d..00000000 --- a/META +++ /dev/null @@ -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 - diff --git a/Makefile b/Makefile index ff587aca..6302348f 100644 --- a/Makefile +++ b/Makefile @@ -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' diff --git a/README.md b/README.md index bcc5ba01..a0ac39b6 100644 --- a/README.md +++ b/README.md @@ -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`): diff --git a/_oasis b/_oasis index e9049e20..9fc4ec59 100644 --- a/_oasis +++ b/_oasis @@ -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 diff --git a/_tags b/_tags index a9392af5..99009386 100644 --- a/_tags +++ b/_tags @@ -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 : package(bytes) # Library containers_data "src/data/containers_data.cmxs": use_containers_data +: 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) : package(bytes) : package(lwt) : use_containers : use_containers_data : 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 +: package(benchmark) +: package(bytes) +: package(gen) +: package(sequence) +: use_containers +: use_containers_advanced +: use_containers_data +: use_containers_iter +: use_containers_misc +: use_containers_string : package(benchmark) : package(gen) : package(sequence) @@ -99,10 +102,10 @@ true: annot, bin_annot : use_containers_iter : 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 +: package(bytes) +: use_containers +: use_containers_data +: use_containers_misc : package(bytes) : use_containers : use_containers_data @@ -121,21 +124,21 @@ true: annot, bin_annot : use_containers : 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 +: package(QTest2Lib) +: package(bigarray) +: package(bytes) +: package(gen) +: package(oUnit) +: package(sequence) +: use_containers +: use_containers_advanced +: use_containers_bigarray +: use_containers_data +: use_containers_io +: use_containers_iter +: use_containers_misc +: use_containers_sexp +: use_containers_string : package(QTest2Lib) : package(bigarray) : package(bytes) @@ -151,16 +154,39 @@ true: annot, bin_annot : use_containers_misc : use_containers_sexp : use_containers_string +# Executable run_qtest_lwt +: package(QTest2Lib) +: package(bytes) +: package(gen) +: package(lwt) +: package(lwt.unix) +: package(oUnit) +: package(sequence) +: use_containers +: use_containers_data +: use_containers_lwt +: use_containers_misc +: package(QTest2Lib) +: package(bytes) +: package(gen) +: package(lwt) +: package(lwt.unix) +: package(oUnit) +: package(sequence) +: use_containers +: use_containers_data +: use_containers_lwt +: 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 +: package(bytes) +: package(gen) +: package(oUnit) +: package(qcheck) +: package(sequence) +: use_containers +: use_containers_data +: use_containers_misc +: use_containers_string : package(bytes) : package(gen) : package(oUnit) @@ -171,19 +197,19 @@ true: annot, bin_annot : use_containers_misc : 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 +: package(bytes) +: use_containers +: use_containers_data +: use_containers_misc : use_containers : use_containers_data : use_containers_misc # Executable id_sexp -"examples/id_sexp.native": package(bytes) -"examples/id_sexp.native": use_containers_sexp +: package(bytes) +: use_containers_sexp # Executable id_sexp2 -"examples/id_sexp2.native": package(bytes) -"examples/id_sexp2.native": use_containers_sexp +: package(bytes) +: use_containers_sexp : package(bytes) : use_containers_sexp # OASIS_STOP diff --git a/containers.odocl b/containers.odocl index 80a5be53..a7d4b7c3 100644 --- a/containers.odocl +++ b/containers.odocl @@ -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 diff --git a/doc/build_deps.ml b/doc/build_deps.ml index 5386c641..37633b20 100755 --- a/doc/build_deps.ml +++ b/doc/build_deps.ml @@ -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);; diff --git a/doc/intro.txt b/doc/intro.txt index edbad184..b0bbb36a 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -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: diff --git a/myocamlbuild.ml b/myocamlbuild.ml index ec43fcce..feb6658c 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -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" ;; diff --git a/setup.ml b/setup.ml index 25d365bf..a0def9ae 100644 --- a/setup.ml +++ b/setup.ml @@ -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 ();; diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 5bff0275..0af423c3 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -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 diff --git a/src/core/CCRef.ml b/src/core/CCRef.ml new file mode 100644 index 00000000..e3965765 --- /dev/null +++ b/src/core/CCRef.ml @@ -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 + + diff --git a/src/core/CCRef.mli b/src/core/CCRef.mli new file mode 100644 index 00000000..35694e7e --- /dev/null +++ b/src/core/CCRef.mli @@ -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 + diff --git a/src/core/CCSet.ml b/src/core/CCSet.ml new file mode 100644 index 00000000..5abed74a --- /dev/null +++ b/src/core/CCSet.ml @@ -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 + diff --git a/src/core/CCSet.mli b/src/core/CCSet.mli new file mode 100644 index 00000000..a9b1912a --- /dev/null +++ b/src/core/CCSet.mli @@ -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 diff --git a/src/core/META b/src/core/META index f420a69f..b7423bf6 100644 --- a/src/core/META +++ b/src/core/META @@ -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" diff --git a/src/core/containers.mldylib b/src/core/containers.mldylib index 66cd9318..03fbbecd 100644 --- a/src/core/containers.mldylib +++ b/src/core/containers.mldylib @@ -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 diff --git a/src/core/containers.mllib b/src/core/containers.mllib index 66cd9318..03fbbecd 100644 --- a/src/core/containers.mllib +++ b/src/core/containers.mllib @@ -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 diff --git a/src/data/CCCache.ml b/src/data/CCCache.ml index e65b2e2f..e0340bca 100644 --- a/src/data/CCCache.ml +++ b/src/data/CCCache.ml @@ -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 diff --git a/src/data/CCMixmap.ml b/src/data/CCMixmap.ml new file mode 100644 index 00000000..152dcca8 --- /dev/null +++ b/src/data/CCMixmap.ml @@ -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 diff --git a/src/data/CCMixmap.mli b/src/data/CCMixmap.mli new file mode 100644 index 00000000..c7adfe68 --- /dev/null +++ b/src/data/CCMixmap.mli @@ -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 diff --git a/src/data/CCMixtbl.mli b/src/data/CCMixtbl.mli index 67af7755..a315b41a 100644 --- a/src/data/CCMixtbl.mli +++ b/src/data/CCMixtbl.mli @@ -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 *) diff --git a/src/data/CCRingBuffer.ml b/src/data/CCRingBuffer.ml new file mode 100644 index 00000000..714b78d3 --- /dev/null +++ b/src/data/CCRingBuffer.ml @@ -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)) diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli new file mode 100644 index 00000000..7eadba09 --- /dev/null +++ b/src/data/CCRingBuffer.mli @@ -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 diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index 2956fe2f..bdebe9b8 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -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 = diff --git a/src/data/containers_data.mldylib b/src/data/containers_data.mldylib index 90d1274e..f5be522f 100644 --- a/src/data/containers_data.mldylib +++ b/src/data/containers_data.mldylib @@ -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 diff --git a/src/data/containers_data.mllib b/src/data/containers_data.mllib index 90d1274e..f5be522f 100644 --- a/src/data/containers_data.mllib +++ b/src/data/containers_data.mllib @@ -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 diff --git a/src/iter/CCKTree.ml b/src/iter/CCKTree.ml index 35e8590d..02ac32c4 100644 --- a/src/iter/CCKTree.ml +++ b/src/iter/CCKTree.ml @@ -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 "@[(@[%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 diff --git a/src/iter/CCKTree.mli b/src/iter/CCKTree.mli index c64444f3..30916abf 100644 --- a/src/iter/CCKTree.mli +++ b/src/iter/CCKTree.mli @@ -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 diff --git a/src/lwt/containers_lwt.mlpack b/src/lwt/containers_lwt.mlpack index 103df89d..941bca91 100644 --- a/src/lwt/containers_lwt.mlpack +++ b/src/lwt/containers_lwt.mlpack @@ -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 diff --git a/src/lwt/lwt_klist.ml b/src/lwt/lwt_klist.ml new file mode 100644 index 00000000..bf651830 --- /dev/null +++ b/src/lwt/lwt_klist.ml @@ -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) +*) + diff --git a/src/lwt/lwt_klist.mli b/src/lwt/lwt_klist.mli new file mode 100644 index 00000000..abc62b9b --- /dev/null +++ b/src/lwt/lwt_klist.mli @@ -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 + diff --git a/src/lwt/lwt_pipe.ml b/src/lwt/lwt_pipe.ml new file mode 100644 index 00000000..36af2b1f --- /dev/null +++ b/src/lwt/lwt_pipe.ml @@ -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 diff --git a/src/lwt/lwt_pipe.mli b/src/lwt/lwt_pipe.mli new file mode 100644 index 00000000..46702c78 --- /dev/null +++ b/src/lwt/lwt_pipe.mli @@ -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 diff --git a/src/pervasives/CCPervasives.ml b/src/pervasives/CCPervasives.ml index 13228ed0..96410c18 100644 --- a/src/pervasives/CCPervasives.ml +++ b/src/pervasives/CCPervasives.ml @@ -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 diff --git a/tests/quick/.common.ml b/tests/quick/.common.ml index 9ee90649..fe217640 100644 --- a/tests/quick/.common.ml +++ b/tests/quick/.common.ml @@ -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";; diff --git a/tests/quick/levenshtein_dict.ml b/tests/quick/levenshtein_dict.ml index 8700c4fa..5fc2c3be 100755 --- a/tests/quick/levenshtein_dict.ml +++ b/tests/quick/levenshtein_dict.ml @@ -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)