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

merge from master; version 0.6

Browse source
This commit is contained in:
Simon Cruanes 2014-11-23 14:19:00 +01:00
commit 1b15573acd
54 changed files with 3497 additions and 2354 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.merlin
View file

@ -4,12 +4,14 @@ S string
S pervasives
S tests
S examples
S benchs
B _build/core
B _build/misc
B _build/string
B _build/pervasives
B _build/tests
B _build/examples
B _build/benchs/
PKG oUnit
PKG benchmark
PKG threads

26
CHANGELOG.md
View file

@ -1,5 +1,31 @@
# Changelog
## 0.6
### breaking changes
- new `CCIO` module, much simpler, but incompatible interface
- renamed `CCIO` to `advanced.CCMonadIO`
- `CCError.t` now has two type arguments
### other changes
- `CCMultiSet.{add_mult,remove_mult,update}`
- `CCVector.{top,top_exn}`
- `CCFun.compose_binop` (binary composition)
- `CCList.init`
- new module `CCCache`
* moved from `misc`
* add `CCache`.{size,iter}
* incompatible interface (functor -> values), much simpler to use
- `lwt/Lwt_actor` stub, for erlang-style concurrency (albeit much much more naive)
- `misc/Mixtbl`
- more benchmarks, with a more general system to select/run them
- more efficient versions of `CCList.{flatten,append,flat_map}`, some functions
are now tailrec
## 0.5
### breaking changes

13
HOWTO.md
View file

@ -2,10 +2,11 @@
## Make a release
1. `make test-all`
2. merge into `stable` (from now on, proceed on branch `stable`)
3. update version in `_oasis`
4. `make update_next_tag` (to update `@since` comments)
5. update `CHANGELOG.md` (see its end to find the right git command)
6. commit, tag, and push both to github
7. new opam package
2. update version in `_oasis`
3. `make update_next_tag` (to update `@since` comments)
4. `git checkout stable`
5. `git merge master`
6. update `CHANGELOG.md` (see its end to find the right git command)
7. commit, tag, and push both to github
8. new opam package

2
Makefile
View file

@ -114,5 +114,5 @@ update_next_tag:
udpate_sequence:
git subtree pull --prefix sequence sequence stable --squash
.PHONY: examples push_doc tags qtest clean update_sequence push-stable clean-generated
.PHONY: examples push_doc tags qtest clean update_sequence update_next_tag push-stable clean-generated

5
README.md
View file

@ -27,6 +27,11 @@ Some of the modules have been moved to their own repository (e.g. `sequence`,
[![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/)
## Finding help
- the [github wiki](https://github.com/c-cube/ocaml-containers/wiki)
- the IRC channel (`##ocaml-containers` on Freenode)
## Use
You can either build and install the library (see `Build`), or just copy

48
_oasis
View file

@ -1,6 +1,6 @@
OASISFormat: 0.4
Name: containers
Version: 0.5
Version: 0.6
Homepage: https://github.com/c-cube/ocaml-containers
Authors: Simon Cruanes
License: BSD-2-clause
@ -47,7 +47,7 @@ Library "containers"
CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash,
CCKList, CCInt, CCBool, CCArray, CCOrd, CCIO,
CCRandom, CCKTree, CCTrie, CCString, CCHashtbl,
CCFlatHashtbl, CCSexp, CCMap
CCFlatHashtbl, CCSexp, CCMap, CCCache
BuildDepends: bytes
Library "containers_string"
@ -60,7 +60,7 @@ Library "containers_string"
Library "containers_advanced"
Path: advanced
Pack: true
Modules: CCLinq, CCBatch, CCCat
Modules: CCLinq, CCBatch, CCCat, CCMonadIO
FindlibName: advanced
FindlibParent: containers
BuildDepends: containers
@ -75,12 +75,12 @@ Library "containers_pervasives"
Library "containers_misc"
Path: misc
Pack: true
Modules: Cache, FHashtbl, FlatHashtbl, Hashset,
Modules: FHashtbl, FlatHashtbl, Hashset,
Heap, LazyGraph, PersistentGraph,
PHashtbl, SkipList, SplayTree, SplayMap, Univ,
Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM,
TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee,
BTree, Ty, Cause, AVL, ParseReact
BTree, Ty, Cause, AVL, ParseReact, Mixtbl
BuildDepends: unix,containers
FindlibName: misc
FindlibParent: containers
@ -97,14 +97,13 @@ Library "containers_thread"
Library "containers_lwt"
Path: lwt
Modules: Behavior, Lwt_automaton
Modules: Behavior, Lwt_automaton, Lwt_actor
Pack: true
FindlibName: lwt
FindlibParent: containers
Build$: flag(lwt) && flag(misc)
Install$: flag(lwt) && flag(misc)
BuildDepends: containers,lwt,lwt.unix,containers.misc
XMETARequires: containers,lwt,lwt.unix,containers.misc
BuildDepends: containers, lwt, lwt.unix, containers.misc
Library "containers_cgi"
Path: cgi
@ -148,29 +147,14 @@ Document containers_advanced
XOCamlbuildPath: .
XOCamlbuildLibraries: containers.advanced
Executable benchs
Executable run_benchs
Path: benchs/
Install: false
CompiledObject: native
Build$: flag(bench)
MainIs: benchs.ml
BuildDepends: containers,containers.string,containers.misc,bench,containers.advanced
Executable bench_conv
Path: benchs/
Install: false
CompiledObject: native
Build$: flag(bench)
MainIs: bench_conv.ml
BuildDepends: containers,benchmark
Executable bench_batch
Path: benchs/
Install: false
CompiledObject: native
Build$: flag(bench)
MainIs: bench_batch.ml
BuildDepends: containers,benchmark
Build$: flag(bench) && flag(misc)
MainIs: run_benchs.ml
BuildDepends: containers, containers.misc, containers.advanced,
containers.string, benchmark
Executable bench_hash
Path: benchs/
@ -180,6 +164,14 @@ Executable bench_hash
MainIs: bench_hash.ml
BuildDepends: containers,containers.misc
Executable bench_conv
Path: benchs/
Install: false
CompiledObject: native
Build$: flag(bench)
MainIs: bench_conv.ml
BuildDepends: containers,benchmark
Executable test_levenshtein
Path: tests/
Install: false

41
_tags
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: c052544c3d7576d929b768e46a58e0a9)
# DO NOT EDIT (digest: 87b09f8c85905e63062b223fad9468e9)
# 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
@ -26,6 +26,7 @@ true: annot, bin_annot
"advanced/CCLinq.cmx": for-pack(Containers_advanced)
"advanced/CCBatch.cmx": for-pack(Containers_advanced)
"advanced/CCCat.cmx": for-pack(Containers_advanced)
"advanced/CCMonadIO.cmx": for-pack(Containers_advanced)
<advanced/*.ml{,i,y}>: package(bytes)
<advanced/*.ml{,i,y}>: use_containers
# Library containers_pervasives
@ -34,7 +35,6 @@ true: annot, bin_annot
<pervasives/*.ml{,i,y}>: use_containers
# Library containers_misc
"misc/containers_misc.cmxs": use_containers_misc
"misc/cache.cmx": for-pack(Containers_misc)
"misc/fHashtbl.cmx": for-pack(Containers_misc)
"misc/flatHashtbl.cmx": for-pack(Containers_misc)
"misc/hashset.cmx": for-pack(Containers_misc)
@ -65,6 +65,7 @@ true: annot, bin_annot
"misc/cause.cmx": for-pack(Containers_misc)
"misc/AVL.cmx": for-pack(Containers_misc)
"misc/parseReact.cmx": for-pack(Containers_misc)
"misc/mixtbl.cmx": for-pack(Containers_misc)
<misc/*.ml{,i,y}>: package(bytes)
<misc/*.ml{,i,y}>: package(unix)
<misc/*.ml{,i,y}>: use_containers
@ -77,6 +78,7 @@ true: annot, bin_annot
"lwt/containers_lwt.cmxs": use_containers_lwt
"lwt/behavior.cmx": for-pack(Containers_lwt)
"lwt/lwt_automaton.cmx": for-pack(Containers_lwt)
"lwt/lwt_actor.cmx": for-pack(Containers_lwt)
<lwt/*.ml{,i,y}>: package(bytes)
<lwt/*.ml{,i,y}>: package(lwt)
<lwt/*.ml{,i,y}>: package(lwt.unix)
@ -88,35 +90,30 @@ true: annot, bin_annot
<cgi/*.ml{,i,y}>: package(CamlGI)
<cgi/*.ml{,i,y}>: package(bytes)
<cgi/*.ml{,i,y}>: use_containers
# Executable benchs
"benchs/benchs.native": package(bench)
"benchs/benchs.native": package(bytes)
"benchs/benchs.native": package(unix)
"benchs/benchs.native": use_containers
"benchs/benchs.native": use_containers_advanced
"benchs/benchs.native": use_containers_misc
"benchs/benchs.native": use_containers_string
<benchs/*.ml{,i,y}>: package(bench)
# Executable run_benchs
"benchs/run_benchs.native": package(benchmark)
"benchs/run_benchs.native": package(bytes)
"benchs/run_benchs.native": package(unix)
"benchs/run_benchs.native": use_containers
"benchs/run_benchs.native": use_containers_advanced
"benchs/run_benchs.native": use_containers_misc
"benchs/run_benchs.native": use_containers_string
<benchs/*.ml{,i,y}>: use_containers_advanced
<benchs/*.ml{,i,y}>: use_containers_string
# Executable bench_conv
"benchs/bench_conv.native": package(benchmark)
"benchs/bench_conv.native": package(bytes)
"benchs/bench_conv.native": use_containers
# Executable bench_batch
"benchs/bench_batch.native": package(benchmark)
"benchs/bench_batch.native": package(bytes)
"benchs/bench_batch.native": use_containers
<benchs/*.ml{,i,y}>: package(benchmark)
# Executable bench_hash
"benchs/bench_hash.native": package(bytes)
"benchs/bench_hash.native": package(unix)
"benchs/bench_hash.native": use_containers
"benchs/bench_hash.native": use_containers_misc
<benchs/*.ml{,i,y}>: package(bytes)
<benchs/*.ml{,i,y}>: package(unix)
<benchs/*.ml{,i,y}>: use_containers
<benchs/*.ml{,i,y}>: use_containers_misc
# Executable bench_conv
"benchs/bench_conv.native": package(benchmark)
"benchs/bench_conv.native": package(bytes)
"benchs/bench_conv.native": use_containers
<benchs/*.ml{,i,y}>: package(benchmark)
<benchs/*.ml{,i,y}>: package(bytes)
<benchs/*.ml{,i,y}>: use_containers
# Executable test_levenshtein
"tests/test_levenshtein.native": package(bytes)
"tests/test_levenshtein.native": package(qcheck)

519
advanced/CCMonadIO.ml Normal file
View file

@ -0,0 +1,519 @@
(*
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 IO Monad} *)
type _ t =
| Return : 'a -> 'a t
| Fail : string -> 'a t
| Map : ('a -> 'b) * 'a t -> 'b t
| Bind : ('a -> 'b t) * 'a t -> 'b t
| WithGuard: unit t * 'a t -> 'a t (* run guard in any case *)
| Star : ('a -> 'b) t * 'a t -> 'b t
| Repeat : int * 'a t -> 'a list t
| RepeatIgnore : int * 'a t -> unit t
| Wrap : (unit -> 'a) -> 'a t
| SequenceMap : ('a -> 'b t) * 'a list -> 'b list t
type 'a io = 'a t
type 'a with_finalizer = ('a t * unit t) t
type 'a or_error = [ `Ok of 'a | `Error of string ]
let (>>=) x f = Bind(f,x)
let bind ?finalize f a = match finalize with
| None -> Bind(f,a)
| Some b -> WithGuard (b, Bind (f,a))
let map f x = Map(f, x)
let (>|=) x f = Map(f, x)
let return x = Return x
let pure = return
let fail msg = Fail msg
let (<*>) f a = Star (f, a)
let lift = map
let lift2 f a b =
a >>= fun x -> map (f x) b
let lift3 f a b c =
a >>= fun x ->
b >>= fun y -> map (f x y) c
let sequence_map f l =
SequenceMap (f,l)
let sequence l =
let _id x = x in
SequenceMap(_id, l)
let repeat i a =
if i <= 0 then Return [] else Repeat (i,a)
let repeat' i a =
if i <= 0 then Return () else RepeatIgnore (i,a)
(** {2 Finalizers} *)
let (>>>=) a f =
a >>= function
| x, finalizer -> WithGuard (finalizer, x >>= f)
(** {2 Running} *)
exception IOFailure of string
let rec _run : type a. a t -> a = function
| Return x -> x
| Fail msg -> raise (IOFailure msg)
| Map (f, a) -> f (_run a)
| Bind (f, a) -> _run (f (_run a))
| WithGuard (g, a) ->
begin try
let res = _run a in
_run g;
res
with e ->
_run g;
raise e
end
| Star (f, a) -> _run f (_run a)
| Repeat (i,a) -> _repeat [] i a
| RepeatIgnore (i,a) -> _repeat_ignore i a
| Wrap f -> f()
| SequenceMap (f, l) -> _sequence_map f l []
and _repeat : type a. a list -> int -> a t -> a list
= fun acc i a -> match i with
| 0 -> List.rev acc
| _ ->
let x = _run a in
_repeat (x::acc) (i-1) a
and _repeat_ignore : type a. int -> a t -> unit
= fun i a -> match i with
| 0 -> ()
| _ ->
let _ = _run a in
_repeat_ignore (i-1) a
and _sequence_map : type a b. (a -> b t) -> a list -> b list -> b list
= fun f l acc -> match l with
| [] -> List.rev acc
| a::tail ->
let x = _run (f a) in
_sequence_map f tail (x::acc)
let _printers =
ref [
(* default printer *)
( function IOFailure msg
| Sys_error msg -> Some msg
| Exit -> Some "exit"
| _ -> None
)
]
exception PrinterResult of string
let _print_exn e =
try
List.iter
(fun p -> match p e with
| None -> ()
| Some msg -> raise (PrinterResult msg)
) !_printers;
Printexc.to_string e
with PrinterResult s -> s
let run x =
try `Ok (_run x)
with e -> `Error (_print_exn e)
exception IO_error of string
let run_exn x =
try _run x
with e -> raise (IO_error (_print_exn e))
let register_printer p = _printers := p :: !_printers
(** {2 Standard Wrappers} *)
let _open_in mode flags filename () =
open_in_gen flags mode filename
let _close_in ic () = close_in ic
let with_in ?(mode=0o644) ?(flags=[]) filename =
Wrap (_open_in mode flags filename)
>>= fun ic ->
Return (Return ic, Wrap (_close_in ic))
let _read ic s i len () = input ic s i len
let read ic s i len = Wrap (_read ic s i len)
let _read_line ic () =
try Some (Pervasives.input_line ic)
with End_of_file -> None
let read_line ic = Wrap(_read_line ic)
let rec _read_lines ic acc =
read_line ic
>>= function
| None -> return (List.rev acc)
| Some l -> _read_lines ic (l::acc)
let read_lines ic = _read_lines ic []
let _read_all ic () =
let buf = Buffer.create 128 in
try
while true do
Buffer.add_channel buf ic 1024
done;
"" (* never returned *)
with End_of_file -> Buffer.contents buf
let read_all ic = Wrap(_read_all ic)
let _open_out mode flags filename () =
open_out_gen flags mode filename
let _close_out oc () = close_out oc
let with_out ?(mode=0o644) ?(flags=[]) filename =
Wrap(_open_out mode (Open_wronly::flags) filename)
>>= fun oc ->
Return(Return oc, Wrap(_close_out oc))
let with_out_a ?mode ?(flags=[]) filename =
with_out ?mode ~flags:(Open_creat::Open_append::flags) filename
let _write oc s i len () = output oc s i len
let write oc s i len = Wrap (_write oc s i len)
let _write_str oc s () = output oc s 0 (String.length s)
let write_str oc s = Wrap (_write_str oc s)
let _write_line oc l () =
output_string oc l;
output_char oc '\n'
let write_line oc l = Wrap (_write_line oc l)
let _write_buf oc buf () = Buffer.output_buffer oc buf
let write_buf oc buf = Wrap (_write_buf oc buf)
let flush oc = Wrap (fun () -> Pervasives.flush oc)
(** {2 Seq} *)
module Seq = struct
type 'a step_result =
| Yield of 'a
| Stop
type 'a gen = unit -> 'a step_result io
type 'a t = 'a gen
let _stop () = return Stop
let _yield x = return (Yield x)
let map_pure f gen () =
gen() >>= function
| Stop -> _stop ()
| Yield x -> _yield (f x)
let map f g () =
g() >>= function
| Stop -> _stop ()
| Yield x -> f x >>= _yield
let rec filter_map f g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
match f x with
| None -> filter_map f g()
| Some y -> _yield y
let rec filter f g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
if f x then _yield x else filter f g()
let rec flat_map f g () =
g() >>= function
| Stop -> _stop ()
| Yield x ->
f x >>= fun g' -> _flat_map_aux f g g' ()
and _flat_map_aux f g g' () =
g'() >>= function
| Stop -> flat_map f g ()
| Yield x -> _yield x
let general_iter f acc g =
let acc = ref acc in
let rec _next () =
g() >>= function
| Stop -> _stop()
| Yield x ->
f !acc x >>= function
| `Stop -> _stop()
| `Continue (acc', ret) ->
acc := acc';
match ret with
| None -> _next()
| Some y -> _yield y
in
_next
let take n seq =
general_iter
(fun n x -> if n<=0
then return `Stop
else return (`Continue (n-1, Some x))
) n seq
let drop n seq =
general_iter
(fun n x -> if n<=0
then return (`Continue (n, Some x))
else return (`Continue (n-1, None))
) n seq
let take_while p seq =
general_iter
(fun () x ->
p x >|= function
| true -> `Continue ((), Some x)
| false -> `Stop
) () seq
let drop_while p seq =
general_iter
(fun dropping x ->
if dropping
then p x >|= function
| true -> `Continue (true, None)
| false -> `Continue (false, Some x)
else return (`Continue (false, Some x))
) true seq
(* apply all actions from [l] to [x] *)
let rec _apply_all_to x l = match l with
| [] -> return ()
| f::tail -> f x >>= fun () -> _apply_all_to x tail
let _tee funs g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
_apply_all_to x funs >>= fun () ->
_yield x
let tee funs g = match funs with
| [] -> g
| _::_ -> _tee funs g
(** {6 Consume} *)
let rec fold_pure f acc g =
g() >>= function
| Stop -> return acc
| Yield x -> fold_pure f (f acc x) g
let length g = fold_pure (fun acc _ -> acc+1) 0 g
let rec fold f acc g =
g() >>= function
| Stop -> return acc
| Yield x ->
f acc x >>= fun acc' -> fold f acc' g
let rec iter f g =
g() >>= function
| Stop -> return ()
| Yield x -> f x >>= fun _ -> iter f g
let of_fun g = g
let empty () = _stop()
let singleton x =
let first = ref true in
fun () ->
if !first then (first := false; _yield x) else _stop()
let cons x g =
let first = ref true in
fun () ->
if !first then (first := false; _yield x) else g()
let of_list l =
let l = ref l in
fun () -> match !l with
| [] -> _stop()
| x::tail -> l:= tail; _yield x
let of_array a =
let i = ref 0 in
fun () ->
if !i = Array.length a
then _stop()
else (
let x = a.(!i) in
incr i;
_yield x
)
(* TODO: wrapper around with_in? using bind ~finalize:... ? *)
let chunks ~size ic =
let buf = Buffer.create size in
let eof = ref false in
let next() =
if !eof then _stop()
else try
Buffer.add_channel buf ic size;
let s = Buffer.contents buf in
Buffer.clear buf;
_yield s
with End_of_file ->
let s = Buffer.contents buf in
eof := true;
if s="" then _stop() else _yield s
in
next
let lines ic () =
try _yield (input_line ic)
with End_of_file -> _stop()
let words _g =
failwith "words: not implemented yet"
(* TODO: state machine that goes:
- 0: read input chunk
- switch to "search for ' '", and yield word
- goto 0 if no ' ' found
- yield leftover when g returns Stop
let buf = Buffer.create 32 in
let next() =
g() >>= function
| Stop -> _stop
| Yield s ->
Buffer.add_string buf s;
search_
in
next
*)
let output ?sep oc seq =
let first = ref true in
iter
(fun s ->
(* print separator *)
( if !first
then (first:=false; return ())
else match sep with
| None -> return ()
| Some sep -> write_str oc sep
) >>= fun () ->
write_str oc s
) seq
>>= fun () -> flush oc
end
(** {6 File and file names} *)
module File = struct
type t = string
let to_string f = f
let make f =
if Filename.is_relative f
then Filename.concat (Sys.getcwd()) f
else f
let exists f = Wrap (fun () -> Sys.file_exists f)
let is_directory f = Wrap (fun () -> Sys.is_directory f)
let remove f = Wrap (fun () -> Sys.remove f)
let _read_dir d () =
if Sys.is_directory d
then
let arr = Sys.readdir d in
Seq.map_pure make (Seq.of_array arr)
else Seq.empty
let rec _walk d () =
if Sys.is_directory d
then
let arr = Sys.readdir d in
let tail = Seq.of_array arr in
let tail = Seq.flat_map
(fun s -> return (_walk (Filename.concat d s) ()))
tail
in Seq.cons (`Dir,d) tail
else Seq.singleton (`File, d)
let walk t = Wrap (_walk t)
let read_dir ?(recurse=false) d =
if recurse
then walk d
>|= Seq.filter_map
(function
| `File, f -> Some f
| `Dir, _ -> None
)
else Wrap (_read_dir d)
let rec _read_dir_rec d () =
if Sys.is_directory d
then
let arr = Sys.readdir d in
let arr = Seq.of_array arr in
let arr = Seq.map_pure (fun s -> Filename.concat d s) arr in
Seq.flat_map
(fun s ->
if Sys.is_directory s
then return (_read_dir_rec s ())
else return (Seq.singleton s)
) arr
else Seq.empty
end
(** {2 Raw} *)
module Raw = struct
let wrap f = Wrap f
end

323
advanced/CCMonadIO.mli Normal file
View file

@ -0,0 +1,323 @@
(*
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 IO Monad}
A simple abstraction over blocking IO, with strict evaluation. This is in
no way an alternative to Lwt/Async if you need concurrency.
@since 0.3.3
*)
(**
Examples:
- obtain the list of lines of a file:
{[
let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);;
]}
- transfer one file into another:
{[
# let a = CCIO.(
with_in "input" >>>= fun ic ->
with_out ~flags:[Open_creat] "output" >>>= fun oc ->
Seq.chunks 512 ic
|> Seq.output oc
) ;;
# run a;;
]}
*)
type 'a t
type 'a io = 'a t
type 'a with_finalizer
(** A value of type ['a with_finalizer] is similar to a value ['a t] but
also contains a finalizer that must be run to cleanup.
See {!(>>>=)} to get rid of it. *)
type 'a or_error = [ `Ok of 'a | `Error of string ]
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** wait for the result of an action, then use a function to build a
new action and execute it *)
val return : 'a -> 'a t
(** Just return a value *)
val repeat : int -> 'a t -> 'a list t
(** Repeat an IO action as many times as required *)
val repeat' : int -> 'a t -> unit t
(** Same as {!repeat}, but ignores the result *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Map values *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val bind : ?finalize:(unit t) -> ('a -> 'b t) -> 'a t -> 'b t
(** [bind f a] runs the action [a] and applies [f] to its result
to obtain a new action. It then behaves exactly like this new
action.
@param finalize an optional action that is always run after evaluating
the whole action *)
val pure : 'a -> 'a t
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
val lift : ('a -> 'b) -> 'a t -> 'b t
(** Synonym to {!map} *)
val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
val sequence : 'a t list -> 'a list t
(** Runs operations one by one and gather their results *)
val sequence_map : ('a -> 'b t) -> 'a list -> 'b list t
(** Generalization of {!sequence} *)
val fail : string -> 'a t
(** [fail msg] fails with the given message. Running the IO value will
return an [`Error] variant *)
(** {2 Finalizers} *)
val (>>>=) : 'a with_finalizer -> ('a -> 'b t) -> 'b t
(** Same as {!(>>=)}, but taking the finalizer into account. Once this
IO value is done executing, the finalizer is executed and the resource,
fred. *)
(** {2 Running} *)
val run : 'a t -> 'a or_error
(** Run an IO action.
@return either [`Ok x] when [x] is the successful result of the
computation, or some [`Error "message"] *)
exception IO_error of string
val run_exn : 'a t -> 'a
(** Unsafe version of {!run}. It assumes non-failure.
@raise IO_error if the execution didn't go well *)
val register_printer : (exn -> string option) -> unit
(** [register_printer p] register [p] as a possible failure printer.
If [run a] raises an exception [e], [p e] is evaluated. If [p e = Some msg]
then the error message will be [msg], otherwise other printers will
be tried *)
(** {2 Standard Wrappers} *)
(** {6 Input} *)
val with_in : ?mode:int -> ?flags:open_flag list ->
string -> in_channel with_finalizer
(** Open an input file with the given optional flag list.
It yields a [in_channel] with a finalizer attached. See {!(>>>=)} to
use it. *)
val read : in_channel -> string -> int -> int -> int t
(** Read a chunk into the given string *)
val read_line : in_channel -> string option t
(** Read a line from the channel. Returns [None] if the input is terminated. *)
val read_lines : in_channel -> string list t
(** Read all lines eagerly *)
val read_all : in_channel -> string t
(** Read the whole channel into a buffer, then converted into a string *)
(** {6 Output} *)
val with_out : ?mode:int -> ?flags:open_flag list ->
string -> out_channel with_finalizer
(** Same as {!with_in} but for an output channel *)
val with_out_a : ?mode:int -> ?flags:open_flag list ->
string -> out_channel with_finalizer
(** Similar to {!with_out} but with the [Open_append] and [Open_creat]
flags activated *)
val write : out_channel -> string -> int -> int -> unit t
val write_str : out_channel -> string -> unit t
val write_buf : out_channel -> Buffer.t -> unit t
val write_line : out_channel -> string -> unit t
val flush : out_channel -> unit t
(* TODO: printf/fprintf wrappers *)
(** {2 Streams}
Iterators on chunks of bytes, or lines, or any other value using combinators.
Those iterators are usable only once, because their source might
be usable only once (think of a socket) *)
module Seq : sig
type 'a t
(** An IO stream of values of type 'a, consumable (iterable only once) *)
val map : ('a -> 'b io) -> 'a t -> 'b t
(** Map values with actions *)
val map_pure : ('a -> 'b) -> 'a t -> 'b t
(** Map values with a pure function *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter : ('a -> bool) -> 'a t -> 'a t
val flat_map : ('a -> 'b t io) -> 'a t -> 'b t
(** Map each value to a sub sequence of values *)
val take : int -> 'a t -> 'a t
val drop : int -> 'a t -> 'a t
val take_while : ('a -> bool io) -> 'a t -> 'a t
val drop_while : ('a -> bool io) -> 'a t -> 'a t
val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)] io) ->
'b -> 'a t -> 'c t
(** [general_iter f acc seq] performs a [filter_map] over [seq],
using [f]. [f] is given a state and the current value, and
can either return [`Stop] to indicate it stops traversing,
or [`Continue (st, c)] where [st] is the new state and
[c] an optional output value.
The result is the stream of values output by [f] *)
val tee : ('a -> unit io) list -> 'a t -> 'a t
(** [tee funs seq] behaves like [seq], but each element is given to
every function [f] in [funs]. This function [f] returns an action that
is eagerly executed. *)
(** {6 Consume} *)
val iter : ('a -> _ io) -> 'a t -> unit io
(** Iterate on the stream, with an action for each element *)
val length : _ t -> int io
(** Length of the stream *)
val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io
(** [fold f acc seq] folds over [seq], consuming it. Every call to [f]
has the right to return an IO value. *)
val fold_pure : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b io
(** [fold f acc seq] folds over [seq], consuming it. [f] is pure. *)
(** {6 Standard Wrappers} *)
type 'a step_result =
| Yield of 'a
| Stop
type 'a gen = unit -> 'a step_result io
val of_fun : 'a gen -> 'a t
(** Create a stream from a function that yields an element or stops *)
val empty : 'a t
val singleton : 'a -> 'a t
val cons : 'a -> 'a t -> 'a t
val of_list : 'a list -> 'a t
val of_array : 'a array -> 'a t
val chunks : size:int -> in_channel -> string t
(** Read the channel's content into chunks of size [size] *)
val lines : in_channel -> string t
(** Lines of an input channel *)
val words : string t -> string t
(** Split strings into words at " " boundaries.
{b NOT IMPLEMENTED} *)
val output : ?sep:string -> out_channel -> string t -> unit io
(** [output oc seq] outputs every value of [seq] into [oc], separated
with the optional argument [sep] (default: None).
It blocks until all values of [seq] are produced and written to [oc]. *)
end
(** {6 File and file names}
How to list recursively files in a directory:
{[
CCIO.(
File.read_dir ~recurse:true (File.make "/tmp")
>>= Seq.output ~sep:"\n" stdout
) |> CCIO.run_exn ;;
]}
See {!File.walk} if you also need to list directories.
*)
module File : sig
type t = string
(** A file is always represented by its absolute path *)
val to_string : t -> string
val make : string -> t
(** Build a file representation from a path (absolute or relative) *)
val exists : t -> bool io
val is_directory : t -> bool io
val remove : t -> unit io
val read_dir : ?recurse:bool -> t -> t Seq.t io
(** [read_dir d] returns a sequence of files and directory contained
in the directory [d] (or an empty stream if [d] is not a directory)
@param recurse if true (default [false]), sub-directories are also
explored *)
val walk : t -> ([`File | `Dir] * t) Seq.t io
(** similar to {!read_dir} (with [recurse=true]), this function walks
a directory recursively and yields either files or directories.
Is a file anything that doesn't satisfy {!is_directory} (including
symlinks, etc.) *)
end
(** {2 Low level access} *)
module Raw : sig
val wrap : (unit -> 'a) -> 'a t
(** [wrap f] is the IO action that, when executed, returns [f ()].
[f] should be callable as many times as required *)
end

3
advanced/containers_advanced.mlpack
View file

@ -1,6 +1,7 @@
# OASIS_START
# DO NOT EDIT (digest: 0f4295a7a722dd4aab35ba71fd5daaae)
# DO NOT EDIT (digest: 5a399cd532edb84596f3034081578694)
CCLinq
CCBatch
CCCat
CCMonadIO
# OASIS_STOP

252
benchs/CCBench.ml Normal file
View file

@ -0,0 +1,252 @@
(*
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 helpers for benchmarks} *)
let print_line_ fmt () =
Format.pp_print_string fmt (CCString.repeat "*" 80);
Format.pp_print_newline fmt ()
let print_list_ ?(sep=", ") pp_item fmt l =
let rec print fmt l = match l with
| x::((_::_) as l) ->
pp_item fmt x;
Format.pp_print_string fmt sep;
Format.pp_print_cut fmt ();
print fmt l
| x::[] -> pp_item fmt x
| [] -> ()
in
print fmt l
(** {2 Bench Tree} *)
module SMap = Map.Make(String)
type single_bench = unit -> Benchmark.samples
type bench =
| Multiple of bench list * bench SMap.t
| Bench of single_bench
| WithInt of ((int -> bench) * int) list
let is_multiple = function
| Multiple _ -> true
| _ -> false
let rec merge_ t1 t2 = match t1, t2 with
| Multiple (l, map), ((Bench _ | WithInt _) as x) ->
Multiple (x :: l, map)
| Multiple (l1, m1), Multiple (l2, m2) ->
let m = SMap.merge
(fun _ o1 o2 -> merge_opt_ o1 o2)
m1 m2
in
Multiple (l1 @ l2, m)
| (Bench _ | WithInt _), Multiple _ -> merge_ t2 t1
| Bench _, _
| WithInt _, _ ->
Multiple ([t1; t2], SMap.empty) (* composite *)
and merge_opt_ o1 o2 = match o1, o2 with
| None, None -> None
| Some o, None
| None, Some o -> Some o
| Some o1, Some o2 -> Some (merge_ o1 o2)
let mk_list = function
| [] -> invalid_arg "mk_list"
| x :: tail -> List.fold_left merge_ x tail
let raw f = Bench f
let throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat time ?name f x =
Bench (fun () ->
Benchmark.throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat time ?name f x)
let throughputN ?style ?fwidth ?fdigits ?repeat time f =
Bench (fun () ->
Benchmark.throughputN ?style ?fwidth ?fdigits ?repeat time f)
let (>::) n t =
if n = "" then invalid_arg ">::";
Multiple ([], SMap.singleton n t)
let (>:::) n l =
if n = "" then invalid_arg ">:::";
Multiple ([], SMap.singleton n (mk_list l))
let with_int f = function
| [] -> invalid_arg "with_int: empty list"
| l -> WithInt (List.map (fun n -> f, n) l)
let map_int l =
if l = [] then invalid_arg "map_int";
WithInt l
(* print the structure of the tree *)
let rec print fmt = function
| Multiple (l, m) ->
Format.fprintf fmt "@[<hv>%a%a@]"
print_map m
(print_list_ ~sep:"," print) l
| WithInt l ->
Format.fprintf fmt "@[<hv>[%a]@]"
(print_list_ print_pair)
(List.map (fun (f, n) -> n, f n) l)
| Bench _ -> Format.fprintf fmt "<>"
and print_pair fmt (n,t) =
Format.fprintf fmt "@[<h>%d: %a@]" n print t
and print_map fmt m =
let first = ref true in
Format.pp_open_vbox fmt 0;
SMap.iter (fun n t ->
if !first then first := false else Format.pp_print_cut fmt ();
Format.fprintf fmt "@[%s.%a@]" n print t) m;
Format.pp_close_box fmt ()
(** {2 Path} *)
type path = string list
let print_path fmt path =
Format.fprintf fmt "@[<h>%a@]"
(print_list_ ~sep:"." Format.pp_print_string) path
let str_split_ ~by s =
let len_by = String.length by in
assert (len_by > 0);
let l = ref [] in
let n = String.length s in
let rec search prev i =
if i >= n
then (
if i>prev then l := String.sub s prev (n-prev) :: !l ;
List.rev !l
)
else if is_prefix i 0
then begin
l := (String.sub s prev (i-prev)) :: !l; (* save substring *)
search (i+len_by) (i+len_by)
end
else search prev (i+1)
and is_prefix i j =
if j = len_by
then true
else if i = n
then false
else s.[i] = by.[j] && is_prefix (i+1) (j+1)
in search 0 0
let parse_path s = str_split_ ~by:"." s
let () =
assert (parse_path "foo.bar" = ["foo";"bar"]);
assert (parse_path "foo" = ["foo"]);
assert (parse_path "" = []);
()
let prefix path t = List.fold_right (fun s t -> s >:: t) path t
(** {2 Run} *)
(* run one atomic single_bench *)
let run_single_bench_ fmt path f =
print_line_ fmt ();
Format.fprintf fmt "run bench %a@." print_path (List.rev path);
let res = f () in
Benchmark.tabulate res
(* run all benchs *)
let rec run_all fmt path t = match t with
| Bench f -> run_single_bench_ fmt path f
| Multiple (l, m) ->
List.iter (run_all fmt path) l;
SMap.iter
(fun n t' ->
let path = n :: path in
run_all fmt path t'
) m
| WithInt l ->
List.iter (fun (f, n) -> run_all fmt (string_of_int n::path) (f n)) l
let run fmt t = run_all fmt [] t
let sprintf_ format =
let b = Buffer.create 32 in
let fmt = Format.formatter_of_buffer b in
Format.kfprintf
(fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt format
(* run all within a path *)
let rec run_path_rec_ fmt path remaining t = match t, remaining with
| _, [] -> run_all fmt path t
| Multiple (_, m), s :: remaining' ->
begin try
let t' = SMap.find s m in
run_path_rec_ fmt (s::path) remaining' t'
with Not_found ->
let msg = sprintf_ "could not find %s under path %a"
s print_path (List.rev path) in
failwith msg
end
| WithInt l, _ ->
List.iter (fun (f, n) -> run_path_rec_ fmt (string_of_int n::path) remaining (f n)) l
| Bench _, _::_ -> ()
let run_path fmt t path = run_path_rec_ fmt [] path t
let run_main ?(argv=Sys.argv) ?(out=Format.std_formatter) t =
let path = ref [] in
let do_print_tree = ref false in
let set_path_ s = path := parse_path s in
let options =
[ "-p", Arg.String set_path_, "only apply to subpath"
; "-tree", Arg.Set do_print_tree, "print bench tree"
] in
try
Arg.parse_argv argv options (fun _ -> ()) "run benchmarks [options]";
if !do_print_tree
then Format.fprintf out "@[%a@]@." print t
else (
Format.printf "run on path %a@." print_path !path;
run_path out t !path (* regular path *)
)
with Arg.Help msg ->
Format.pp_print_string out msg
(** {2 Global Registration} *)
let tree_ = ref (Multiple ([], SMap.empty))
let global_bench () = !tree_
let register ?(path=[]) new_t =
tree_ := merge_ !tree_ (prefix path new_t)
let register' ~path new_t =
register ~path:(parse_path path) new_t
let run_main ?argv ?out () =
run_main ?argv ?out !tree_

113
benchs/CCBench.mli Normal file
View file

@ -0,0 +1,113 @@
(*
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 helpers for benchmarks} *)
(** {2 Benchmark Tree}
Naming benchmark within a hierarchy that allows to filter them *)
type bench
val throughput1 :
?min_count:Int64.t ->
?style:Benchmark.style ->
?fwidth:int ->
?fdigits:int ->
?repeat:int -> int -> ?name:string -> ('a -> 'b) -> 'a -> bench
val throughputN :
?style:Benchmark.style ->
?fwidth:int ->
?fdigits:int ->
?repeat:int -> int -> (string * ('a -> 'b) * 'a) list -> bench
val raw : (unit -> Benchmark.samples) -> bench
(** Give control to the user to produce her samples *)
val (>::) : string -> bench -> bench
val mk_list : bench list -> bench
val (>:::) : string -> bench list -> bench
val with_int : (int -> bench) -> int list -> bench
(** Parametrize a bench with several values *)
val map_int : ((int -> bench) * int) list -> bench
(** One function for each integer.
@raise Invalid_argument if the two lists don't have the same length
or are empty *)
val print : Format.formatter -> bench -> unit
(** Print the tree of benchmarks *)
(** {2 Path}
A path in a benchmark tree *)
type path = string list
val print_path : Format.formatter -> path -> unit
val parse_path : string -> path
(** split a string into a path at the "." separators *)
val prefix : path -> bench -> bench
(** Add the path as a prefix to the tree *)
(** {2 Running} *)
val run : Format.formatter -> bench -> unit
(** [run fmt t] runs all benchmarks of [t] and print the results to [fmt] *)
val run_path : Format.formatter -> bench -> path -> unit
(** Run only a sub-tree of the benchmarks *)
val run_main :
?argv:string array ->
?out:Format.formatter ->
bench -> unit
(** Main function: parses the command line arguments and runs benchmarks
accordingly *)
(** {2 Global Registration} *)
val register : ?path:path -> bench -> unit
(** Register a benchmark to the global register of benchmarks (a global tree) *)
val register' : path:string -> bench -> unit
(** Same as {!register} but applies {!parse_path} first to its argument *)
val global_bench : unit -> bench
(** Global bench tree, built from calls to {!register} *)
val run_main :
?argv:string array ->
?out:Format.formatter ->
unit -> unit
(** Same as {!run_main} but on the global tree of benchmarks *)

91
benchs/bench_batch.ml
View file

@ -1,91 +0,0 @@
(** benchmark CCBatch *)
open Containers_advanced
module type COLL = sig
val name : string
include CCBatch.COLLECTION
val doubleton : 'a -> 'a -> 'a t
val (--) : int -> int -> int t
val equal : int t -> int t -> bool
end
module Make(C : COLL) = struct
let f1 x = x mod 2 = 0
let f2 x = -x
let f3 x = C.doubleton x (x+1)
let f4 x = -x
let collect a = C.fold (+) 0 a
let naive a =
let a = C.filter f1 a in
let a = C.flat_map f3 a in
let a = C.filter f1 a in
let a = C.map f2 a in
let a = C.flat_map f3 a in
let a = C.map f4 a in
ignore (collect a);
a
module BA = CCBatch.Make(C)
let ops =
BA.(filter f1 >>> flat_map f3 >>> filter f1 >>> map f2 >>> flat_map f3 >>> map f4)
let batch a =
let a = BA.apply ops a in
ignore (collect a);
a
let bench_for ~time n =
Printf.printf "\n\nbenchmark for %s of len %d\n" C.name n;
flush stdout;
let a = C.(0 -- n) in
(* debug
CCPrint.printf "naive: %a\n" (CCArray.pp CCInt.pp) (naive a);
CCPrint.printf "simple: %a\n" (CCArray.pp CCInt.pp) (batch_simple a);
CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a);
*)
assert (C.equal (batch a) (naive a));
let res = Benchmark.throughputN time
[ C.name ^ "_naive", naive, a
; C.name ^ "_batch", batch, a
]
in
Benchmark.tabulate res
let bench () =
bench_for 1 100;
bench_for 4 100_000;
bench_for 4 1_000_000;
()
end
module BenchArray = Make(struct
include CCArray
let name = "array"
let equal a b = a=b
let doubleton x y = [| x; y |]
let fold = Array.fold_left
end)
module BenchList = Make(struct
include CCList
let name = "list"
let equal a b = a=b
let doubleton x y = [ x; y ]
let fold = List.fold_left
end)
module BenchKList = Make(struct
include CCKList
let name = "klist"
let equal a b = equal (=) a b
let doubleton x y = CCKList.of_list [ x; y ]
end)
let () =
BenchArray.bench();
BenchList.bench();
BenchKList.bench ();
()

419
benchs/benchs.ml
View file

@ -1,419 +0,0 @@
(** Benchmarking *)
(** {2 hashtables} *)
module IHashtbl = Hashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IFlatHashtbl = FlatHashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IFHashtbl = FHashtbl.Tree(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IPersistentHashtbl = CCPersistentHashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IMap = Map.Make(struct
type t = int
let compare i j = i - j
end)
module ICCHashtbl = CCFlatHashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
let phashtbl_add n =
let h = PHashtbl.create 50 in
for i = n downto 0 do
PHashtbl.add h i i;
done;
h
let hashtbl_add n =
let h = Hashtbl.create 50 in
for i = n downto 0 do
Hashtbl.add h i i;
done;
h
let ihashtbl_add n =
let h = IHashtbl.create 50 in
for i = n downto 0 do
IHashtbl.add h i i;
done;
h
let iflathashtbl_add n =
let h = IFlatHashtbl.create 50 in
for i = n downto 0 do
IFlatHashtbl.replace h i i;
done;
h
let ifhashtbl_add n =
let h = ref (IFHashtbl.empty 32) in
for i = n downto 0 do
h := IFHashtbl.replace !h i i;
done;
!h
let skiplist_add n =
let l = SkipList.create compare in
for i = n downto 0 do
SkipList.add l i i;
done;
l
let ipersistenthashtbl_add n =
let h = ref (IPersistentHashtbl.create 32) in
for i = n downto 0 do
h := IPersistentHashtbl.replace !h i i;
done;
!h
let imap_add n =
let h = ref IMap.empty in
for i = n downto 0 do
h := IMap.add i i !h;
done;
!h
let icchashtbl_add n =
let h = ICCHashtbl.create 50 in
for i = n downto 0 do
ICCHashtbl.add h i i;
done;
h
let bench_maps1 () =
Format.printf "----------------------------------------@.";
let res = Bench.bench_n
["phashtbl_add", (fun n -> ignore (phashtbl_add n));
"hashtbl_add", (fun n -> ignore (hashtbl_add n));
"ihashtbl_add", (fun n -> ignore (ihashtbl_add n));
"iflathashtbl_add", (fun n -> ignore (iflathashtbl_add n));
"ifhashtbl_add", (fun n -> ignore (ifhashtbl_add n));
"ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n));
"skiplist_add", (fun n -> ignore (skiplist_add n));
"imap_add", (fun n -> ignore (imap_add n));
"ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n))
]
in
Bench.summarize 1. res
let phashtbl_replace n =
let h = PHashtbl.create 50 in
for i = 0 to n do
PHashtbl.replace h i i;
done;
for i = n downto 0 do
PHashtbl.replace h i i;
done;
h
let hashtbl_replace n =
let h = Hashtbl.create 50 in
for i = 0 to n do
Hashtbl.replace h i i;
done;
for i = n downto 0 do
Hashtbl.replace h i i;
done;
h
let ihashtbl_replace n =
let h = IHashtbl.create 50 in
for i = 0 to n do
IHashtbl.replace h i i;
done;
for i = n downto 0 do
IHashtbl.replace h i i;
done;
h
let iflathashtbl_replace n =
let h = IFlatHashtbl.create 50 in
for i = 0 to n do
IFlatHashtbl.replace h i i;
done;
for i = n downto 0 do
IFlatHashtbl.replace h i i;
done;
h
let ifhashtbl_replace n =
let h = ref (IFHashtbl.empty 32) in
for i = 0 to n do
h := IFHashtbl.replace !h i i;
done;
for i = n downto 0 do
h := IFHashtbl.replace !h i i;
done;
!h
let ipersistenthashtbl_replace n =
let h = ref (IPersistentHashtbl.create 32) in
for i = 0 to n do
h := IPersistentHashtbl.replace !h i i;
done;
for i = n downto 0 do
h := IPersistentHashtbl.replace !h i i;
done;
!h
let skiplist_replace n =
let l = SkipList.create compare in
for i = 0 to n do
SkipList.add l i i;
done;
for i = n downto 0 do
SkipList.add l i i;
done;
l
let imap_replace n =
let h = ref IMap.empty in
for i = 0 to n do
h := IMap.add i i !h;
done;
for i = n downto 0 do
h := IMap.add i i !h;
done;
!h
let icchashtbl_replace n =
let h = ICCHashtbl.create 50 in
for i = 0 to n do
ICCHashtbl.add h i i;
done;
for i = n downto 0 do
ICCHashtbl.add h i i;
done;
h
let bench_maps2 () =
Format.printf "----------------------------------------@.";
let res = Bench.bench_n
["phashtbl_replace", (fun n -> ignore (phashtbl_replace n));
"hashtbl_replace", (fun n -> ignore (hashtbl_replace n));
"ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n));
"iflathashtbl_replace", (fun n -> ignore (iflathashtbl_replace n));
"ifhashtbl_replace", (fun n -> ignore (ifhashtbl_replace n));
"ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n));
"skiplist_replace", (fun n -> ignore (skiplist_replace n));
"imap_replace", (fun n -> ignore (imap_replace n));
"ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n));
]
in
Bench.summarize 1. res
let my_len = 250
let phashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (PHashtbl.find h i);
done
let hashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (Hashtbl.find h i);
done
let ihashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IHashtbl.find h i);
done
let iflathashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IFlatHashtbl.find h i);
done
let ifhashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IFHashtbl.find h i);
done
let ipersistenthashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IPersistentHashtbl.find h i);
done
let skiplist_find l =
fun n ->
for i = 0 to n-1 do
ignore (SkipList.find l i);
done
let array_find a =
fun n ->
for i = 0 to n-1 do
ignore (Array.get a i);
done
let imap_find m =
fun n ->
for i = 0 to n-1 do
ignore (IMap.find i m);
done
let icchashtbl_find m =
fun n ->
for i = 0 to n-1 do
ignore (ICCHashtbl.get_exn i m);
done
let bench_maps3 () =
List.iter
(fun len ->
let h = phashtbl_add len in
let h' = hashtbl_add len in
let h'' = ihashtbl_add len in
let h''' = iflathashtbl_add len in
let h'''' = ifhashtbl_add len in
let h''''' = ipersistenthashtbl_add len in
let l = skiplist_add len in
let a = Array.init len (fun i -> string_of_int i) in
let m = imap_add len in
let h'''''' = icchashtbl_add len in
Format.printf "----------------------------------------@.";
Format.printf "try on size %d@.@.@." len;
Bench.bench [
"phashtbl_find", (fun () -> phashtbl_find h len);
"hashtbl_find", (fun () -> hashtbl_find h' len);
"ihashtbl_find", (fun () -> ihashtbl_find h'' len);
"iflathashtbl_find", (fun () -> iflathashtbl_find h''' len);
"ifhashtbl_find", (fun () -> ifhashtbl_find h'''' len);
"ipersistenthashtbl_find", (fun () -> ipersistenthashtbl_find h''''' len);
"skiplist_find", (fun () -> skiplist_find l len);
"array_find", (fun () -> array_find a len);
"imap_find", (fun () -> imap_find m len);
"cchashtbl_find", (fun () -> icchashtbl_find h'''''' len);
])
[10;20;100;1000;10000]
let bench_maps() =
bench_maps1 ();
bench_maps2 ();
bench_maps3 ();
()
(** {2 Sequence/Gen} *)
let bench_enum () =
let n = 1_000_000 in
let seq () = CCSequence.fold (+) 0 (CCSequence.int_range ~start:0 ~stop:n) in
let enum () = CCGen.fold (+) 0 (CCGen.int_range 0 n) in
Bench.bench
[ "sequence.fold", seq;
"gen.fold", enum;
];
let n = 100_000 in
let seq () =
let open CCSequence in
let seq = int_range ~start:0 ~stop:n in
let seq = flatMap (fun x -> int_range ~start:x ~stop:(x+10)) seq in
fold (+) 0 seq in
let enum () =
let open CCGen in
let seq = int_range 0 n in
let seq = flat_map (fun x -> int_range x (x+10)) seq in
fold (+) 0 seq in
Bench.bench
[ "sequence.flatMap", seq;
"gen.flatMap", enum;
]
(** {2 Cache} *)
(** Cached fibonacci function *)
module Fibo(C : Cache.S with type key = int) = struct
let fib ~size =
let rec fib fib' n =
match n with
| 0 -> 0
| 1 -> 1
| 2 -> 1
| n ->
fib' (n-1) + fib' (n-2)
in
let cache = C.create size in
let cached_fib x = C.with_cache_rec cache fib x in
cached_fib
end
module LinearIntCache = Cache.Linear(struct
type t = int
let equal i j = i = j
end)
module ReplacingIntCache = Cache.Replacing(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module LRUIntCache = Cache.LRU(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module DummyIntCache = Cache.Dummy(struct type t = int end)
let bench_cache () =
(* Fibonacci for those caching implementations *)
let module LinearFibo = Fibo(LinearIntCache) in
let module ReplacingFibo = Fibo(ReplacingIntCache) in
let module LRUFibo= Fibo(LRUIntCache) in
let module DummyFibo = Fibo(DummyIntCache) in
(* benchmark caches with fibo function *)
let bench_fib fib () =
ignore (List.map fib [5;10;20;30;35]);
()
in
let conf = Bench.config in
conf.Bench.samples <- 100;
Bench.bench
[ "linear_fib", bench_fib (LinearFibo.fib ~size:5);
"replacing_fib", bench_fib (ReplacingFibo.fib ~size:256);
"LRU_fib", bench_fib (LRUFibo.fib ~size:256);
"dummy_fib", bench_fib (DummyFibo.fib ~size:5);
];
conf.Bench.samples <- 1000;
()
let _ =
match Sys.argv with
| [| _; "maps" |] -> bench_maps ()
| [| _; "enum" |] -> bench_enum ()
| [| _; "cache" |] -> bench_cache ()
| [| _; ("-help" | "--help") |] -> print_endline "./benchs [maps|enum|cache]"
| [| _ |] ->
bench_enum ();
bench_maps ();
bench_cache ();
()
| _ -> failwith "unknown argument (-help)"

612
benchs/run_benchs.ml Normal file
View file

@ -0,0 +1,612 @@
(** Generic benchs *)
(* composition *)
let (%%) f g x = f (g x)
(* FIXME: find out why -tree takes so long *)
module L = struct
(* FLAT MAP *)
let f_ x =
if x mod 10 = 0 then []
else if x mod 5 = 1 then [x;x+1]
else [x;x+1;x+2;x+3]
let bench_flat_map ?(time=2) n =
let l = lazy CCList.(1 -- n) in
let flatten_map_ l = List.flatten (CCList.map f_ l)
and flatten_ccmap_ l = List.flatten (List.map f_ l) in
CCBench.throughputN time
[ "flat_map", CCList.flat_map f_ %% Lazy.force, l
; "flatten o CCList.map", flatten_ccmap_ %% Lazy.force, l
; "flatten o map", flatten_map_ %% Lazy.force, l
]
(* APPEND *)
let append_ f (lazy l1, lazy l2, lazy l3) =
ignore (f (f l1 l2) l3)
let bench_append ?(time=2) n =
let l1 = lazy CCList.(1 -- n) in
let l2 = lazy CCList.(n+1 -- 2*n) in
let l3 = lazy CCList.(2*n+1 -- 3*n) in
let arg = l1, l2, l3 in
CCBench.throughputN time
[ "CCList.append", append_ CCList.append, arg
; "List.append", append_ List.append, arg
]
(* FLATTEN *)
let bench_flatten ?(time=2) n =
let fold_right_append_ l =
List.fold_right List.append l []
and cc_fold_right_append_ l =
CCList.fold_right CCList.append l []
in
let l = lazy (
CCList.Idx.mapi
(fun i x -> CCList.(x -- (x+ min i 100)))
CCList.(1 -- n))
in
CCBench.throughputN time
[ "CCList.flatten", CCList.flatten %% Lazy.force, l
; "List.flatten", List.flatten %% Lazy.force, l
; "fold_right append", fold_right_append_ %% Lazy.force, l
; "CCList.(fold_right append)", cc_fold_right_append_ %% Lazy.force, l
]
(* MAIN *)
let () = CCBench.register CCBench.(
"list" >:::
[ "flat_map" >::
map_int
[ bench_flat_map ~time:2, 100
; bench_flat_map ~time:2, 10_000
; bench_flat_map ~time:4, 100_000]
; "flatten" >::
map_int
[ bench_flatten ~time:2, 100
; bench_flatten ~time:2, 10_000
; bench_flatten ~time:4, 100_000]
; "append" >::
map_int
[ bench_append ~time:2, 100
; bench_append ~time:2, 10_000
; bench_append ~time:4, 100_000]
]
)
end
module Vec = struct
let f x = x+1
let map_push_ f v =
let v' = CCVector.create () in
CCVector.iter (fun x -> CCVector.push v' (f x)) v;
v'
let map_push_size_ f v =
let v' = CCVector.create_with ~capacity:(CCVector.length v) 0 in
CCVector.iter (fun x -> CCVector.push v' (f x)) v;
v'
let bench_map n =
let v = lazy (CCVector.init n (fun x->x)) in
CCBench.throughputN 2
[ "map", CCVector.map f %% Lazy.force, v
; "map_push", map_push_ f %% Lazy.force, v
; "map_push_cap", map_push_size_ f %% Lazy.force, v
]
let try_append_ app n v2 () =
let v1 = CCVector.init n (fun x->x) in
app v1 (Lazy.force v2);
assert (CCVector.length v1 = 2*n);
()
let append_naive_ v1 v2 =
CCVector.iter (fun x -> CCVector.push v1 x) v2
let bench_append n =
let v2 = lazy (CCVector.init n (fun x->n+x)) in
CCBench.throughputN 2
[ "append", try_append_ CCVector.append n v2, ()
; "append_naive", try_append_ append_naive_ n v2, ()
]
let () = CCBench.register CCBench.(
"vector" >:::
[ "map" >:: with_int bench_map [100; 10_000; 100_000]
; "append" >:: with_int bench_append [100; 10_000; 50_000]
]
)
end
module Cache = struct
module C = CCCache
let make_fib c =
let f = C.with_cache_rec c
(fun fib n -> match n with
| 0 -> 0
| 1 -> 1
| 2 -> 1
| n -> fib (n-1) + fib (n-2)
)
in
fun x ->
C.clear c;
f x
let bench_fib n =
let l =
[ "replacing_fib (128)", make_fib (C.replacing 128), n
; "LRU_fib (128)", make_fib (C.lru 128), n
; "replacing_fib (16)", make_fib (C.replacing 16), n
; "LRU_fib (16)", make_fib (C.lru 16), n
; "unbounded", make_fib (C.unbounded 32), n
]
in
let l = if n <= 20
then [ "linear_fib (5)", make_fib (C.linear 5), n
; "linear_fib (32)", make_fib (C.linear 32), n
; "dummy_fib", make_fib C.dummy, n
] @ l
else l
in
CCBench.throughputN 3 l
let () = CCBench.register CCBench.(
"cache" >:::
[ "fib" >:: with_int bench_fib [10; 20; 100; 200; 1_000;]
]
)
end
module Tbl = struct
module IHashtbl = Hashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IFlatHashtbl = FlatHashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IFHashtbl = FHashtbl.Tree(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IPersistentHashtbl = CCPersistentHashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
module IMap = Map.Make(struct
type t = int
let compare i j = i - j
end)
module ICCHashtbl = CCFlatHashtbl.Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)
let phashtbl_add n =
let h = PHashtbl.create 50 in
for i = n downto 0 do
PHashtbl.add h i i;
done;
h
let hashtbl_add n =
let h = Hashtbl.create 50 in
for i = n downto 0 do
Hashtbl.add h i i;
done;
h
let ihashtbl_add n =
let h = IHashtbl.create 50 in
for i = n downto 0 do
IHashtbl.add h i i;
done;
h
let iflathashtbl_add n =
let h = IFlatHashtbl.create 50 in
for i = n downto 0 do
IFlatHashtbl.replace h i i;
done;
h
let ifhashtbl_add n =
let h = ref (IFHashtbl.empty 32) in
for i = n downto 0 do
h := IFHashtbl.replace !h i i;
done;
!h
let skiplist_add n =
let l = SkipList.create compare in
for i = n downto 0 do
SkipList.add l i i;
done;
l
let ipersistenthashtbl_add n =
let h = ref (IPersistentHashtbl.create 32) in
for i = n downto 0 do
h := IPersistentHashtbl.replace !h i i;
done;
!h
let imap_add n =
let h = ref IMap.empty in
for i = n downto 0 do
h := IMap.add i i !h;
done;
!h
let icchashtbl_add n =
let h = ICCHashtbl.create 50 in
for i = n downto 0 do
ICCHashtbl.add h i i;
done;
h
let bench_maps1 n =
CCBench.throughputN 3
["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n;
"hashtbl_add", (fun n -> ignore (hashtbl_add n)), n;
"ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n;
"iflathashtbl_add", (fun n -> ignore (iflathashtbl_add n)), n;
"ifhashtbl_add", (fun n -> ignore (ifhashtbl_add n)), n;
"ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n)), n;
"skiplist_add", (fun n -> ignore (skiplist_add n)), n;
"imap_add", (fun n -> ignore (imap_add n)), n;
"ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)), n;
]
let phashtbl_replace n =
let h = PHashtbl.create 50 in
for i = 0 to n do
PHashtbl.replace h i i;
done;
for i = n downto 0 do
PHashtbl.replace h i i;
done;
h
let hashtbl_replace n =
let h = Hashtbl.create 50 in
for i = 0 to n do
Hashtbl.replace h i i;
done;
for i = n downto 0 do
Hashtbl.replace h i i;
done;
h
let ihashtbl_replace n =
let h = IHashtbl.create 50 in
for i = 0 to n do
IHashtbl.replace h i i;
done;
for i = n downto 0 do
IHashtbl.replace h i i;
done;
h
let iflathashtbl_replace n =
let h = IFlatHashtbl.create 50 in
for i = 0 to n do
IFlatHashtbl.replace h i i;
done;
for i = n downto 0 do
IFlatHashtbl.replace h i i;
done;
h
let ifhashtbl_replace n =
let h = ref (IFHashtbl.empty 32) in
for i = 0 to n do
h := IFHashtbl.replace !h i i;
done;
for i = n downto 0 do
h := IFHashtbl.replace !h i i;
done;
!h
let ipersistenthashtbl_replace n =
let h = ref (IPersistentHashtbl.create 32) in
for i = 0 to n do
h := IPersistentHashtbl.replace !h i i;
done;
for i = n downto 0 do
h := IPersistentHashtbl.replace !h i i;
done;
!h
let skiplist_replace n =
let l = SkipList.create compare in
for i = 0 to n do
SkipList.add l i i;
done;
for i = n downto 0 do
SkipList.add l i i;
done;
l
let imap_replace n =
let h = ref IMap.empty in
for i = 0 to n do
h := IMap.add i i !h;
done;
for i = n downto 0 do
h := IMap.add i i !h;
done;
!h
let icchashtbl_replace n =
let h = ICCHashtbl.create 50 in
for i = 0 to n do
ICCHashtbl.add h i i;
done;
for i = n downto 0 do
ICCHashtbl.add h i i;
done;
h
let bench_maps2 n =
CCBench.throughputN 3
["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n;
"hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n;
"ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n;
"iflathashtbl_replace", (fun n -> ignore (iflathashtbl_replace n)), n;
"ifhashtbl_replace", (fun n -> ignore (ifhashtbl_replace n)), n;
"ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n)), n;
"skiplist_replace", (fun n -> ignore (skiplist_replace n)), n;
"imap_replace", (fun n -> ignore (imap_replace n)), n;
"ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)), n;
]
let my_len = 250
let phashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (PHashtbl.find h i);
done
let hashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (Hashtbl.find h i);
done
let ihashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IHashtbl.find h i);
done
let iflathashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IFlatHashtbl.find h i);
done
let ifhashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IFHashtbl.find h i);
done
let ipersistenthashtbl_find h =
fun n ->
for i = 0 to n-1 do
ignore (IPersistentHashtbl.find h i);
done
let skiplist_find l =
fun n ->
for i = 0 to n-1 do
ignore (SkipList.find l i);
done
let array_find a =
fun n ->
for i = 0 to n-1 do
ignore (Array.get a i);
done
let imap_find m =
fun n ->
for i = 0 to n-1 do
ignore (IMap.find i m);
done
let icchashtbl_find m =
fun n ->
for i = 0 to n-1 do
ignore (ICCHashtbl.get_exn i m);
done
let bench_maps3 n =
let h = phashtbl_add n in
let h' = hashtbl_add n in
let h'' = ihashtbl_add n in
let h''' = iflathashtbl_add n in
let h'''' = ifhashtbl_add n in
let h''''' = ipersistenthashtbl_add n in
let l = skiplist_add n in
let a = Array.init n (fun i -> string_of_int i) in
let m = imap_add n in
let h'''''' = icchashtbl_add n in
CCBench.throughputN 3 [
"phashtbl_find", (fun () -> phashtbl_find h n), ();
"hashtbl_find", (fun () -> hashtbl_find h' n), ();
"ihashtbl_find", (fun () -> ihashtbl_find h'' n), ();
"iflathashtbl_find", (fun () -> iflathashtbl_find h''' n), ();
"ifhashtbl_find", (fun () -> ifhashtbl_find h'''' n), ();
"ipersistenthashtbl_find", (fun () -> ipersistenthashtbl_find h''''' n), ();
"skiplist_find", (fun () -> skiplist_find l n), ();
"array_find", (fun () -> array_find a n), ();
"imap_find", (fun () -> imap_find m n), ();
"cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), ();
]
let () = CCBench.register CCBench.(
"tbl" >:::
[ "add" >:: with_int bench_maps1 [10; 100; 1_000; 10_000;]
; "replace" >:: with_int bench_maps2 [10; 100; 1_000; 10_000]
; "find" >:: with_int bench_maps3 [10; 20; 100; 1_000; 10_000]
])
end
module Iter = struct
(** {2 Sequence/Gen} *)
let bench_fold n =
let seq () = CCSequence.fold (+) 0 CCSequence.(0 --n) in
let gen () = CCGen.fold (+) 0 CCGen.(0 -- n) in
let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in
CCBench.throughputN 3
[ "sequence.fold", seq, ();
"gen.fold", gen, ();
"klist.fold", klist, ();
]
let bench_flat_map n =
let seq () = CCSequence.(
0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0
)
and gen () = CCGen.(
0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0
)
and klist () = CCKList.(
0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0
)
in
CCBench.throughputN 3
[ "sequence.flat_map", seq, ();
"gen.flat_map", gen, ();
"klist.flat_map", klist, ();
]
let () = CCBench.register CCBench.(
"iter" >:::
[ "fold" >:: with_int bench_fold [100; 1_000; 10_000; 1_000_000]
; "flat_map" >:: with_int bench_flat_map [1_000; 10_000]
])
end
module Batch = struct
(** benchmark CCBatch *)
open Containers_advanced
module type COLL = sig
val name : string
include CCBatch.COLLECTION
val doubleton : 'a -> 'a -> 'a t
val (--) : int -> int -> int t
val equal : int t -> int t -> bool
end
module Make(C : COLL) = struct
let f1 x = x mod 2 = 0
let f2 x = -x
let f3 x = C.doubleton x (x+1)
let f4 x = -x
let collect a = C.fold (+) 0 a
let naive a =
let a = C.filter f1 a in
let a = C.flat_map f3 a in
let a = C.filter f1 a in
let a = C.map f2 a in
let a = C.flat_map f3 a in
let a = C.map f4 a in
ignore (collect a);
a
module BA = CCBatch.Make(C)
let ops =
BA.(filter f1 >>> flat_map f3 >>> filter f1 >>>
map f2 >>> flat_map f3 >>> map f4)
let batch a =
let a = BA.apply ops a in
ignore (collect a);
a
let bench_for ~time n =
let a = C.(0 -- n) in
(* debug
CCPrint.printf "naive: %a\n" (CCArray.pp CCInt.pp) (naive a);
CCPrint.printf "simple: %a\n" (CCArray.pp CCInt.pp) (batch_simple a);
CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a);
*)
assert (C.equal (batch a) (naive a));
CCBench.throughputN time
[ C.name ^ "_naive", naive, a
; C.name ^ "_batch", batch, a
]
let bench = CCBench.(
C.name >:: map_int
[ bench_for ~time:1, 100
; bench_for ~time:4, 100_000
; bench_for ~time:4, 1_000_000
])
end
module BenchArray = Make(struct
include CCArray
let name = "array"
let equal a b = a=b
let doubleton x y = [| x; y |]
let fold = Array.fold_left
end)
module BenchList = Make(struct
include CCList
let name = "list"
let equal a b = a=b
let doubleton x y = [ x; y ]
let fold = List.fold_left
end)
module BenchKList = Make(struct
include CCKList
let name = "klist"
let equal a b = equal (=) a b
let doubleton x y = CCKList.of_list [ x; y ]
end)
let () = CCBench.register CCBench.(
"batch" >:: mk_list
[ BenchKList.bench
; BenchArray.bench
; BenchList.bench
])
end
let () =
CCBench.run_main ()

3
containers.odocl
View file

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

3
containers_advanced.odocl
View file

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

4
containers_misc.odocl
View file

@ -1,6 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 3c4c75622413b2b99679e7439134f037)
misc/Cache
# DO NOT EDIT (digest: df85a5182175d1029216007c66a27aa4)
misc/FHashtbl
misc/FlatHashtbl
misc/Hashset
@ -31,4 +30,5 @@ misc/Ty
misc/Cause
misc/AVL
misc/ParseReact
misc/Mixtbl
# OASIS_STOP

326
core/CCCache.ml Normal file
View file

@ -0,0 +1,326 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Caches} *)
type 'a equal = 'a -> 'a -> bool
type 'a hash = 'a -> int
let default_eq_ = Pervasives.(=)
let default_hash_ = Hashtbl.hash
(** {2 Value interface} *)
type ('a,'b) t = {
set : 'a -> 'b -> unit;
get : 'a -> 'b; (* or raise Not_found *)
size : unit -> int;
iter : ('a -> 'b -> unit) -> unit;
clear : unit -> unit;
}
let clear c = c.clear ()
let with_cache c f x =
try
c.get x
with Not_found ->
let y = f x in
c.set x y;
y
let with_cache_rec c f =
let rec f' x = with_cache c (f f') x in
f'
let size c = c.size ()
let iter c f = c.iter f
let dummy = {
set=(fun _ _ -> ());
get=(fun _ -> raise Not_found);
clear=(fun _ -> ());
size=(fun _ -> 0);
iter=(fun _ -> ());
}
module Linear = struct
type ('a,'b) bucket =
| Empty
| Pair of 'a * 'b
type ('a,'b) t = {
eq : 'a equal;
arr : ('a,'b) bucket array;
mutable i : int; (* index for next assertion, cycles through *)
}
let make eq size =
assert (size>0);
{arr=Array.make size Empty; eq; i=0; }
let clear c =
Array.fill c.arr 0 (Array.length c.arr) Empty;
c.i <- 0
(* linear lookup *)
let rec search_ c i x =
if i=Array.length c.arr then raise Not_found;
match c.arr.(i) with
| Pair (x', y) when c.eq x x' -> y
| Pair _
| Empty -> search_ c (i+1) x
let get c x = search_ c 0 x
let set c x y =
c.arr.(c.i) <- Pair (x,y);
c.i <- (c.i + 1) mod Array.length c.arr
let iter c f =
Array.iter (function Pair (x,y) -> f x y | Empty -> ()) c.arr
let size c () =
let r = ref 0 in
iter c (fun _ _ -> incr r);
!r
end
let linear ?(eq=default_eq_) size =
let size = max size 1 in
let arr = Linear.make eq size in
{ get=(fun x -> Linear.get arr x);
set=(fun x y -> Linear.set arr x y);
clear=(fun () -> Linear.clear arr);
size=Linear.size arr;
iter=Linear.iter arr;
}
module Replacing = struct
type ('a,'b) bucket =
| Empty
| Pair of 'a * 'b
type ('a,'b) t = {
eq : 'a equal;
hash : 'a hash;
arr : ('a,'b) bucket array;
mutable c_size : int;
}
let make eq hash size =
assert (size>0);
{arr=Array.make size Empty; eq; hash; c_size=0 }
let clear c =
c.c_size <- 0;
Array.fill c.arr 0 (Array.length c.arr) Empty
let get c x =
let i = c.hash x mod Array.length c.arr in
match c.arr.(i) with
| Pair (x', y) when c.eq x x' -> y
| Pair _
| Empty -> raise Not_found
let set c x y =
let i = c.hash x mod Array.length c.arr in
if c.arr.(i) = Empty then c.c_size <- c.c_size + 1;
c.arr.(i) <- Pair (x,y)
let iter c f =
Array.iter (function Empty -> () | Pair (x,y) -> f x y) c.arr
let size c () = c.c_size
end
let replacing ?(eq=default_eq_) ?(hash=default_hash_) size =
let c = Replacing.make eq hash size in
{ get=(fun x -> Replacing.get c x);
set=(fun x y -> Replacing.set c x y);
clear=(fun () -> Replacing.clear c);
size=Replacing.size c;
iter=Replacing.iter c;
}
module type HASH = sig
type t
val equal : t equal
val hash : t hash
end
module LRU(X:HASH) = struct
type key = X.t
module H = Hashtbl.Make(X)
type 'a t = {
table : 'a node H.t; (* hashtable key -> node *)
mutable first : 'a node option;
size : int; (* max size *)
}
and 'a node = {
mutable key : key;
mutable value : 'a;
mutable next : 'a node;
mutable prev : 'a node;
} (** Meta data for the value, making a chained list *)
let make size =
assert (size > 0);
{ table = H.create size;
size;
first=None;
}
let clear c =
H.clear c.table;
c.first <- None;
()
(* take first from queue *)
let take_ c =
match c.first with
| Some n when n.next == n ->
(* last element *)
c.first <- None;
n
| Some n ->
c.first <- Some n.next;
n.prev.next <- n.next;
n.next.prev <- n.prev;
n
| None ->
failwith "LRU: empty queue"
(* push at back of queue *)
let push_ c n =
match c.first with
| None ->
n.next <- n;
n.prev <- n;
c.first <- Some n
| Some n1 when n1==n -> ()
| Some n1 ->
n.prev <- n1.prev;
n.next <- n1;
n1.prev.next <- n;
n1.prev <- n
(* remove from queue *)
let remove_ n =
n.prev.next <- n.next;
n.next.prev <- n.prev
(* Replace least recently used element of [c] by x->y *)
let replace_ c x y =
(* remove old *)
let n = take_ c in
H.remove c.table n.key;
(* add x->y, at the back of the queue *)
n.key <- x;
n.value <- y;
H.add c.table x n;
push_ c n;
()
(* Insert x->y in the cache, increasing its entry count *)
let insert_ c x y =
let rec n = {
key = x;
value = y;
next = n;
prev = n;
} in
H.add c.table x n;
push_ c n;
()
let get c x =
let n = H.find c.table x in
(* put n at the back of the queue *)
remove_ n;
push_ c n;
n.value
let set c x y =
let len = H.length c.table in
assert (len <= c.size);
if len = c.size
then replace_ c x y
else insert_ c x y
let size c () = H.length c.table
let iter c f =
H.iter (fun x node -> f x node.value) c.table
end
let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
let module L = LRU(struct
type t = a
let equal = eq
let hash = hash
end) in
let c = L.make size in
{ get=(fun x -> L.get c x);
set=(fun x y -> L.set c x y);
clear=(fun () -> L.clear c);
size=L.size c;
iter=L.iter c;
}
module UNBOUNDED(X:HASH) = struct
module H = Hashtbl.Make(X)
let make size =
assert (size > 0);
H.create size
let clear c = H.clear c
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
end
let unbounded (type a) ?(eq=default_eq_) ?(hash=default_hash_) size =
let module C = UNBOUNDED(struct
type t = a
let equal = eq
let hash = hash
end) in
let c = C.make size in
{ get=(fun x -> C.get c x);
set=(fun x y -> C.set c x y);
clear=(fun () -> C.clear c);
iter=C.iter c;
size=C.size c;
}

111
core/CCCache.mli Normal file
View file

@ -0,0 +1,111 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Caches}
Particularly useful for memoization. See {!with_cache} and {!with_cache_rec}
for more details.
@since 0.6 *)
type 'a equal = 'a -> 'a -> bool
type 'a hash = 'a -> int
(** {2 Value interface}
Typical use case: one wants to memoize a function [f : 'a -> 'b]. Code sample:
{[
let f x =
print_endline "call f";
x + 1;;
let f' = with_cache (lru 256) f;;
f' 0;; (* prints *)
f' 1;; (* prints *)
f' 0;; (* doesn't print, returns cached value *)
]}
@since 0.6 *)
type ('a, 'b) t
val clear : (_,_) t -> unit
(** Clear the content of the cache *)
val with_cache : ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b
(** [with_cache c f] behaves like [f], but caches calls to [f] in the
cache [c]. It always returns the same value as
[f x], if [f x] returns, or raise the same exception.
However, [f] may not be called if [x] is in the cache. *)
val with_cache_rec : ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b
(** [with_cache_rec c f] is a function that first, applies [f] to
some [f' = fix f], such that recursive calls to [f'] are cached in [c].
It is similar to {!with_cache} but with a function that takes as
first argument its own recursive version.
Examples (memoized Fibonacci function):
{[
let fib = with_cache_rec (lru 256)
(fun fib' n -> match n with
| 1 | 2 -> 1
| _ -> fib' (n-1) + fib' (n-2)
);;
fib 70;;
]}
*)
val size : (_,_) t -> int
(** Size of the cache (number of entries). At most linear in the number
of entries. *)
val iter : ('a,'b) t -> ('a -> 'b -> unit) -> unit
(** Iterate on cached values. Should yield [size cache] pairs. *)
val dummy : ('a,'b) t
(** dummy cache, never stores any value *)
val linear : ?eq:'a equal -> int -> ('a, 'b) t
(** Linear cache with the given size. It stores key/value pairs in
an array and does linear search at every call, so it should only be used
with small size.
@param eq optional equality predicate for keys *)
val replacing : ?eq:'a equal -> ?hash:'a hash ->
int -> ('a,'b) t
(** Replacing cache of the given size. Equality and hash functions can be
parametrized. It's a hash table that handles collisions by replacing
the old value with the new (so a cache entry is evicted when another
entry with the same hash (modulo size) is added).
Never grows wider than the given size. *)
val lru : ?eq:'a equal -> ?hash:'a hash ->
int -> ('a,'b) t
(** LRU cache of the given size ("Least Recently Used": keys that have not been
used recently are deleted first). Never grows wider than the given size. *)
val unbounded : ?eq:'a equal -> ?hash:'a hash ->
int -> ('a,'b) t
(** Unbounded cache, backed by a Hash table. Will grow forever
unless {!clear} is called manually. *)

2
core/CCError.mli
View file

@ -62,7 +62,7 @@ val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t
(** Map on error.
@since 0.5 *)
val map2 : ('a -> 'b) -> ('err -> 'err) -> ('a, 'err) t -> ('b, 'err) t
val map2 : ('a -> 'b) -> ('err1 -> 'err2) -> ('a, 'err1) t -> ('b, 'err2) t
(** Same as {!map}, but also with a function that can transform
the error message in case of failure *)

2
core/CCFun.cppo.ml
View file

@ -40,6 +40,8 @@ let (@@) f x = f x
let compose f g x = g (f x)
let compose_binop f g x y = g (f x) (f y)
let flip f x y = f y x
let curry f x y = f (x,y)

12
core/CCFun.mli
View file

@ -32,6 +32,12 @@ val (|>) : 'a -> ('a -> 'b) -> 'b
val compose : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
(** Composition *)
val compose_binop : ('a -> 'b) -> ('b -> 'b -> 'c) -> 'a -> 'a -> 'c
(** [compose_binop f g] is [fun x y -> g (f x) (f y)]
Example (partial order):
[List.sort (compose_binop fst CCInt.compare) [1, true; 2, false; 1, false]]
@since 0.6*)
val (%>) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
(** Alias to [compose] *)
@ -68,9 +74,9 @@ val lexicographic : ('a -> 'a -> int) -> ('a -> 'a -> int) -> 'a -> 'a -> int
(** Lexicographic combination of comparison functions *)
val finally : h:(unit -> unit) -> f:(unit -> 'a) -> 'a
(** [finally h f] calls [f ()] and returns its result. If it raises, the
same exception is raised; in {b any} case, [h ()] is called after
[f ()] terminates. *)
(** [finally h f] calls [f ()] and returns its result. If it raises, the
same exception is raised; in {b any} case, [h ()] is called after
[f ()] terminates. *)
(** {2 Monad}

570
core/CCIO.ml
View file

@ -24,432 +24,126 @@ 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 IO Monad} *)
(** {1 IO Utils} *)
type _ t =
| Return : 'a -> 'a t
| Fail : string -> 'a t
| Map : ('a -> 'b) * 'a t -> 'b t
| Bind : ('a -> 'b t) * 'a t -> 'b t
| WithGuard: unit t * 'a t -> 'a t (* run guard in any case *)
| Star : ('a -> 'b) t * 'a t -> 'b t
| Repeat : int * 'a t -> 'a list t
| RepeatIgnore : int * 'a t -> unit t
| Wrap : (unit -> 'a) -> 'a t
| SequenceMap : ('a -> 'b t) * 'a list -> 'b list t
type 'a gen = unit -> 'a option (** See {!CCGen} *)
type 'a io = 'a t
type 'a with_finalizer = ('a t * unit t) t
type 'a or_error = [ `Ok of 'a | `Error of string ]
let (>>=) x f = Bind(f,x)
let bind ?finalize f a = match finalize with
| None -> Bind(f,a)
| Some b -> WithGuard (b, Bind (f,a))
let map f x = Map(f, x)
let (>|=) x f = Map(f, x)
let return x = Return x
let pure = return
let fail msg = Fail msg
let (<*>) f a = Star (f, a)
let lift = map
let lift2 f a b =
a >>= fun x -> map (f x) b
let lift3 f a b c =
a >>= fun x ->
b >>= fun y -> map (f x y) c
let sequence_map f l =
SequenceMap (f,l)
let sequence l =
let _id x = x in
SequenceMap(_id, l)
let repeat i a =
if i <= 0 then Return [] else Repeat (i,a)
let repeat' i a =
if i <= 0 then Return () else RepeatIgnore (i,a)
(** {2 Finalizers} *)
let (>>>=) a f =
a >>= function
| x, finalizer -> WithGuard (finalizer, x >>= f)
(** {2 Running} *)
exception IOFailure of string
let rec _run : type a. a t -> a = function
| Return x -> x
| Fail msg -> raise (IOFailure msg)
| Map (f, a) -> f (_run a)
| Bind (f, a) -> _run (f (_run a))
| WithGuard (g, a) ->
begin try
let res = _run a in
_run g;
res
with e ->
_run g;
raise e
end
| Star (f, a) -> _run f (_run a)
| Repeat (i,a) -> _repeat [] i a
| RepeatIgnore (i,a) -> _repeat_ignore i a
| Wrap f -> f()
| SequenceMap (f, l) -> _sequence_map f l []
and _repeat : type a. a list -> int -> a t -> a list
= fun acc i a -> match i with
| 0 -> List.rev acc
| _ ->
let x = _run a in
_repeat (x::acc) (i-1) a
and _repeat_ignore : type a. int -> a t -> unit
= fun i a -> match i with
| 0 -> ()
| _ ->
let _ = _run a in
_repeat_ignore (i-1) a
and _sequence_map : type a b. (a -> b t) -> a list -> b list -> b list
= fun f l acc -> match l with
| [] -> List.rev acc
| a::tail ->
let x = _run (f a) in
_sequence_map f tail (x::acc)
let _printers =
ref [
(* default printer *)
( function IOFailure msg
| Sys_error msg -> Some msg
| Exit -> Some "exit"
| _ -> None
)
]
exception PrinterResult of string
let _print_exn e =
let with_in ?(mode=0o644) ?(flags=[]) filename f =
let ic = open_in_gen flags mode filename in
try
List.iter
(fun p -> match p e with
| None -> ()
| Some msg -> raise (PrinterResult msg)
) !_printers;
Printexc.to_string e
with PrinterResult s -> s
let x = f ic in
close_in ic;
x
with e ->
close_in ic;
raise e
let run x =
try `Ok (_run x)
with e -> `Error (_print_exn e)
let read_chunks ?(size=256) ic =
let buf = Buffer.create size in
let eof = ref false in
let next() =
if !eof then None
else try
Buffer.add_channel buf ic size;
let s = Buffer.contents buf in
Buffer.clear buf;
Some s
with End_of_file ->
let s = Buffer.contents buf in
eof := true;
if s="" then None else Some s
in
next
exception IO_error of string
let run_exn x =
try _run x
with e -> raise (IO_error (_print_exn e))
let register_printer p = _printers := p :: !_printers
(** {2 Standard Wrappers} *)
let _open_in mode flags filename () =
open_in_gen flags mode filename
let _close_in ic () = close_in ic
let with_in ?(mode=0o644) ?(flags=[]) filename =
Wrap (_open_in mode flags filename)
>>= fun ic ->
Return (Return ic, Wrap (_close_in ic))
let _read ic s i len () = input ic s i len
let read ic s i len = Wrap (_read ic s i len)
let _read_line ic () =
try Some (Pervasives.input_line ic)
let read_line ic =
try Some (input_line ic)
with End_of_file -> None
let read_line ic = Wrap(_read_line ic)
let rec _read_lines ic acc =
read_line ic
>>= function
| None -> return (List.rev acc)
| Some l -> _read_lines ic (l::acc)
let read_lines ic =
let stop = ref false in
fun () ->
if !stop then None
else try Some (input_line ic)
with End_of_file -> (stop:=true; None)
let read_lines ic = _read_lines ic []
let read_lines_l ic =
let l = ref [] in
try
while true do
l := input_line ic :: !l
done;
assert false
with End_of_file ->
List.rev !l
let _read_all ic () =
let buf = Buffer.create 128 in
let read_all ic =
let buf = Buffer.create 256 in
try
while true do
Buffer.add_channel buf ic 1024
done;
"" (* never returned *)
with End_of_file -> Buffer.contents buf
assert false (* never reached*)
with End_of_file ->
Buffer.contents buf
let read_all ic = Wrap(_read_all ic)
let with_out ?(mode=0o644) ?(flags=[]) filename f =
let oc = open_out_gen flags mode filename in
try
let x = f oc in
close_out oc;
x
with e ->
close_out oc;
raise e
let _open_out mode flags filename () =
open_out_gen flags mode filename
let _close_out oc () = close_out oc
let with_out_a ?mode ?(flags=[]) filename f =
with_out ?mode ~flags:(Open_creat::Open_append::flags) filename f
let with_out ?(mode=0o644) ?(flags=[]) filename =
Wrap(_open_out mode (Open_wronly::flags) filename)
>>= fun oc ->
Return(Return oc, Wrap(_close_out oc))
let with_out_a ?mode ?(flags=[]) filename =
with_out ?mode ~flags:(Open_creat::Open_append::flags) filename
let _write oc s i len () = output oc s i len
let write oc s i len = Wrap (_write oc s i len)
let _write_str oc s () = output oc s 0 (String.length s)
let write_str oc s = Wrap (_write_str oc s)
let _write_line oc l () =
output_string oc l;
let write_line oc s =
output_string oc s;
output_char oc '\n'
let write_line oc l = Wrap (_write_line oc l)
let _write_buf oc buf () = Buffer.output_buffer oc buf
let write_buf oc buf = Wrap (_write_buf oc buf)
let write_gen ?(sep="") oc g =
let rec recurse () = match g() with
| None -> ()
| Some s ->
output_string oc sep;
output_string oc s;
recurse ()
in match g() with
| None -> ()
| Some s ->
output_string oc s;
recurse ()
let flush oc = Wrap (fun () -> Pervasives.flush oc)
let rec write_lines oc g = match g () with
| None -> ()
| Some l ->
write_line oc l;
write_lines oc g
(** {2 Seq} *)
let write_lines_l oc l =
List.iter (write_line oc) l
module Seq = struct
type 'a step_result =
| Yield of 'a
| Stop
let tee funs g () = match g() with
| None -> None
| Some x as res ->
List.iter
(fun f ->
try f x
with _ -> ()
) funs;
res
type 'a gen = unit -> 'a step_result io
(* TODO: lines/unlines: string gen -> string gen *)
type 'a t = 'a gen
let _stop () = return Stop
let _yield x = return (Yield x)
let map_pure f gen () =
gen() >>= function
| Stop -> _stop ()
| Yield x -> _yield (f x)
let map f g () =
g() >>= function
| Stop -> _stop ()
| Yield x -> f x >>= _yield
let rec filter_map f g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
match f x with
| None -> filter_map f g()
| Some y -> _yield y
let rec filter f g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
if f x then _yield x else filter f g()
let rec flat_map f g () =
g() >>= function
| Stop -> _stop ()
| Yield x ->
f x >>= fun g' -> _flat_map_aux f g g' ()
and _flat_map_aux f g g' () =
g'() >>= function
| Stop -> flat_map f g ()
| Yield x -> _yield x
let general_iter f acc g =
let acc = ref acc in
let rec _next () =
g() >>= function
| Stop -> _stop()
| Yield x ->
f !acc x >>= function
| `Stop -> _stop()
| `Continue (acc', ret) ->
acc := acc';
match ret with
| None -> _next()
| Some y -> _yield y
in
_next
let take n seq =
general_iter
(fun n x -> if n<=0
then return `Stop
else return (`Continue (n-1, Some x))
) n seq
let drop n seq =
general_iter
(fun n x -> if n<=0
then return (`Continue (n, Some x))
else return (`Continue (n-1, None))
) n seq
let take_while p seq =
general_iter
(fun () x ->
p x >|= function
| true -> `Continue ((), Some x)
| false -> `Stop
) () seq
let drop_while p seq =
general_iter
(fun dropping x ->
if dropping
then p x >|= function
| true -> `Continue (true, None)
| false -> `Continue (false, Some x)
else return (`Continue (false, Some x))
) true seq
(* apply all actions from [l] to [x] *)
let rec _apply_all_to x l = match l with
| [] -> return ()
| f::tail -> f x >>= fun () -> _apply_all_to x tail
let _tee funs g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
_apply_all_to x funs >>= fun () ->
_yield x
let tee funs g = match funs with
| [] -> g
| _::_ -> _tee funs g
(** {6 Consume} *)
let rec fold_pure f acc g =
g() >>= function
| Stop -> return acc
| Yield x -> fold_pure f (f acc x) g
let length g = fold_pure (fun acc _ -> acc+1) 0 g
let rec fold f acc g =
g() >>= function
| Stop -> return acc
| Yield x ->
f acc x >>= fun acc' -> fold f acc' g
let rec iter f g =
g() >>= function
| Stop -> return ()
| Yield x -> f x >>= fun _ -> iter f g
let of_fun g = g
let empty () = _stop()
let singleton x =
let first = ref true in
fun () ->
if !first then (first := false; _yield x) else _stop()
let cons x g =
let first = ref true in
fun () ->
if !first then (first := false; _yield x) else g()
let of_list l =
let l = ref l in
fun () -> match !l with
| [] -> _stop()
| x::tail -> l:= tail; _yield x
let of_array a =
let i = ref 0 in
fun () ->
if !i = Array.length a
then _stop()
else (
let x = a.(!i) in
incr i;
_yield x
)
(* TODO: wrapper around with_in? using bind ~finalize:... ? *)
let chunks ~size ic =
let buf = Buffer.create size in
let eof = ref false in
let next() =
if !eof then _stop()
else try
Buffer.add_channel buf ic size;
let s = Buffer.contents buf in
Buffer.clear buf;
_yield s
with End_of_file ->
let s = Buffer.contents buf in
eof := true;
if s="" then _stop() else _yield s
in
next
let lines ic () =
try _yield (input_line ic)
with End_of_file -> _stop()
let words _g =
failwith "words: not implemented yet"
(* TODO: state machine that goes:
- 0: read input chunk
- switch to "search for ' '", and yield word
- goto 0 if no ' ' found
- yield leftover when g returns Stop
let buf = Buffer.create 32 in
let next() =
g() >>= function
| Stop -> _stop
| Yield s ->
Buffer.add_string buf s;
search_
in
next
*)
let output ?sep oc seq =
let first = ref true in
iter
(fun s ->
(* print separator *)
( if !first
then (first:=false; return ())
else match sep with
| None -> return ()
| Some sep -> write_str oc sep
) >>= fun () ->
write_str oc s
) seq
>>= fun () -> flush oc
end
(** {6 File and file names} *)
(* TODO: words: string gen -> string gen,
with a state machine that goes:
- 0: read input chunk
- switch to "search for ' '", and yield word
- goto 0 if no ' ' found
- yield leftover when g returns Stop
*)
module File = struct
type t = string
@ -461,59 +155,53 @@ module File = struct
then Filename.concat (Sys.getcwd()) f
else f
let exists f = Wrap (fun () -> Sys.file_exists f)
let exists f = Sys.file_exists f
let is_directory f = Wrap (fun () -> Sys.is_directory f)
let is_directory f = Sys.is_directory f
let remove f = Wrap (fun () -> Sys.remove f)
let remove f = Sys.remove f
let _read_dir d () =
let read_dir_base d =
if Sys.is_directory d
then
let arr = Sys.readdir d in
Seq.map_pure make (Seq.of_array arr)
else Seq.empty
CCGen.of_array arr
else CCGen.empty
let rec _walk d () =
let cons_ x tl =
let first=ref true in
fun () ->
if !first then (
first := false;
Some x
) else tl ()
let rec walk d =
if Sys.is_directory d
then
let arr = Sys.readdir d in
let tail = Seq.of_array arr in
let tail = Seq.flat_map
(fun s -> return (_walk (Filename.concat d s) ()))
let tail = CCGen.of_array arr in
let tail = CCGen.flat_map
(fun s -> walk (Filename.concat d s))
tail
in Seq.cons (`Dir,d) tail
else Seq.singleton (`File, d)
in cons_ (`Dir,d) tail
else CCGen.singleton (`File, d)
let walk t = Wrap (_walk t)
type walk_item = [`File | `Dir] * t
let read_dir ?(recurse=false) d =
if recurse
then walk d
>|= Seq.filter_map
(function
| `File, f -> Some f
| `Dir, _ -> None
)
else Wrap (_read_dir d)
let rec _read_dir_rec d () =
if Sys.is_directory d
then
let arr = Sys.readdir d in
let arr = Seq.of_array arr in
let arr = Seq.map_pure (fun s -> Filename.concat d s) arr in
Seq.flat_map
(fun s ->
if Sys.is_directory s
then return (_read_dir_rec s ())
else return (Seq.singleton s)
) arr
else Seq.empty
end
CCGen.filter_map
(function
| `File, f -> Some f
| `Dir, _ -> None
) (walk d)
else read_dir_base d
(** {2 Raw} *)
module Raw = struct
let wrap f = Wrap f
let show_walk_item (i,f) =
(match i with
| `File -> "file:"
| `Dir -> "dir: "
) ^ f
end

292
core/CCIO.mli
View file

@ -24,267 +24,110 @@ 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 IO Monad}
(** {1 IO Utils}
A simple abstraction over blocking IO, with strict evaluation. This is in
no way an alternative to Lwt/Async if you need concurrency.
Simple utilities to deal with basic Input/Output tasks in a resource-safe
way. For advanced IO tasks, the user is advised to use something
like Lwt or Async, that are far more comprehensive.
This module depends on {!CCGen}.
@since 0.3.3
*)
@since 0.6
{b NOTE} this was formerly a monadic IO module. The old module is now
in [containers.advanced] under the name [CCMonadIO].
(**
Examples:
- obtain the list of lines of a file:
{[
let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);;
# let l = CCIO.(with_in "/tmp/some_file" read_lines);;
]}
- transfer one file into another:
{[
# let a = CCIO.(
with_in "input" >>>= fun ic ->
with_out ~flags:[Open_creat] "output" >>>= fun oc ->
Seq.chunks 512 ic
|> Seq.output oc
# CCIO.(
with_in "/tmp/input"
(fun ic ->
with_out ~flags:[Open_creat] ~mode:0o644 "/tmp/output"
(fun oc ->
Seq.chunks 512 ic |> Seq.to_output oc
)
)
) ;;
# run a;;
]}
*)
type 'a t
type 'a io = 'a t
type 'a gen = unit -> 'a option (** See {!CCGen} *)
type 'a with_finalizer
(** A value of type ['a with_finalizer] is similar to a value ['a t] but
also contains a finalizer that must be run to cleanup.
See {!(>>>=)} to get rid of it. *)
type 'a or_error = [ `Ok of 'a | `Error of string ]
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** wait for the result of an action, then use a function to build a
new action and execute it *)
val return : 'a -> 'a t
(** Just return a value *)
val repeat : int -> 'a t -> 'a list t
(** Repeat an IO action as many times as required *)
val repeat' : int -> 'a t -> unit t
(** Same as {!repeat}, but ignores the result *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Map values *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val bind : ?finalize:(unit t) -> ('a -> 'b t) -> 'a t -> 'b t
(** [bind f a] runs the action [a] and applies [f] to its result
to obtain a new action. It then behaves exactly like this new
action.
@param finalize an optional action that is always run after evaluating
the whole action *)
val pure : 'a -> 'a t
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
val lift : ('a -> 'b) -> 'a t -> 'b t
(** Synonym to {!map} *)
val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
val sequence : 'a t list -> 'a list t
(** Runs operations one by one and gather their results *)
val sequence_map : ('a -> 'b t) -> 'a list -> 'b list t
(** Generalization of {!sequence} *)
val fail : string -> 'a t
(** [fail msg] fails with the given message. Running the IO value will
return an [`Error] variant *)
(** {2 Finalizers} *)
val (>>>=) : 'a with_finalizer -> ('a -> 'b t) -> 'b t
(** Alternative to {!(>>=)} that also takes a [unit t] value, that is a
finalizer. This action will run in any case (even failure).
Other than the finalizer, this behaves like {!(>>=)} *)
(** {2 Running} *)
val run : 'a t -> 'a or_error
(** Run an IO action.
@return either [`Ok x] when [x] is the successful result of the
computation, or some [`Error "message"] *)
exception IO_error of string
val run_exn : 'a t -> 'a
(** Unsafe version of {!run}. It assumes non-failure.
@raise IO_error if the execution didn't go well *)
val register_printer : (exn -> string option) -> unit
(** [register_printer p] register [p] as a possible failure printer.
If [run a] raises an exception [e], [p e] is evaluated. If [p e = Some msg]
then the error message will be [msg], otherwise other printers will
be tried *)
(** {2 Standard Wrappers} *)
(** {6 Input} *)
(** {2 Input} *)
val with_in : ?mode:int -> ?flags:open_flag list ->
string -> in_channel with_finalizer
(** Open an input file with the given optional flag list.
It yields a [in_channel] with a finalizer attached. See {!(>>>=)} to
use it. *)
string -> (in_channel -> 'a) -> 'a
(** Open an input file with the given optional flag list, calls the function
on the input channel. When the function raises or returns, the
channel is closed. *)
val read : in_channel -> string -> int -> int -> int t
(** Read a chunk into the given string *)
val read_chunks : ?size:int -> in_channel -> string gen
(** Read the channel's content into chunks of size [size] *)
val read_line : in_channel -> string option t
(** Read a line from the channel. Returns [None] if the input is terminated. *)
val read_line : in_channel -> string option
(** Read a line from the channel. Returns [None] if the input is terminated.
The "\n" is removed from the line. *)
val read_lines : in_channel -> string list t
(** Read all lines eagerly *)
val read_lines : in_channel -> string gen
(** Read all lines. The generator should be traversed only once. *)
val read_all : in_channel -> string t
val read_lines_l : in_channel -> string list
(** Read all lines into a list *)
val read_all : in_channel -> string
(** Read the whole channel into a buffer, then converted into a string *)
(** {6 Output} *)
val with_out : ?mode:int -> ?flags:open_flag list ->
string -> out_channel with_finalizer
string -> (out_channel -> 'a) -> 'a
(** Same as {!with_in} but for an output channel *)
val with_out_a : ?mode:int -> ?flags:open_flag list ->
string -> out_channel with_finalizer
string -> (out_channel -> 'a) -> 'a
(** Similar to {!with_out} but with the [Open_append] and [Open_creat]
flags activated *)
val write : out_channel -> string -> int -> int -> unit t
val write_line : out_channel -> string -> unit
(** Write the given string on the channel, followed by "\n" *)
val write_str : out_channel -> string -> unit t
val write_gen : ?sep:string -> out_channel -> string gen -> unit
(** Write the given strings on the output. If provided, add [sep] between
every two string (but not at the end) *)
val write_buf : out_channel -> Buffer.t -> unit t
val write_lines : out_channel -> string gen -> unit
(** Write every string on the output, followed by "\n". *)
val write_line : out_channel -> string -> unit t
val write_lines_l : out_channel -> string list -> unit
val flush : out_channel -> unit t
(** {2 Misc for Generators} *)
(* TODO: printf/fprintf wrappers *)
(** {2 Streams}
Iterators on chunks of bytes, or lines, or any other value using combinators.
Those iterators are usable only once, because their source might
be usable only once (think of a socket) *)
module Seq : sig
type 'a t
(** An IO stream of values of type 'a, consumable (iterable only once) *)
val map : ('a -> 'b io) -> 'a t -> 'b t
(** Map values with actions *)
val map_pure : ('a -> 'b) -> 'a t -> 'b t
(** Map values with a pure function *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter : ('a -> bool) -> 'a t -> 'a t
val flat_map : ('a -> 'b t io) -> 'a t -> 'b t
(** Map each value to a sub sequence of values *)
val take : int -> 'a t -> 'a t
val drop : int -> 'a t -> 'a t
val take_while : ('a -> bool io) -> 'a t -> 'a t
val drop_while : ('a -> bool io) -> 'a t -> 'a t
val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)] io) ->
'b -> 'a t -> 'c t
(** [general_iter f acc seq] performs a [filter_map] over [seq],
using [f]. [f] is given a state and the current value, and
can either return [`Stop] to indicate it stops traversing,
or [`Continue (st, c)] where [st] is the new state and
[c] an optional output value.
The result is the stream of values output by [f] *)
val tee : ('a -> unit io) list -> 'a t -> 'a t
(** [tee funs seq] behaves like [seq], but each element is given to
every function [f] in [funs]. This function [f] returns an action that
is eagerly executed. *)
(** {6 Consume} *)
val iter : ('a -> _ io) -> 'a t -> unit io
(** Iterate on the stream, with an action for each element *)
val length : _ t -> int io
(** Length of the stream *)
val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io
(** [fold f acc seq] folds over [seq], consuming it. Every call to [f]
has the right to return an IO value. *)
val fold_pure : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b io
(** [fold f acc seq] folds over [seq], consuming it. [f] is pure. *)
(** {6 Standard Wrappers} *)
type 'a step_result =
| Yield of 'a
| Stop
type 'a gen = unit -> 'a step_result io
val of_fun : 'a gen -> 'a t
(** Create a stream from a function that yields an element or stops *)
val empty : 'a t
val singleton : 'a -> 'a t
val cons : 'a -> 'a t -> 'a t
val of_list : 'a list -> 'a t
val of_array : 'a array -> 'a t
val chunks : size:int -> in_channel -> string t
(** Read the channel's content into chunks of size [size] *)
val lines : in_channel -> string t
(** Lines of an input channel *)
val words : string t -> string t
(** Split strings into words at " " boundaries.
{b NOT IMPLEMENTED} *)
val output : ?sep:string -> out_channel -> string t -> unit io
(** [output oc seq] outputs every value of [seq] into [oc], separated
with the optional argument [sep] (default: None).
It blocks until all values of [seq] are produced and written to [oc]. *)
end
val tee : ('a -> unit) list -> 'a gen -> 'a gen
(** [tee funs gen] behaves like [gen], but each element is given to
every function [f] in [funs] at the time the element is produced. *)
(** {6 File and file names}
How to list recursively files in a directory:
{[
CCIO.(
File.read_dir ~recurse:true (File.make "/tmp")
>>= Seq.output ~sep:"\n" stdout
) |> CCIO.run_exn ;;
]}
# let files = CCIO.File.read_dir ~recurse:true (CCIO.File.make "/tmp");;
# CCIO.write_lines stdout files;;
]}
See {!File.walk} if you also need to list directories.
See {!File.walk} if you also need to list directories:
{[
# let content = CCIO.File.walk (CCIO.File.make "/tmp");;
# CCGen.map CCIO.File.show_walk_item content |> CCIO.write_lines stdout;;
]}
*)
module File : sig
@ -296,28 +139,25 @@ module File : sig
val make : string -> t
(** Build a file representation from a path (absolute or relative) *)
val exists : t -> bool io
val exists : t -> bool
val is_directory : t -> bool io
val is_directory : t -> bool
val remove : t -> unit io
val remove : t -> unit
val read_dir : ?recurse:bool -> t -> t Seq.t io
val read_dir : ?recurse:bool -> t -> t gen
(** [read_dir d] returns a sequence of files and directory contained
in the directory [d] (or an empty stream if [d] is not a directory)
@param recurse if true (default [false]), sub-directories are also
explored *)
val walk : t -> ([`File | `Dir] * t) Seq.t io
type walk_item = [`File | `Dir] * t
val walk : t -> walk_item gen
(** similar to {!read_dir} (with [recurse=true]), this function walks
a directory recursively and yields either files or directories.
Is a file anything that doesn't satisfy {!is_directory} (including
symlinks, etc.) *)
end
(** {2 Low level access} *)
module Raw : sig
val wrap : (unit -> 'a) -> 'a t
(** [wrap f] is the IO action that, when executed, returns [f ()].
[f] should be callable as many times as required *)
val show_walk_item : walk_item -> string
end

120
core/CCList.ml
View file

@ -31,7 +31,7 @@ type 'a t = 'a list
let empty = []
(* max depth for direct recursion *)
let _direct_depth = 500
let direct_depth_default_ = 1000
let map f l =
let rec direct f i l = match l with
@ -43,7 +43,7 @@ let map f l =
and safe f l =
List.rev (List.rev_map f l)
in
direct f _direct_depth l
direct f direct_depth_default_ l
(*$Q
(Q.list Q.small_int) (fun l -> \
@ -53,6 +53,8 @@ let map f l =
let (>|=) l f = map f l
let direct_depth_append_ = 10_000
let append l1 l2 =
let rec direct i l1 l2 = match l1 with
| [] -> l2
@ -61,10 +63,21 @@ let append l1 l2 =
and safe l1 l2 =
List.rev_append (List.rev l1) l2
in
direct _direct_depth l1 l2
match l1 with
| [] -> l2
| [x] -> x::l2
| [x;y] -> x::y::l2
| _ -> direct direct_depth_append_ l1 l2
let (@) = append
(*$T
[1;2;3] @ [4;5;6] = [1;2;3;4;5;6]
(1-- 10_000) @ (10_001 -- 20_000) = 1 -- 20_000
*)
let direct_depth_filter_ = 10_000
let filter p l =
let rec direct i p l = match l with
| [] -> []
@ -76,7 +89,7 @@ let filter p l =
| x::l' when not (p x) -> safe p l' acc
| x::l' -> safe p l' (x::acc)
in
direct _direct_depth p l
direct direct_depth_filter_ p l
let fold_right f l acc =
let rec direct i f l acc = match l with
@ -91,7 +104,7 @@ let fold_right f l acc =
let acc = f x acc in
safe f l' acc
in
direct _direct_depth f l acc
direct direct_depth_default_ f l acc
(*$T
fold_right (+) (1 -- 1_000_000) 0 = \
@ -103,6 +116,21 @@ let fold_right f l acc =
l = fold_right (fun x y->x::y) l [])
*)
let init len f =
let rec init_rec acc i f =
if i=0 then f i :: acc
else init_rec (f i :: acc) (i-1) f
in
if len<0 then invalid_arg "init"
else if len=0 then []
else init_rec [] (len-1) f
(*$T
init 0 (fun _ -> 0) = []
init 1 (fun x->x) = [0]
init 1000 (fun x->x) = 0--999
*)
let rec compare f l1 l2 = match l1, l2 with
| [], [] -> 0
| _, [] -> 1
@ -116,25 +144,36 @@ let rec equal f l1 l2 = match l1, l2 with
| [], _ | _, [] -> false
| x1::l1', x2::l2' -> f x1 x2 && equal f l1' l2'
(* append difference lists *)
let _d_append f1 f2 =
fun l -> f1 (f2 l)
(*$T
equal CCInt.equal (1--1_000_000) (1--1_000_000)
*)
let flat_map f l =
let rec aux prefix f l = match l with
| [] -> prefix []
let rec aux f l kont = match l with
| [] -> kont []
| x::l' ->
let sublist = append (f x) in
let prefix = _d_append prefix sublist in
aux prefix f l'
let y = f x in
let kont' tail = match y with
| [] -> kont tail
| [x] -> kont (x :: tail)
| [x;y] -> kont (x::y::tail)
| l -> kont (append l tail)
in
aux f l' kont'
in
aux (fun l->l) f l
aux f l (fun l->l)
(*$T
flat_map (fun x -> [x+1; x*2]) [10;100] = [11;20;101;200]
List.length (flat_map (fun x->[x]) (1--300_000)) = 300_000
*)
let flatten l = flat_map (fun l -> l) l
let flatten l = fold_right append l []
(*$T
flatten [[1]; [2;3;4]; []; []; [5;6]] = 1--6
flatten (init 300_001 (fun x->[x])) = 0--300_000
*)
let product f l1 l2 =
flat_map (fun x -> map (fun y -> f x y) l2) l1
@ -210,12 +249,13 @@ let take n l =
| _ when n=0 -> List.rev acc
| x::l' -> safe (n-1) (x::acc) l'
in
direct _direct_depth n l
direct direct_depth_default_ n l
(*$T
take 2 [1;2;3;4;5] = [1;2]
take 10_000 (range 0 100_000) |> List.length = 10_000
take 10_000 (range 0 2_000) = range 0 2_000
take 300_000 (1 -- 400_000) = 1 -- 300_000
*)
let rec drop n l = match l with
@ -274,20 +314,38 @@ module Set = struct
(fun t -> mem ~eq t l2)
l1
let rec uniq ?(eq=(=)) l = match l with
| [] -> []
| x::xs when List.exists (eq x) xs -> uniq ~eq xs
| x::xs -> x :: uniq ~eq xs
let uniq ?(eq=(=)) l =
let rec uniq eq acc l = match l with
| [] -> List.rev acc
| x::xs when List.exists (eq x) xs -> uniq eq acc xs
| x::xs -> uniq eq (x::acc) xs
in uniq eq [] l
let rec union ?(eq=(=)) l1 l2 = match l1 with
| [] -> l2
| x::xs when mem ~eq x l2 -> union ~eq xs l2
| x::xs -> x::(union ~eq xs l2)
(*$T
Set.uniq [1;1;2;2;3;4;4;2;4;1;5] |> List.sort Pervasives.compare = [1;2;3;4;5]
*)
let rec inter ?(eq=(=)) l1 l2 = match l1 with
| [] -> []
| x::xs when mem ~eq x l2 -> x::(inter ~eq xs l2)
| _::xs -> inter ~eq xs l2
let union ?(eq=(=)) l1 l2 =
let rec union eq acc l1 l2 = match l1 with
| [] -> List.rev_append acc l2
| x::xs when mem ~eq x l2 -> union eq acc xs l2
| x::xs -> union eq (x::acc) xs l2
in union eq [] l1 l2
(*$T
Set.union [1;2;4] [2;3;4;5] = [1;2;3;4;5]
*)
let inter ?(eq=(=)) l1 l2 =
let rec inter eq acc l1 l2 = match l1 with
| [] -> List.rev acc
| x::xs when mem ~eq x l2 -> inter eq (x::acc) xs l2
| _::xs -> inter eq acc xs l2
in inter eq [] l1 l2
(*$T
Set.inter [1;2;4] [2;3;4;5] = [2;4]
*)
end
module Idx = struct
@ -591,7 +649,7 @@ type 'a formatter = Format.formatter -> 'a -> unit
type 'a random_gen = Random.State.t -> 'a
let random_len len g st =
map (fun _ -> g st) (range' 0 len)
init len (fun _ -> g st)
(*$T
random_len 10 CCInt.random_small (Random.State.make [||]) |> List.length = 10
@ -639,7 +697,7 @@ let of_gen g =
| None -> List.rev acc
| Some x -> safe (x::acc) g
in
direct _direct_depth g
direct direct_depth_default_ g
let to_klist l =
let rec make l () = match l with
@ -657,7 +715,7 @@ let of_klist l =
| `Nil -> List.rev acc
| `Cons (x,l') -> safe (x::acc) l'
in
direct _direct_depth l
direct direct_depth_default_ l
(** {2 IO} *)

4
core/CCList.mli
View file

@ -48,6 +48,10 @@ val filter : ('a -> bool) -> 'a t -> 'a t
val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** Safe version of [fold_right] *)
val init : int -> (int -> 'a) -> 'a t
(** Same as [Array.init]
@since 0.6 *)
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool

44
core/CCMultiSet.ml
View file

@ -45,6 +45,12 @@ module type S = sig
val remove : t -> elt -> t
val add_mult : t -> elt -> int -> t
val remove_mult : t -> elt -> int -> t
val update : t -> elt -> (int -> int) -> t
val min : t -> elt
val max : t -> elt
@ -102,12 +108,31 @@ module Make(O : Set.OrderedType) = struct
let n = count ms x in
M.add x (n+1) ms
let remove ms x =
let add_mult ms x n =
if n < 0 then invalid_arg "CCMultiSet.add_mult";
if n=0
then ms
else M.add x (count ms x + n) ms
let remove_mult ms x n =
if n < 0 then invalid_arg "CCMultiSet.remove_mult";
let cur_n = count ms x in
let new_n = cur_n - n in
if new_n <= 0
then M.remove x ms
else M.add x new_n ms
let remove ms x = remove_mult ms x 1
let update ms x f =
let n = count ms x in
match n with
| 0 -> ms
| 1 -> M.remove x ms
| _ -> M.add x (n-1) ms
match f n with
| 0 ->
if n=0 then ms else M.remove x ms
| n' ->
if n' < 0
then invalid_arg "CCMultiSet.udpate"
else M.add x n' ms
let min ms =
fst (M.min_binding ms)
@ -197,3 +222,12 @@ module Make(O : Set.OrderedType) = struct
seq (fun x -> m := add !m x);
!m
end
(*$T
let module S = CCMultiSet.Make(String) in \
S.count (S.add_mult S.empty "a" 5) "a" = 5
let module S = CCMultiSet.Make(String) in \
S.count (S.remove_mult (S.add_mult S.empty "a" 5) "a" 3) "a" = 2
let module S = CCMultiSet.Make(String) in \
S.count (S.remove_mult (S.add_mult S.empty "a" 4) "a" 6) "a" = 0
*)

17
core/CCMultiSet.mli
View file

@ -45,6 +45,23 @@ module type S = sig
val remove : t -> elt -> t
val add_mult : t -> elt -> int -> t
(** [add_mult set x n] adds [n] occurrences of [x] to [set]
@raise Invalid_argument if [n < 0]
@since 0.6 *)
val remove_mult : t -> elt -> int -> t
(** [remove_mult set x n] removes at most [n] occurrences of [x] from [set]
@raise Invalid_argument if [n < 0]
@since 0.6 *)
val update : t -> elt -> (int -> int) -> t
(** [update set x f] calls [f n] where [n] is the current multiplicity
of [x] in [set] ([0] to indicate its absence); the result of [f n]
is the new multiplicity of [x].
@raise Invalid_argument if [f n < 0]
@since 0.6 *)
val min : t -> elt
(** Minimal element w.r.t the total ordering on elements *)

85
core/CCVector.ml
View file

@ -92,36 +92,48 @@ let _resize v newcapacity =
()
(*$T
(let v = create_with ~capacity:10 1 in ensure v 200; capacity v >= 200)
let v = create_with ~capacity:10 1 in \
ensure v 200; capacity v >= 200
*)
(* grow the array, using [x] as a filler if required *)
let _grow v x =
if _empty_array v
then v.vec <- Array.make 32 x
else
else (
let n = Array.length v.vec in
let size = min (n + n/2 + 10) Sys.max_array_length in
let size = min (2 * n + 10) Sys.max_array_length in
if size = n then failwith "vec: can't grow any further";
_resize v size
)
(* resize so that capacity is at least size. Use a doubling-size
strategy so that calling many times [ensure] will
behave well *)
let ensure v size =
if Array.length v.vec = 0
then ()
else if v.size < size
then
let size' = min size Sys.max_array_length in
_resize v size'
else if size > Sys.max_array_length
then failwith "vec.ensure: size too big"
else (
let n = ref (max 16 (Array.length v.vec)) in
while !n < size do n := min Sys.max_array_length (2* !n) done;
_resize v !n
)
let clear v =
v.size <- 0
let is_empty v = v.size = 0
let push_unsafe v x =
Array.unsafe_set v.vec v.size x;
v.size <- v.size + 1
let push v x =
if v.size = Array.length v.vec
then _grow v x;
Array.unsafe_set v.vec v.size x;
v.size <- v.size + 1
push_unsafe v x
(** add all elements of b to a *)
let append a b =
@ -164,8 +176,10 @@ let append_seq a seq =
seq (fun x -> push a x)
let append_array a b =
ensure a (a.size + Array.length b);
Array.iter (push a) b
let len_b = Array.length b in
ensure a (a.size + len_b);
Array.blit b 0 a.vec a.size len_b;
a.size <- a.size + len_b
(*$T
let v1 = init 5 (fun i->i) and v2 = Array.init 5 (fun i->i+5) in \
@ -201,6 +215,19 @@ let pop v =
try Some (pop_exn v)
with Failure _ -> None
let top v =
if v.size = 0 then None else Some v.vec.(v.size-1)
let top_exn v =
if v.size = 0 then failwith "Vector.top";
v.vec.(v.size-1)
(*$T
1 -- 10 |> top = Some 10
create () |> top = None
1 -- 10 |> top_exn = 10
*)
let copy v = {
size = v.size;
vec = Array.sub v.vec 0 v.size;
@ -274,10 +301,7 @@ let map f v =
then create ()
else (
let vec = Array.init v.size (fun i -> f (Array.unsafe_get v.vec i)) in
{
size=v.size;
vec;
}
{ size=v.size; vec; }
)
(*$T
@ -286,17 +310,23 @@ let map f v =
*)
let filter' p v =
let i = ref (v.size - 1) in
while !i >= 0 do
if not (p v.vec.(! i))
(* remove i-th item! *)
then remove v !i;
decr i
done
let i = ref 0 in (* cur element *)
let j = ref 0 in (* cur insertion point *)
let n = v.size in
while !i < n do
if p v.vec.(! i) then (
(* move element i at the first empty slot.
invariant: i >= j*)
if !i > !j then v.vec.(!j) <- v.vec.(!i);
incr i;
incr j
) else incr i
done;
v.size <- !j
(*$T
let v = 1 -- 10 in filter' (fun x->x<4) v; \
to_list v |> List.sort Pervasives.compare = [1;2;3]
to_list v = [1;2;3]
*)
let filter p v =
@ -305,13 +335,14 @@ let filter p v =
else (
let v' = create_with ~capacity:v.size v.vec.(0) in
Array.iter
(fun x -> if p x then push v' x)
(fun x -> if p x then push_unsafe v' x)
v.vec;
v'
)
(*$T
filter (fun x-> x mod 2=0) (of_list [1;2;3;4;5]) |> to_list = [2;4]
filter (fun x-> x mod 2=0) (1 -- 1_000_000) |> length = 500_000
*)
let fold f acc v =
@ -463,9 +494,13 @@ let of_list l = match l with
| [] -> create()
| x::_ ->
let v = create_with ~capacity:(List.length l + 5) x in
List.iter (push v) l;
List.iter (push_unsafe v) l;
v
(*$T
of_list CCList.(1--300_000) |> to_list = CCList.(1--300_000)
*)
let to_array v =
Array.sub v.vec 0 v.size

12
core/CCVector.mli
View file

@ -99,6 +99,15 @@ val pop_exn : ('a, rw) t -> 'a
(** remove last element, or raise a Failure if empty
@raise Failure on an empty vector *)
val top : ('a, _) t -> 'a option
(** Top element, if present
@since 0.6 *)
val top_exn : ('a, _) t -> 'a
(** Top element, if present
@raise Failure on an empty vector
@since 0.6 *)
val copy : ('a,_) t -> ('a,'mut) t
(** Shallow copy (may give an immutable or mutable vector) *)
@ -134,8 +143,7 @@ val filter : ('a -> bool) -> ('a,_) t -> ('a, 'mut) t
returns a new vector that only contains elements of [v] satisfying [p]. *)
val filter' : ('a -> bool) -> ('a, rw) t -> unit
(** Filter elements in place. Does {b NOT} preserve the order
of the elements. *)
(** Filter elements in place. *)
val fold : ('b -> 'a -> 'b) -> 'b -> ('a,_) t -> 'b
(** fold on elements of the vector *)

18
core/META
View file

@ -1,6 +1,6 @@
# OASIS_START
# DO NOT EDIT (digest: f28449d1761e3b4dfea6c77b24996bbb)
version = "0.5"
# DO NOT EDIT (digest: 34ddfea96490dfa42580c0446eef8db6)
version = "0.6"
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.5"
version = "0.6"
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.5"
version = "0.6"
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 "pervasives" (
version = "0.5"
version = "0.6"
description = "A modular standard library focused on data structures."
requires = "containers"
archive(byte) = "containers_pervasives.cma"
@ -41,7 +41,7 @@ package "pervasives" (
)
package "misc" (
version = "0.5"
version = "0.6"
description = "A modular standard library focused on data structures."
requires = "unix containers"
archive(byte) = "containers_misc.cma"
@ -52,7 +52,7 @@ package "misc" (
)
package "lwt" (
version = "0.5"
version = "0.6"
description = "A modular standard library focused on data structures."
requires = "containers lwt lwt.unix containers.misc"
archive(byte) = "containers_lwt.cma"
@ -63,7 +63,7 @@ package "lwt" (
)
package "cgi" (
version = "0.5"
version = "0.6"
description = "A modular standard library focused on data structures."
requires = "containers CamlGI"
archive(byte) = "containers_cgi.cma"
@ -74,7 +74,7 @@ package "cgi" (
)
package "advanced" (
version = "0.5"
version = "0.6"
description = "A modular standard library focused on data structures."
requires = "containers"
archive(byte) = "containers_advanced.cma"

3
core/containers.mldylib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: ce5ac7ea3a03a61e3ed7dc10a551b94e)
# DO NOT EDIT (digest: 3c18f9fa7222954b0235c41f44fd620a)
CCVector
CCDeque
CCGen
@ -31,4 +31,5 @@ CCHashtbl
CCFlatHashtbl
CCSexp
CCMap
CCCache
# OASIS_STOP

3
core/containers.mllib
View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: ce5ac7ea3a03a61e3ed7dc10a551b94e)
# DO NOT EDIT (digest: 3c18f9fa7222954b0235c41f44fd620a)
CCVector
CCDeque
CCGen
@ -31,4 +31,5 @@ CCHashtbl
CCFlatHashtbl
CCSexp
CCMap
CCCache
# OASIS_STOP

3
lwt/containers_lwt.mlpack
View file

@ -1,5 +1,6 @@
# OASIS_START
# DO NOT EDIT (digest: 0baec9dfd3857e8cff12e40cdf9ce7db)
# DO NOT EDIT (digest: 0522ffe492b9796ab336d55b925afe68)
Behavior
Lwt_automaton
Lwt_actor
# OASIS_STOP

181
lwt/lwt_actor.ml Normal file
View file

@ -0,0 +1,181 @@
(*
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 Small Actor system for Lwt} *)
module ITbl = Hashtbl.Make(struct
type t = int
let equal (i:int) j = i=j
let hash i = i land max_int
end)
(** {2 Actors Basics} *)
let (>>=) = Lwt.(>>=)
type 'a t = {
mutable inbox : 'a Queue.t;
cond : unit Lwt_condition.t;
act : 'a t -> 'a -> unit Lwt.t;
setup : unit -> unit Lwt.t;
pid : int;
mutable links : any_actor list;
mutable monitors : monitor list;
mutable thread : unit Lwt.t option; (* running thread *)
}
(* invariant: thead=Some t means that t is running, and the
actor is alive *)
and any_actor =
| AnyActor : _ t -> any_actor
and monitor =
| Monitor : [> `Died of any_actor] t -> monitor
(* send message *)
let send m x =
Queue.push x m.inbox;
Lwt_condition.signal m.cond ();
Lwt.return_unit
(* [a] just died, now kill its friends *)
let propagate_dead a =
let traversed = ITbl.create 16 in
(* depth-first traversal of the clique of linked actors *)
let rec traverse stack = match stack with
| [] -> ()
| AnyActor a :: stack' when ITbl.mem traversed a.pid ->
traverse stack'
| (AnyActor a) as any_a :: stack' ->
ITbl.add traversed a.pid ();
begin match a.thread with
| None -> ()
| Some t ->
Lwt.cancel t;
a.thread <- None;
end;
(* notify monitors that [a] died *)
let monitors = a.monitors in
Lwt.async
(fun () ->
Lwt_list.iter_p
(function Monitor m -> send m (`Died any_a)
) monitors
);
(* follow links to other actors to kill *)
let stack' = List.rev_append a.links stack' in
traverse stack'
in
traverse [AnyActor a]
(* number of active actors *)
let num_active = ref 0
let on_num_active_0 = Lwt_condition.create()
let decr_num_active () =
decr num_active;
assert (!num_active >= 0);
if !num_active = 0 then Lwt_condition.broadcast on_num_active_0 ()
(* how to start an actor *)
let start_ a =
(* main loop of the actor *)
let rec loop () =
Lwt_condition.wait a.cond >>= fun () ->
let x = Queue.pop a.inbox in
a.act a x >>= fun () ->
loop ()
and exn_handler e =
Lwt_log.ign_info_f ~exn:e "error in thread %d" a.pid;
propagate_dead a;
Lwt.return_unit
in
match a.thread with
| Some _ -> failwith "start: actor already running";
| None ->
(* start the thread *)
let thread = Lwt.catch (fun () -> a.setup () >>= loop) exn_handler in
(* maintain [num_active] *)
incr num_active;
Lwt.on_termination thread decr_num_active;
a.thread <- Some thread;
()
let kill a = propagate_dead a
let no_setup_ () = Lwt.return_unit
let pid a = a.pid
let cur_pid = ref 0
let monitor m a =
a.monitors <- Monitor m :: a.monitors
let link a b =
if a.thread = None
then kill b
else if b.thread = None
then kill a;
a.links <- AnyActor b :: a.links;
b.links <- AnyActor a :: b.links;
()
let spawn ?(links=[]) ?(setup=no_setup_) act =
let pid = !cur_pid in
incr cur_pid;
let a = {
inbox=Queue.create ();
cond = Lwt_condition.create();
act;
setup;
pid;
links=[];
monitors=[];
thread=None;
} in
start_ a;
(* link now *)
List.iter (function AnyActor b -> link a b) links;
a
let cur_timeout_id = ref 0
let timeout a f =
if f <= 0. then invalid_arg "timeout";
let i = !cur_timeout_id in
incr cur_timeout_id;
let _ = Lwt_engine.on_timer f false
(fun _ -> Lwt.async (fun () -> send a (`Timeout i)))
in
i
(* wait until num_active=0 *)
let rec wait_all () =
if !num_active = 0
then Lwt.return_unit
else
Lwt_condition.wait on_num_active_0 >>= fun () ->
wait_all ()

75
lwt/lwt_actor.mli Normal file
View file

@ -0,0 +1,75 @@
(*
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 Small Actor system for Lwt}
Let's draw inspiration from Erlang. Just a tiny bit.
{b NOTE}: this module is not thread-safe at all.
*)
(** {2 Actors Basics} *)
type 'a t
(** An actor that can receive messages of type 'a. In practice, 'a will
often be a variant or a polymorphic variant. *)
type any_actor =
| AnyActor : _ t -> any_actor
val spawn : ?links:any_actor list ->
?setup:(unit -> unit Lwt.t) ->
('a t -> 'a -> unit Lwt.t) -> 'a t
(** Spawn a new actor with the given loop function. The function will
be called repeatedly with [(self, message)] where [self] is the actor
itself, and [msg] some incoming message..
@param setup function that is called when the actor (re)starts
@param links list of other actors that are linked to immediately *)
val send : 'a t -> 'a -> unit Lwt.t
(** Send a message to an actor's inbox *)
val pid : _ t -> int
(** Pid of an actor *)
val timeout : [> `Timeout of int ] t -> float -> int
(** [timeout a f] returns some unique integer ticket [i],
and, [f] seconds later, sends [`Timeout i] to [a] *)
val link : _ t -> _ t -> unit
(** [link a b] links the two actors together, so that if one dies, the
other dies too. The linking relationship is transitive and symmetric. *)
val kill : _ t -> unit
(** Kill the actor, and all its linked actors *)
val monitor : [> `Died of any_actor] t -> _ t -> unit
(** [monitor m a] adds [a] to the list of actors monitored by [m]. If [a]
dies for any reason, [m] is sent [`Died a] and can react consequently. *)
val wait_all : unit -> unit Lwt.t
(** Wait for all actors to finish. Typically used directly in {!Lwt_main.run} *)
(* TODO: some basic patterns: monitor strategies, pub/sub... *)

2
lwt/lwt_automaton.ml
View file

@ -26,6 +26,8 @@ of this software, even if advised of the possibility of such damage.
(** {1 interface lwt-automaton} *)
open Containers_misc
module I = struct
let send f i =
Lwt.on_success f (Automaton.I.send i)

2
lwt/lwt_automaton.mli
View file

@ -26,6 +26,8 @@ of this software, even if advised of the possibility of such damage.
(** {1 interface lwt-automaton} *)
open Containers_misc
module I : sig
val send : 'a Lwt.t -> 'a Automaton.I.t -> unit
(** Feed the content of the Lwt value into the automaton input, as soon as

380
misc/cache.ml
View file

@ -1,380 +0,0 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Memoization caches} *)
module type EQ = sig
type t
val equal : t -> t -> bool
end
module type HASH = sig
include EQ
val hash : t -> int
end
(** Signature of a cache for values *)
module type S = sig
type 'a t
type key
val create : int -> 'a t
(** Create a new cache of the given size. *)
val clear : 'a t -> unit
(** Clear content of the cache *)
val with_cache : 'a t -> (key -> 'a) -> key -> 'a
(** Wrap the function with the cache. This means that
[with_cache cache f x] always returns the same value as
[f x], if [f x] returns, or raise the same exception.
However, [f] may not be called if [x] is in the cache. *)
val with_cache_rec : 'a t -> ((key -> 'a) -> key -> 'a) -> key -> 'a
(** Partially apply the given function with a cached version of itself.
It returns the specialized function.
[with_cache_rec cache f] applies [f] to a cached version of [f],
called [f'], so that [f' x = f f' x]. *)
end
(** Signature of a cache for pairs of values *)
module type S2 = sig
type 'a t
type key1
type key2
val create : int -> 'a t
(** Create a new cache of the given size. *)
val clear : 'a t -> unit
(** Clear content of the cache *)
val with_cache : 'a t -> (key1 -> key2 -> 'a) -> key1 -> key2 -> 'a
(** Wrap the function with the cache *)
end
(** {2 Dummy cache (no caching) *)
module Dummy(X : sig type t end) = struct
type 'a t = unit
and key = X.t
let create size = ()
let clear () = ()
let with_cache () f x = f x
let with_cache_rec () f x =
let rec f' x = f f' x in
f' x
end
module Dummy2(X : sig type t end)(Y : sig type t end) = struct
type 'a t = unit
and key1 = X.t
and key2 = Y.t
let create size = ()
let clear () = ()
let with_cache () f x1 x2 = f x1 x2
end
(** {2 Small linear cache} *)
(** This cache stores (key,value) pairs in an array, that is traversed
linearily. It is therefore only reasonable for small sizes (like 5). *)
module Linear(X : EQ) = struct
type 'a t = 'a bucket array
and 'a bucket = Empty | Pair of key * 'a | PairRaise of key * exn
and key = X.t
let create size =
assert (size >= 1);
Array.make size Empty
let clear cache =
Array.fill cache 0 (Array.length cache) Empty
(** Insert the bucket [b] into the cache *)
let insert cache b =
let n = Array.length cache in
(* shift other values toward the end *)
Array.blit cache 0 cache 1 (n-1);
cache.(0) <- b
(** Try to find [f x] in the cache, otherwise compute it
and cache the result *)
let with_cache cache f x =
let n = Array.length cache in
let rec search i =
(* function that performs the lookup *)
if i = n then begin
(* cache miss *)
try
let y = f x in
insert cache (Pair (x, y));
y
with e ->
insert cache (PairRaise (x, e));
raise e
end else match cache.(i) with
| Pair (x',y) when X.equal x x' -> y
| PairRaise (x', e) when X.equal x x' -> raise e
| _ -> search (i+1)
in
search 0
let with_cache_rec cache f x =
(* make a recursive version of [f] that uses the cache *)
let rec f' x = with_cache cache (fun x -> f f' x) x in
f' x
end
module Linear2(X : EQ)(Y : EQ) = struct
type 'a t = 'a bucket array
and 'a bucket = Empty | Assoc of key1 * key2 * 'a | AssocRaise of key1 * key2 * exn
and key1 = X.t
and key2 = Y.t
let create size =
assert (size >= 1);
Array.make size Empty
let clear cache =
Array.fill cache 0 (Array.length cache) Empty
(** Insert the binding [b] into the cache *)
let insert cache b =
let n = Array.length cache in
(* shift other values toward the end *)
Array.blit cache 0 cache 1 (n-1);
cache.(0) <- b
(** Try to find [f x] in the cache, otherwise compute it
and cache the result *)
let with_cache cache f x1 x2 =
let n = Array.length cache in
let rec search i =
(* function that performs the lookup *)
if i = n then begin
(* cache miss *)
try
let y = f x1 x2 in
insert cache (Assoc (x1, x2, y));
y
with e ->
insert cache (AssocRaise (x1, x2, e));
raise e
end else match cache.(i) with
| Assoc (x1',x2',y) when X.equal x1 x1' && Y.equal x2 x2' -> y
| AssocRaise (x1',x2',e) when X.equal x1 x1' && Y.equal x2 x2' -> raise e
| _ -> search (i+1)
in
search 0
end
(** {2 An imperative cache of fixed size for memoization of pairs} *)
module Replacing(X : HASH) = struct
type key = X.t
(** A slot of the array contains a (key, value, true)
if key->value is stored there (at index hash(key) % length),
(null, null, false) otherwise.
The first slot in the array contains the function
used to produce the value upon a cache miss. *)
type 'a t = 'a bucket array
and 'a bucket = Empty | Assoc of key * 'a | AssocRaise of key * exn
let create size =
Array.make size Empty
let clear c =
Array.fill c 0 (Array.length c) Empty
(** Try to find [f x] in the cache, otherwise compute it
and cache the result *)
let with_cache c f x =
let i = (X.hash x) mod (Array.length c) in
match c.(i) with
| Assoc (x', y) when X.equal x x' ->
y (* cache hit *)
| AssocRaise (x', e) when X.equal x x' ->
raise e (* cache hit *)
| _ -> (* cache miss *)
try
let y = f x in
c.(i) <- Assoc (x, y);
y
with e ->
c.(i) <- AssocRaise (x, e);
raise e
let with_cache_rec cache f x =
(* make a recursive version of [f] that uses the cache *)
let rec f' x = with_cache cache (fun x -> f f' x) x in
f' x
end
module Replacing2(X : HASH)(Y : HASH) = struct
(** A slot of the array contains a (key, value, true)
if key->value is stored there (at index hash(key) % length),
(null, null, false) otherwise.
The first slot in the array contains the function
used to produce the value upon a cache miss. *)
type 'a t = 'a bucket array
and 'a bucket = Empty | Assoc of key1 * key2 * 'a | AssocRaise of key1 * key2 * exn
and key1 = X.t
and key2 = Y.t
let create size =
Array.make size Empty
let clear c =
Array.fill c 0 (Array.length c) Empty
let with_cache c f x1 x2 =
let i = (((X.hash x1 + 17) lxor Y.hash x2) mod Array.length c) in
match c.(i) with
| Assoc (x1', x2', y) when X.equal x1 x1' && Y.equal x2 x2' ->
y (* cache hit *)
| AssocRaise (x1', x2', e) when X.equal x1 x1' && Y.equal x2 x2' ->
raise e (* cache hit *)
| _ -> (* cache miss *)
try
let y = f x1 x2 in
c.(i) <- Assoc (x1, x2, y);
y
with e ->
c.(i) <- AssocRaise (x1, x2, e);
raise e
end
(** {2 Hashtables with Least Recently Used eviction policy *)
(* TODO: handle exceptions *)
module LRU(X : HASH) = struct
type key = X.t
module H = Hashtbl.Make(X)
type 'a t = {
table : 'a node H.t; (* hashtable key -> node *)
first : 'a node; (* dummy node for the entry of the list *)
mutable len : int; (* number of entries *)
size : int; (* max size *)
}
and 'a node = {
mutable key : key;
mutable value : 'a;
mutable next : 'a node;
mutable prev : 'a node;
} (** Meta data for the value *)
let create size =
let rec first =
{ key = Obj.magic 0; value = Obj.magic 0; next=first; prev=first; }
in
{ table = H.create size;
len = 0;
size;
first;
}
(** Clear the content of the cache *)
let clear c =
c.len <- 0;
H.clear c.table;
c.first.next <- c.first;
c.first.prev <- c.first;
()
(** Find an element, or raise Not_found *)
let find c x =
let n = H.find c.table x in
assert (X.equal n.key x);
n.value
(** Replace least recently used element of [c] by x->y *)
let replace c x y =
let n = c.first.next in
(* remove old element *)
H.remove c.table n.key;
(* insertion in hashtable *)
H.add c.table x n;
(* re-use the node for x,y *)
n.key <- x;
n.value <- y;
(* remove from front of queue *)
n.next.prev <- c.first;
c.first.next <- n.next;
(* insert at back of queue *)
let last = c.first.prev in
last.next <- n;
c.first.prev <- n;
n.next <- c.first;
n.prev <- last;
()
(** Insert x->y in the cache, increasing its entry count *)
let insert c x y =
c.len <- c.len + 1;
let n = {
key = x;
value = y;
next = c.first;
prev = c.first.prev;
} in
(* insertion in hashtable *)
H.add c.table x n;
(* insertion at back of queue *)
c.first.prev.next <- n;
c.first.prev <- n;
()
(** Try to find [f x] in the cache, otherwise compute it
and cache the result *)
let with_cache c f x =
try
find c x
with Not_found ->
let y = f x in
(if c.len = c.size
then replace c x y
else insert c x y);
y
let with_cache_rec cache f x =
(* make a recursive version of [f] that uses the cache *)
let rec f' x = with_cache cache (fun x -> f f' x) x in
f' x
end

107
misc/cache.mli
View file

@ -1,107 +0,0 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Memoization caches} *)
(** {2 Signatures} *)
module type EQ = sig
type t
val equal : t -> t -> bool
end
module type HASH = sig
include EQ
val hash : t -> int
end
(** Signature of a cache for values *)
module type S = sig
type 'a t
type key
val create : int -> 'a t
(** Create a new cache of the given size. *)
val clear : 'a t -> unit
(** Clear content of the cache *)
val with_cache : 'a t -> (key -> 'a) -> key -> 'a
(** Wrap the function with the cache. This means that
[with_cache cache f x] always returns the same value as
[f x], if [f x] returns, or raise the same exception.
However, [f] may not be called if [x] is in the cache. *)
val with_cache_rec : 'a t -> ((key -> 'a) -> key -> 'a) -> key -> 'a
(** Partially apply the given function with a cached version of itself.
It returns the specialized function.
[with_cache_rec cache f] applies [f] to a cached version of [f],
called [f'], so that [f' x = f f' x]. *)
end
(** Signature of a cache for pairs of values *)
module type S2 = sig
type 'a t
type key1
type key2
val create : int -> 'a t
(** Create a new cache of the given size. *)
val clear : 'a t -> unit
(** Clear content of the cache *)
val with_cache : 'a t -> (key1 -> key2 -> 'a) -> key1 -> key2 -> 'a
(** Wrap the function with the cache *)
end
(** {2 Dummy cache (no caching)} *)
module Dummy(X : sig type t end) : S with type key = X.t
module Dummy2(X : sig type t end)(Y : sig type t end) : S2 with type key1 = X.t and type key2 = Y.t
(** {2 Small linear cache} *)
(** This cache stores (key,value) pairs in an array, that is traversed
linearily. It is therefore only reasonable for small sizes (like 5). *)
module Linear(X : EQ) : S with type key = X.t
module Linear2(X : EQ)(Y : EQ) : S2 with type key1 = X.t and type key2 = Y.t
(** {2 Hashtables that resolve collisions by replacing} *)
module Replacing(X : HASH) : S with type key = X.t
module Replacing2(X : HASH)(Y : HASH) : S2 with type key1 = X.t and type key2 = Y.t
(** {2 Hashtables with Least Recently Used eviction policy} *)
module LRU(X : HASH) : S with type key = X.t
(* TODO exception handling in LRU *)
(* TODO LRU2 *)

4
misc/containers_misc.mlpack
View file

@ -1,6 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 77c9e2e3233437cee692be334bdaa224)
Cache
# DO NOT EDIT (digest: 5f2c8615af923cd3ff229b6d10c55bc8)
FHashtbl
FlatHashtbl
Hashset
@ -31,4 +30,5 @@ Ty
Cause
AVL
ParseReact
Mixtbl
# OASIS_STOP

103
misc/mixtbl.ml Normal file
View file

@ -0,0 +1,103 @@
(*
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);
}
type 'a t = ('a, unit -> unit) Hashtbl.t
let create n = Hashtbl.create n
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}
let get ~inj tbl x =
try inj.get (Hashtbl.find tbl x)
with Not_found -> None
let set ~inj tbl x y =
Hashtbl.replace tbl x (inj.set y)
let length tbl = Hashtbl.length tbl
let clear tbl = Hashtbl.clear tbl
let remove tbl x = Hashtbl.remove tbl x
let copy tbl = Hashtbl.copy tbl
let mem ~inj tbl x =
try
inj.get (Hashtbl.find tbl x) <> None
with Not_found -> false
let find ~inj tbl x =
match inj.get (Hashtbl.find tbl x) with
| None -> raise Not_found
| Some v -> v
let iter_keys tbl f =
Hashtbl.iter (fun x _ -> f x) tbl
let fold_keys tbl acc f =
Hashtbl.fold (fun x _ acc -> f acc x) tbl acc
(** {2 Iterators} *)
type 'a sequence = ('a -> unit) -> unit
let keys_seq tbl yield =
Hashtbl.iter
(fun x _ -> yield x)
tbl
let bindings_of ~inj tbl yield =
Hashtbl.iter
(fun k value ->
match inj.get value with
| None -> ()
| Some v -> yield (k, v)
) tbl
type value =
| Value : ('b injection -> 'b option) -> value
let bindings tbl yield =
Hashtbl.iter
(fun x y -> yield (x, Value (fun inj -> inj.get y)))
tbl

123
misc/mixtbl.mli Normal file
View file

@ -0,0 +1,123 @@
(*
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}
From https://github.com/mjambon/mixtbl , thanks to him.
Example:
{[
let inj_int = Mixtbl.access () ;;
let tbl = Mixtbl.create 10 ;;
OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a");;
Mixtbl.set inj_int tbl "a" 1;;
OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a");;
let inj_string = Mixtbl.access () ;;
Mixtbl.set inj_string tbl "b" "Hello";
OUnit.assert_equal (Some "Hello") (Mixtbl.get inj_string tbl "b");;
OUnit.assert_equal None (Mixtbl.get inj_string tbl "a");;
OUnit.assert_equal (Some 1) (Mixtbl.get inj_int tbl "a");;
Mixtbl.set inj_string tbl "a" "Bye";;
OUnit.assert_equal None (Mixtbl.get inj_int tbl "a");;
OUnit.assert_equal (Some "Bye") (Mixtbl.get inj_string tbl "a");;
]}
@since 0.6 *)
type 'a t
(** A hash table containing values of different types.
The type parameter ['a] represents the type of the keys. *)
type 'b injection
(** An accessor for values of type 'b in any table. Values put
in the table using an key can only be retrieved using this
very same key. *)
val create : int -> 'a t
(** [create n] creates a hash table of initial size [n]. *)
val create_inj : unit -> 'b 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 tables (although not in a thread-safe way). *)
val get : inj:'b injection -> 'a t -> 'a -> 'b option
(** Get the value corresponding to this key, if it exists and
belongs to the same key *)
val set : inj:'b injection -> 'a t -> 'a -> 'b -> unit
(** Bind the key to the value, using [inj] *)
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 *)
val length : 'a t -> int
(** Number of bindings *)
val clear : 'a t -> unit
(** Clear content of the hashtable *)
val remove : 'a t -> 'a -> unit
(** Remove the binding for this key *)
val copy : 'a t -> 'a t
(** Copy of the table *)
val mem : inj:_ injection-> 'a t -> 'a -> bool
(** Is the given key in the table, with the right type? *)
val iter_keys : 'a t -> ('a -> unit) -> unit
(** Iterate on the keys of this table *)
val fold_keys : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b
(** Fold over the keys *)
(** {2 Iterators} *)
type 'a sequence = ('a -> unit) -> unit
val keys_seq : 'a t -> 'a sequence
(** All the keys *)
val bindings_of : inj:'b injection -> 'a t -> ('a * 'b) sequence
(** All the bindings that come from the corresponding injection *)
type value =
| Value : ('b injection -> 'b option) -> value
val bindings : 'a t -> ('a * value) sequence
(** Iterate on all bindings *)

340
misc/ratTerm.ml
View file

@ -1,340 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Rational Terms} *)
module type SYMBOL = sig
type t
val compare : t -> t -> int
val to_string : t -> string
end
module type S = sig
module Symbol : SYMBOL
type t = private
| Var of int
| Ref of int
| App of Symbol.t * t list
type term = t
type 'a env = 'a RAL.t
(** Structural equality and comparisons. Two terms being different
for {!eq} may still be equal, but with distinct representations.
For instance [r:f(f(r))] and [r:f(r)] are the same term but they
are not equal structurally. *)
val eq : t -> t -> bool
val cmp : t -> t -> int
val eq_set : t -> t -> bool
(** Proper equality on terms. This returns [true] if the two terms represent
the same infinite tree, not only if they have the same shape. *)
val var : unit -> t
(** free variable, with a fresh name *)
val mk_ref : int -> t
(** Back-ref of [n] levels down (see De Bruijn indices) *)
val app : Symbol.t -> t list -> t
(** Application of a symbol to a list, possibly with a unique label *)
val const : Symbol.t -> t
(** Shortcut for [app s []] *)
val pp : Buffer.t -> t -> unit
val fmt : Format.formatter -> t -> unit
val to_string : t -> string
val rename : t -> t
(** Rename all variables and references to fresh ones *)
module Subst : sig
type t
val empty : t
val bind : t -> int -> term -> t
val deref : t -> term -> term
val apply : ?depth:int -> t -> term -> term
val pp : Buffer.t -> t -> unit
val fmt : Format.formatter -> t -> unit
val to_string : t -> string
end
val matching : ?subst:Subst.t -> term -> term -> Subst.t option
val unify : ?subst:Subst.t -> term -> term -> Subst.t option
end
module Make(Symbol : SYMBOL) = struct
module Symbol = Symbol
type t =
| Var of int
| Ref of int
| App of Symbol.t * t list
type term = t
module IMap = Map.Make(struct
type t = int
let compare i j = i-j
end)
module IHTbl = Hashtbl.Make(struct
type t = int
let equal i j = i=j
let hash i = i land max_int
end)
type 'a env = 'a RAL.t
(** Environment for De Bruijn variables: a random-access list. *)
let _to_int = function
| Var _ -> 1
| Ref _ -> 2
| App _ -> 3
let rec cmp t1 t2 = match t1, t2 with
| Var i1, Var i2 -> i1 - i2
| Ref i1, Ref i2 -> i1 - i2
| App (f1, l1), App (f2, l2) ->
let c = Symbol.compare f1 f2 in
if c <> 0 then c
else cmp_list l1 l2
| _ -> _to_int t1 - _to_int t2
and cmp_list l1 l2 = match l1, l2 with
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| t1::l1', t2::l2' ->
let c = cmp t1 t2 in
if c <> 0 then c else cmp_list l1' l2'
let eq t1 t2 = cmp t1 t2 = 0
module Set2T = Set.Make(struct
type t = term*term
let compare (l1,r1)(l2,r2) =
let c = cmp l1 l2 in
if c <> 0 then c else cmp r1 r2
end)
let eq_set t1 t2 =
let cycle = ref Set2T.empty in
let rec eq env t1 t2 = match t1, t2 with
| Ref i, _ -> eq env (RAL.get env i) t2
| _, Ref j -> eq env t1 (RAL.get env j)
| Var i, Var j -> i=j
| _ when Set2T.mem (t1,t2) !cycle -> true
| App(f1,l1), App(f2,l2) when Symbol.compare f1 f2 = 0 ->
(* if the subterms are equal, and we try to solve again t1=t2,
then we shouldn't cycle. Hence we protect ourself. *)
cycle := Set2T.add (t1, t2) !cycle;
let env = RAL.cons t1 env in
begin try
List.for_all2 (eq env) l1 l2
with Invalid_argument _ -> false
end
| _ -> false
in
eq RAL.empty t1 t2
let _count = ref 0
let var () =
let v = Var !_count in
incr _count;
v
let mk_ref i = Ref i
let app s l = App (s, l)
let const s = App (s, [])
let rec pp buf t = match t with
| Var i -> Printf.bprintf buf "X%d" i
| Ref i -> Printf.bprintf buf "*%d" i
| App (s, []) ->
Buffer.add_string buf (Symbol.to_string s)
| App (s, l) ->
Printf.bprintf buf "%s(%a)" (Symbol.to_string s) pp_list l
and pp_list buf l = match l with
| [] -> ()
| [x] -> pp buf x
| x::((_::_) as l') ->
pp buf x; Buffer.add_string buf ", "; pp_list buf l'
let to_string t =
let b = Buffer.create 16 in
pp b t;
Buffer.contents b
let fmt fmt t = Format.pp_print_string fmt (to_string t)
let rename t =
let names = IHTbl.create 16 in
let rec rename t = match t with
| Var i ->
begin try IHTbl.find names i
with Not_found ->
(* rename variable into a fresh one *)
let v = var() in
IHTbl.add names i v;
v
end
| Ref _ -> t (* no need to rename *)
| App (s, l) ->
app s (List.map rename l)
in rename t
module Subst = struct
type t = term IMap.t
let empty = IMap.empty
let bind s i t =
match t with
| _ when IMap.mem i s -> failwith "Subst.bind"
| Var j when i=j -> s (* id *)
| _ -> IMap.add i t s
let rec deref s t = match t with
| Var i ->
begin try deref s (IMap.find i s)
with Not_found -> t
end
| Ref _
| App _ -> t
(* does the variable [v] occur in [subst(t)]? *)
let rec _occur subst ~var t =
match deref subst t with
| Var _ -> eq var t
| Ref _
| App (_, []) -> false
| App (_, l) -> List.exists (_occur subst ~var) l
let apply ?(depth=0) subst t =
(* [depth]: current depth w.r.t root, [back]: map from var to
the depth of the term they are bound to *)
let rec apply depth back subst t = match t with
| Ref _ -> t
| Var i ->
let t' = deref subst t in
(* interesting case. Either [t] is bound to a term [t']
that contains it, which makes a cyclic term, or it's
not in which case it's easy. *)
begin match t' with
| Ref _ -> t
| App (s, l) ->
if _occur subst ~var:t t'
then
(* in any case we are possibly going to modify [r']
by replacing [x] by a backref. *)
let back = IMap.add i depth back in
let subst = IMap.remove i subst in
app s (List.map (apply (depth+1) back subst) l)
else
(* simply keep t'->s(l) *)
app s (List.map (apply (depth+1) back subst) l)
| Var j ->
assert (not (IMap.mem j subst));
begin try
let k = IMap.find j back in
(* the variable is actually bound to a superterm,
which is at depth [k]. The depth difference is
therefore [depth-k]. *)
Ref (depth-k)
with Not_found ->
t' (* truly unbound variable. *)
end
end
| App (s, l) ->
app s (List.map (apply (depth+1) back subst) l)
in apply depth IMap.empty subst t
let pp buf subst =
Buffer.add_string buf "{";
let first = ref true in
IMap.iter
(fun i t ->
if !first then first:= false else Buffer.add_string buf ", ";
Printf.bprintf buf "X%d → %a" i pp t)
subst;
Buffer.add_string buf "}";
()
let to_string t =
let b = Buffer.create 16 in
pp b t;
Buffer.contents b
let fmt fmt t = Format.pp_print_string fmt (to_string t)
end
exception Fail
let matching ?(subst=Subst.empty) t1 t2 =
assert false (* TODO (need to gather variables of [t2]... *)
let unify ?(subst=Subst.empty) t1 t2 =
(* pairs of terms already unified *)
let cycle = ref Set2T.empty in
(* [env] contains references to superterms *)
let rec unif env subst t1 t2 =
match Subst.deref subst t1, Subst.deref subst t2 with
| Ref i1, _ -> unif env subst (RAL.get env i1) t2
| _, Ref i2 -> unif env subst t1 (RAL.get env i2)
| Var i, Var j when i=j -> subst
| Var i, _ -> Subst.bind subst i t2
| _, Var j -> Subst.bind subst j t1
| t1, t2 when Set2T.mem (t1,t2) !cycle ->
subst (* t1,t2 already being unified, avoid cycling forever *)
| App (f1, l1) as t1, (App (f2, l2) as t2) ->
if Symbol.compare f1 f2 <> 0 then raise Fail;
(* remember we are unifying those terms *)
cycle := Set2T.add (t1, t2) !cycle;
(* now we can assume [t1 = t2] if unification succeeds, so
we just push [t1] into the env *)
let env = RAL.cons t1 env in
try
List.fold_left2 (unif env) subst l1 l2
with Invalid_argument _ -> raise Fail
in
try Some (unif RAL.empty subst t1 t2)
with Fail -> None
end
module Str = struct
type t = string
let compare = String.compare
let to_string s = s
end
module Default = Make(Str)

105
misc/ratTerm.mli
View file

@ -1,105 +0,0 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Rational Terms} *)
module type SYMBOL = sig
type t
val compare : t -> t -> int
val to_string : t -> string
end
module type S = sig
module Symbol : SYMBOL
type t = private
| Var of int
| Ref of int
| App of Symbol.t * t list
type term = t
type 'a env = 'a RAL.t
(** Structural equality and comparisons. Two terms being different
for {!eq} may still be equal, but with distinct representations.
For instance [r:f(f(r))] and [r:f(r)] are the same term but they
are not equal structurally. *)
val eq : t -> t -> bool
val cmp : t -> t -> int
val eq_set : t -> t -> bool
(** Proper equality on terms. This returns [true] if the two terms represent
the same infinite tree, not only if they have the same shape. *)
val var : unit -> t
(** free variable, with a fresh name *)
val mk_ref : int -> t
(** Back-ref of [n] levels down (see De Bruijn indices) *)
val app : Symbol.t -> t list -> t
(** Application of a symbol to a list, possibly with a unique label *)
val const : Symbol.t -> t
(** Shortcut for [app s []] *)
val pp : Buffer.t -> t -> unit
val fmt : Format.formatter -> t -> unit
val to_string : t -> string
val rename : t -> t
(** Rename all variables and references to fresh ones *)
module Subst : sig
type t
val empty : t
val bind : t -> int -> term -> t
val deref : t -> term -> term
val apply : ?depth:int -> t -> term -> term
val pp : Buffer.t -> t -> unit
val fmt : Format.formatter -> t -> unit
val to_string : t -> string
end
val matching : ?subst:Subst.t -> term -> term -> Subst.t option
val unify : ?subst:Subst.t -> term -> term -> Subst.t option
end
module Make(Sym : SYMBOL) : S with module Symbol = Sym
module Str : SYMBOL with type t = string
module Default : sig
include S with module Symbol = Str
(* TODO
val of_string : string -> t option
val of_string_exn : string -> t (** @raise Failure possibly *)
*)
end

32
opam Normal file
View file

@ -0,0 +1,32 @@
opam-version: "1.2"
author: "Simon Cruanes"
maintainer: "simon.cruanes@inria.fr"
build: [
["./configure" "--prefix" prefix "--disable-thread" "--disable-bench"
"--disable-tests" "--disable-cgi" "--%{lwt:enable}%-lwt"
"--enable-docs" "--enable-misc"]
[make "build"]
]
install: [
[make "install"]
]
build-doc: [ make "doc" ]
build-test: [ make "test" ]
remove: [
["ocamlfind" "remove" "containers"]
]
post-messages: [
"in containers, modules start with 'CC' (stands for 'core containers')"
]
depends: [
"ocamlfind" {build}
"base-bytes"
"cppo" {build}
]
depopts: [ "lwt" ]
tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ]
homepage: "https://github.com/c-cube/ocaml-containers/"
doc: "http://cedeela.fr/~simon/software/containers/"
available: [ocaml-version >= "4.00.0"]
dev-repo: "https://github.com/c-cube/ocaml-containers.git"
bug-reports: "https://github.com/c-cube/ocaml-containers/issues/"

126
setup.ml
View file

@ -1,7 +1,7 @@
(* setup.ml generated for the first time by OASIS v0.4.4 *)
(* OASIS_START *)
(* DO NOT EDIT (digest: b1a4974dee45e60fe6927115046bac0e) *)
(* DO NOT EDIT (digest: 4d75ed6ab1fc0101ea43731be9fc6381) *)
(*
Regenerated by OASIS v0.4.5
Visit http://oasis.forge.ocamlcore.org for more information and
@ -6903,7 +6903,7 @@ let setup_t =
alpha_features = [];
beta_features = [];
name = "containers";
version = "0.5";
version = "0.6";
license =
OASISLicense.DEP5License
(OASISLicense.DEP5Unit
@ -7073,7 +7073,8 @@ let setup_t =
"CCHashtbl";
"CCFlatHashtbl";
"CCSexp";
"CCMap"
"CCMap";
"CCCache"
];
lib_pack = false;
lib_internal_modules = [];
@ -7134,7 +7135,8 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{
lib_modules = ["CCLinq"; "CCBatch"; "CCCat"];
lib_modules =
["CCLinq"; "CCBatch"; "CCCat"; "CCMonadIO"];
lib_pack = true;
lib_internal_modules = [];
lib_findlib_parent = Some "containers";
@ -7200,7 +7202,6 @@ let setup_t =
{
lib_modules =
[
"Cache";
"FHashtbl";
"FlatHashtbl";
"Hashset";
@ -7230,7 +7231,8 @@ let setup_t =
"Ty";
"Cause";
"AVL";
"ParseReact"
"ParseReact";
"Mixtbl"
];
lib_pack = true;
lib_internal_modules = [];
@ -7321,7 +7323,7 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{
lib_modules = ["Behavior"; "Lwt_automaton"];
lib_modules = ["Behavior"; "Lwt_automaton"; "Lwt_actor"];
lib_pack = true;
lib_internal_modules = [];
lib_findlib_parent = Some "containers";
@ -7484,7 +7486,7 @@ let setup_t =
});
Executable
({
cs_name = "benchs";
cs_name = "run_benchs";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
@ -7492,7 +7494,10 @@ let setup_t =
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "bench", true)
(OASISExpr.EAnd
(OASISExpr.EFlag "bench",
OASISExpr.EFlag "misc"),
true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "benchs/";
@ -7500,40 +7505,9 @@ let setup_t =
bs_build_depends =
[
InternalLibrary "containers";
InternalLibrary "containers_string";
InternalLibrary "containers_misc";
FindlibPackage ("bench", None);
InternalLibrary "containers_advanced"
];
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 = "benchs.ml"});
Executable
({
cs_name = "bench_conv";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "bench", true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "benchs/";
bs_compiled_object = Native;
bs_build_depends =
[
InternalLibrary "containers";
InternalLibrary "containers_advanced";
InternalLibrary "containers_string";
FindlibPackage ("benchmark", None)
];
bs_build_tools = [ExternalTool "ocamlbuild"];
@ -7546,38 +7520,7 @@ let setup_t =
bs_byteopt = [(OASISExpr.EBool true, [])];
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{exec_custom = false; exec_main_is = "bench_conv.ml"});
Executable
({
cs_name = "bench_batch";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "bench", true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "benchs/";
bs_compiled_object = Native;
bs_build_depends =
[
InternalLibrary "containers";
FindlibPackage ("benchmark", 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 = "bench_batch.ml"});
{exec_custom = false; exec_main_is = "run_benchs.ml"});
Executable
({
cs_name = "bench_hash";
@ -7612,6 +7555,37 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{exec_custom = false; exec_main_is = "bench_hash.ml"});
Executable
({
cs_name = "bench_conv";
cs_data = PropList.Data.create ();
cs_plugin_data = []
},
{
bs_build =
[
(OASISExpr.EBool true, false);
(OASISExpr.EFlag "bench", true)
];
bs_install = [(OASISExpr.EBool true, false)];
bs_path = "benchs/";
bs_compiled_object = Native;
bs_build_depends =
[
InternalLibrary "containers";
FindlibPackage ("benchmark", 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 = "bench_conv.ml"});
Executable
({
cs_name = "test_levenshtein";
@ -7940,7 +7914,7 @@ let setup_t =
};
oasis_fn = Some "_oasis";
oasis_version = "0.4.5";
oasis_digest = Some "\189t\006\169y\003\204\136vd\245\216.\188J\140";
oasis_digest = Some "\151b\2136\171\237[\223\221\025\166\157\127)\016-";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false
@ -7948,6 +7922,6 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
# 7952 "setup.ml"
# 7926 "setup.ml"
(* OASIS_STOP *)
let () = setup ();;

5
tests/quick/.common.ml
View file

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

33
tests/quick/actors.ml Executable file
View file

@ -0,0 +1,33 @@
#!/usr/bin/env ocaml
#use "tests/quick/.common.ml";;
#load "containers.cma";;
#require "lwt.unix";;
#load "containers_misc.cma";;
#load "containers_lwt.cma";;
let (>>=) = Lwt.(>>=)
module A = Containers_lwt.Lwt_actor
let a = A.spawn
(fun _ (`Ping sender) ->
Lwt_io.printl "ping!" >>= fun () ->
Lwt_unix.sleep 1. >>= fun () ->
A.send sender `Pong
)
let b = A.spawn
(fun self -> function
| `Pong
| `Start ->
Lwt_io.printl "pong!" >>= fun () ->
Lwt_unix.sleep 1. >>= fun () ->
A.send a (`Ping self)
)
let () = Lwt_main.run (
Lwt_io.printl "start" >>= fun () ->
A.send b `Start >>= fun () ->
A.wait_all ()
)

17
tests/quick/levenshtein_dict.ml
View file

@ -1,18 +1,19 @@
#!/usr/bin/env ocaml
#use "tests/quick/.common.ml";;
#load "containers.cma";;
open Containers;;
#load "containers_string.cma";;
#require "batteries";;
open Batteries;;
open Containers_string
let words = File.with_file_in "/usr/share/dict/cracklib-small"
(fun i -> IO.read_all i |> String.nsplit ~by:"\\n");;
let words = CCIO.(
(with_in "/usr/share/dict/cracklib-small" >>>= read_lines)
|> run_exn
)
let idx = List.fold_left
(fun idx s -> Levenshtein.StrIndex.add_string idx s s)
Levenshtein.StrIndex.empty words;;
(fun idx s -> Levenshtein.Index.add idx s s)
Levenshtein.Index.empty words;;
Levenshtein.StrIndex.retrieve_string ~limit:1 idx "hell"
Levenshtein.Index.retrieve ~limit:1 idx "hell"
|> Levenshtein.klist_to_list
|> List.iter print_endline;;

17
tests/quick/ratTerm.ml
View file

@ -1,17 +0,0 @@
#!/usr/bin/env ocaml
#use "tests/quick/.common.ml";;
#load "containers.cma";;
open Containers;;
module T = RatTerm.Default;;
#install_printer T.fmt;;
#install_printer T.Subst.fmt;;
let t = T.(app "f" [const "a"; app "f" [mk_ref 1; const "b"]]);;
let t2 = T.(app "f" [var (); app "f" [mk_ref 1; var ()]]);;
let t3 = T.(app "f" [var (); app "f" [var (); const "b"]]);;
let subst2 = match T.unify t t3 with Some s -> s | None -> assert false;;
let t3' = T.Subst.apply subst2 t3;;
T.eq_set t t3';;
ok();;

1
tests/run_tests.ml
View file

@ -21,6 +21,7 @@ let suite =
Test_heap.suite;
Test_graph.suite;
Test_univ.suite;
Test_mixtbl.suite;
]
let props =

95
tests/test_mixtbl.ml Normal file
View file

@ -0,0 +1,95 @@
open OUnit
open Containers_misc
open CCFun
let example () =
let inj_int = Mixtbl.create_inj () in
let tbl = Mixtbl.create 10 in
OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a");
Mixtbl.set ~inj:inj_int tbl "a" 1;
OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a");
let inj_string = Mixtbl.create_inj () in
Mixtbl.set ~inj:inj_string tbl "b" "Hello";
OUnit.assert_equal (Some "Hello") (Mixtbl.get ~inj:inj_string tbl "b");
OUnit.assert_equal None (Mixtbl.get ~inj:inj_string tbl "a");
OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a");
Mixtbl.set ~inj:inj_string tbl "a" "Bye";
OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a");
OUnit.assert_equal (Some "Bye") (Mixtbl.get ~inj:inj_string tbl "a");
()
let test_length () =
let inj_int = Mixtbl.create_inj () in
let tbl = Mixtbl.create 5 in
Mixtbl.set ~inj:inj_int tbl "foo" 1;
Mixtbl.set ~inj:inj_int tbl "bar" 2;
OUnit.assert_equal 2 (Mixtbl.length tbl);
OUnit.assert_equal 2 (Mixtbl.find ~inj:inj_int tbl "bar");
Mixtbl.set ~inj:inj_int tbl "foo" 42;
OUnit.assert_equal 2 (Mixtbl.length tbl);
Mixtbl.remove tbl "bar";
OUnit.assert_equal 1 (Mixtbl.length tbl);
()
let test_clear () =
let inj_int = Mixtbl.create_inj () in
let inj_str = Mixtbl.create_inj () in
let tbl = Mixtbl.create 5 in
Mixtbl.set ~inj:inj_int tbl "foo" 1;
Mixtbl.set ~inj:inj_int tbl "bar" 2;
Mixtbl.set ~inj:inj_str tbl "baaz" "hello";
OUnit.assert_equal 3 (Mixtbl.length tbl);
Mixtbl.clear tbl;
OUnit.assert_equal 0 (Mixtbl.length tbl);
()
let test_mem () =
let inj_int = Mixtbl.create_inj () in
let inj_str = Mixtbl.create_inj () in
let tbl = Mixtbl.create 5 in
Mixtbl.set ~inj:inj_int tbl "foo" 1;
Mixtbl.set ~inj:inj_int tbl "bar" 2;
Mixtbl.set ~inj:inj_str tbl "baaz" "hello";
OUnit.assert_bool "mem foo int" (Mixtbl.mem ~inj:inj_int tbl "foo");
OUnit.assert_bool "mem bar int" (Mixtbl.mem ~inj:inj_int tbl "bar");
OUnit.assert_bool "not mem baaz int" (not (Mixtbl.mem ~inj:inj_int tbl "baaz"));
OUnit.assert_bool "not mem foo str" (not (Mixtbl.mem ~inj:inj_str tbl "foo"));
OUnit.assert_bool "not mem bar str" (not (Mixtbl.mem ~inj:inj_str tbl "bar"));
OUnit.assert_bool "mem baaz str" (Mixtbl.mem ~inj:inj_str tbl "baaz");
()
let test_keys () =
let inj_int = Mixtbl.create_inj () in
let inj_str = Mixtbl.create_inj () in
let tbl = Mixtbl.create 5 in
Mixtbl.set ~inj:inj_int tbl "foo" 1;
Mixtbl.set ~inj:inj_int tbl "bar" 2;
Mixtbl.set ~inj:inj_str tbl "baaz" "hello";
let l = Mixtbl.keys_seq tbl |> CCSequence.to_list in
OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l);
()
let test_bindings () =
let inj_int = Mixtbl.create_inj () in
let inj_str = Mixtbl.create_inj () in
let tbl = Mixtbl.create 5 in
Mixtbl.set ~inj:inj_int tbl "foo" 1;
Mixtbl.set ~inj:inj_int tbl "bar" 2;
Mixtbl.set ~inj:inj_str tbl "baaz" "hello";
Mixtbl.set ~inj:inj_str tbl "str" "rts";
let l_int = Mixtbl.bindings_of tbl ~inj:inj_int |> CCSequence.to_list in
OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int);
let l_str = Mixtbl.bindings_of tbl ~inj:inj_str |> CCSequence.to_list in
OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str);
()
let suite =
"mixtbl" >:::
[ "example" >:: example;
"length" >:: test_length;
"clear" >:: test_clear;
"mem" >:: test_mem;
"bindings" >:: test_bindings;
]