├── dune-project ├── src ├── core │ ├── CCOpt.ml │ ├── CCListLabels.ml │ ├── CCArrayLabels.ml │ ├── CCEqualLabels.ml │ ├── CCStringLabels.ml │ ├── CCShims_.ml │ ├── cpp │ │ └── dune │ ├── CCOpt.mli │ ├── CCUnit.ml │ ├── CCShims_syntax.mli │ ├── dune │ ├── CCBool.ml │ ├── CCBool.mli │ ├── tests │ │ ├── dune │ │ ├── check_labelled_mods.ml │ │ ├── test_random.ml │ │ └── test_hash.ml │ ├── CCChar.ml │ ├── CCCanonical_sexp.mli │ ├── CCAtomic.ml │ ├── CCRef.ml │ ├── CCSexp.mli │ ├── CCEqual.ml │ ├── CCPair.ml │ ├── CCRef.mli │ ├── containersLabels.ml │ ├── CCEqualLabels.mli │ ├── CCEqual.mli │ ├── containers.ml │ ├── CCEither.ml │ ├── CCChar.mli │ ├── CCByte_buffer.mli │ ├── CCOrd.ml │ ├── CCEither.mli │ ├── CCFun.ml │ ├── CCOrd.mli │ ├── CCSet.mli │ └── CCFloat.ml ├── scc │ ├── dune │ └── containers_scc.mli ├── top │ ├── dune │ └── containers_top.ml ├── bencode │ ├── dune │ └── containers_bencode.mli ├── cbor │ ├── dune │ ├── tests │ │ └── dune │ └── containers_cbor.mli ├── codegen │ ├── dune │ ├── tests │ │ ├── dune │ │ └── emit_tests.ml │ └── containers_codegen.mli ├── unix │ └── dune ├── data │ ├── dune │ ├── top │ │ ├── dune │ │ └── containers_data_top.ml │ ├── CCMutHeap.mli │ ├── CCMixset.ml │ ├── CCMixset.mli │ ├── CCMutHeap_intf.ml │ ├── CCZipper.ml │ ├── CCLazy_list.mli │ ├── CCMixtbl.ml │ ├── CCBitField.mli │ ├── CCBitField.ml │ ├── CCBijection.mli │ ├── CCHet.mli │ ├── CCZipper.mli │ ├── CCLazy_list.ml │ ├── CCImmutArray.ml │ ├── CCMultiSet.mli │ ├── CCSimple_queue.mli │ ├── CCImmutArray.mli │ └── CCHashSet.mli ├── testlib │ ├── dune │ └── containers_testlib.mli ├── monomorphic │ ├── dune │ ├── CCMonomorphic.ml │ └── CCMonomorphic.mli ├── dune ├── threads │ ├── dune │ ├── CCSemaphore.mli │ ├── CCSemaphore.ml │ ├── CCTimer.mli │ ├── CCThread.ml │ ├── CCBlockingQueue.mli │ ├── CCThread.mli │ ├── CCLock.ml │ └── CCLock.mli └── mdx_runner.ml ├── .ocp-indent ├── .header ├── tests ├── core │ ├── compat │ │ ├── dune │ │ └── t_compat.ml │ ├── t_eq.ml │ ├── t_char.ml │ ├── t_bool.ml │ ├── dune │ ├── t_either.ml │ ├── t_float.ml │ ├── t_hash.ml │ ├── t_random.ml │ ├── t_fun.ml │ ├── t_set.ml │ ├── t.ml │ ├── t_map.ml │ ├── t_result.ml │ ├── t_option.ml │ ├── t_ord.ml │ ├── t_unix.ml │ ├── t_canonical_sexp.ml │ ├── t_bencode.ml │ ├── t_hashtbl.ml │ ├── t_IO.ml │ ├── t_cbor.ml │ ├── t_heap.ml │ └── t_nativeint.ml ├── data │ ├── dune │ ├── t_bijection.ml │ ├── t_zipper.ml │ ├── t.ml │ ├── t_het.ml │ ├── t_lazylist.ml │ ├── t_hashset.ml │ ├── t_simplequeue.ml │ ├── t_bitfield.ml │ ├── t_cache.ml │ ├── t_mutheap.ml │ ├── t_fun_vec.ml │ ├── t_immutarray.ml │ └── t_graph.ml └── thread │ ├── dune │ ├── t.ml │ ├── t_thread.ml │ ├── t_timer.ml │ ├── t_bq.ml │ ├── t_semaphore.ml │ └── t_lock.ml ├── fuzz ├── clean.sh ├── ccsexp_parse_string_does_not_crash.ml ├── dune ├── list.sh ├── ccsexp_csexp_reparse.ml ├── run.sh └── run_all.sh ├── .gitignore ├── examples ├── test_data │ └── benchpress.sexp ├── id_sexp.ml ├── dune ├── ccparse_irclogs_real.cond.ml └── ccparse_sexp.ml ├── .ocamlformat ├── benchs ├── dune ├── run_bench_hash.ml ├── objsize.ml └── run_objsize.ml ├── dune ├── .github └── workflows │ ├── opam-dependencies.yml.bak │ ├── gh-pages.yml │ ├── compat.yml │ └── main.yml ├── containers-thread.opam ├── containers-data.opam ├── containers.opam ├── Makefile ├── LICENSE ├── doc └── containers.md └── CODE_OF_CONDUCT.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | -------------------------------------------------------------------------------- /src/core/CCOpt.ml: -------------------------------------------------------------------------------- 1 | include CCOption 2 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause=2 2 | with=2 3 | -------------------------------------------------------------------------------- /.header: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | -------------------------------------------------------------------------------- /tests/core/compat/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names t_compat) 3 | (flags :standard -nolabels) 4 | (libraries containers)) 5 | -------------------------------------------------------------------------------- /src/core/CCListLabels.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | include CCList 4 | -------------------------------------------------------------------------------- /src/core/CCArrayLabels.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | include CCArray 4 | -------------------------------------------------------------------------------- /src/core/CCEqualLabels.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | include CCEqual 4 | -------------------------------------------------------------------------------- /src/core/CCStringLabels.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | include CCString 4 | -------------------------------------------------------------------------------- /src/core/CCShims_.ml: -------------------------------------------------------------------------------- 1 | [@@@ifge 4.07] 2 | 3 | module Stdlib = Stdlib 4 | 5 | [@@@else_] 6 | 7 | module Stdlib = Pervasives 8 | 9 | [@@@endif] 10 | -------------------------------------------------------------------------------- /fuzz/clean.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | script_dir=$(dirname $(readlink -f "$0")) 4 | 5 | rm -r "$script_dir"/../fuzz-*-input 6 | rm -r "$script_dir"/../fuzz-*-output 7 | -------------------------------------------------------------------------------- /src/scc/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name containers_scc) 4 | (public_name containers.scc) 5 | (synopsis "strongly connected components algorithm") 6 | (libraries containers)) 7 | -------------------------------------------------------------------------------- /src/core/cpp/dune: -------------------------------------------------------------------------------- 1 | ; our little preprocessor 2 | 3 | (executable 4 | (name cpp) 5 | (flags :standard -warn-error -a+8) 6 | (modes (best exe)) 7 | (libraries dune.configurator)) 8 | -------------------------------------------------------------------------------- /fuzz/ccsexp_parse_string_does_not_crash.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Crowbar.add_test ~name:"ccsexp_parse_string_does_not_crash" [ Crowbar.bytes ] 3 | (fun s -> CCSexp.parse_string s |> ignore) 4 | -------------------------------------------------------------------------------- /src/core/CCOpt.mli: -------------------------------------------------------------------------------- 1 | (** Previous Option module 2 | @deprecated use `CCOption` instead. *) 3 | 4 | [@@@ocaml.deprecated "use CCOption instead"] 5 | 6 | include module type of CCOption 7 | -------------------------------------------------------------------------------- /src/top/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_top) 3 | (public_name containers.top) 4 | (wrapped false) 5 | (modes byte) 6 | (libraries compiler-libs.common containers containers.unix)) 7 | -------------------------------------------------------------------------------- /src/bencode/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_bencode) 3 | (public_name containers.bencode) 4 | (libraries containers) 5 | (synopsis "Bencode codec for containers (the format for bittorrent files)")) 6 | -------------------------------------------------------------------------------- /src/cbor/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_cbor) 3 | (libraries containers) 4 | (preprocess 5 | (action 6 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 7 | (public_name containers.cbor)) 8 | -------------------------------------------------------------------------------- /src/codegen/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_codegen) 3 | (public_name containers.codegen) 4 | (synopsis "code generators for Containers") 5 | (libraries containers) 6 | (flags :standard -warn-error -a+8)) 7 | -------------------------------------------------------------------------------- /src/unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_unix) 3 | (public_name containers.unix) 4 | (wrapped false) 5 | (optional) 6 | (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) 7 | (libraries unix)) 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .*.swo 3 | _build 4 | *.native 5 | *.byte 6 | .session 7 | *.docdir 8 | setup.* 9 | *.html 10 | .merlin 11 | *.install 12 | .ignore 13 | _opam 14 | *.exe 15 | fuzz-*-input 16 | fuzz-*-output 17 | fuzz-logs/ 18 | -------------------------------------------------------------------------------- /tests/core/compat/t_compat.ml: -------------------------------------------------------------------------------- 1 | (* test consistency of interfaces *) 2 | module type L = module type of CCEqual 3 | module type LL = module type of CCEqualLabels;; 4 | 5 | ignore (module CCEqualLabels : L);; 6 | ignore (module CCEqual : LL) 7 | -------------------------------------------------------------------------------- /tests/data/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t) 3 | (flags :standard -strict-sequence -warn-error -a+8 -open CCShims_) 4 | (modes (best exe)) 5 | (package containers-data) 6 | (libraries containers containers-data containers_testlib iter gen)) 7 | -------------------------------------------------------------------------------- /src/data/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_data) 3 | (public_name containers-data) 4 | (wrapped false) 5 | (flags :standard -warn-error -3 -w -70 -color always -safe-string 6 | -strict-sequence -open CCShims_) 7 | (libraries containers)) 8 | -------------------------------------------------------------------------------- /src/testlib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_testlib) 3 | (synopsis "Test library for containers") 4 | (preprocess 5 | (action 6 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 7 | (libraries containers qcheck-core unix)) 8 | -------------------------------------------------------------------------------- /tests/thread/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t) 3 | (flags :standard -strict-sequence -warn-error -a+8 -open CCShims_) 4 | (modes (best exe)) 5 | (package containers-thread) 6 | (libraries containers containers-thread containers_testlib iter threads)) 7 | -------------------------------------------------------------------------------- /src/monomorphic/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_monomorphic) 3 | (public_name containers.monomorphic) 4 | (preprocess 5 | (action 6 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 7 | (modules CCMonomorphic) 8 | (wrapped false)) 9 | -------------------------------------------------------------------------------- /src/core/CCUnit.ml: -------------------------------------------------------------------------------- 1 | [@@@ifge 4.08] 2 | 3 | include Unit 4 | 5 | [@@@else_] 6 | 7 | type t = unit 8 | 9 | let[@inline] equal (_ : t) (_ : t) = true 10 | let[@inline] compare (_ : t) (_ : t) = 0 11 | let to_string () = "()" 12 | 13 | [@@@endif] 14 | -------------------------------------------------------------------------------- /src/data/top/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_data_top) 3 | (public_name containers-data.top) 4 | (wrapped false) 5 | (modes byte) 6 | (flags :standard -warn-error -a+8 -safe-string) 7 | (libraries compiler-libs.common containers containers-data)) 8 | -------------------------------------------------------------------------------- /fuzz/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (flags 3 | (-w "+a-4-9-29-37-40-42-44-48-50-32" -g)) 4 | (names ccsexp_parse_string_does_not_crash 5 | ccutf8_string_uchar_to_bytes_is_same_as_simple_version 6 | ccsexp_csexp_reparse) 7 | (optional) 8 | (libraries crowbar containers)) 9 | -------------------------------------------------------------------------------- /tests/core/t_eq.ml: -------------------------------------------------------------------------------- 1 | open CCEqual 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | q 6 | Q.( 7 | let p = small_list (pair small_int bool) in 8 | pair p p) 9 | (fun (l1, l2) -> (list (pair int bool)) l1 l2 = (l1 = l2)) 10 | -------------------------------------------------------------------------------- /tests/thread/t.ml: -------------------------------------------------------------------------------- 1 | Containers_testlib.run_all ~descr:"containers-thread" 2 | [ 3 | T_bq.Test.get (); 4 | T_lock.Test.get (); 5 | T_pool.Test.get (); 6 | T_semaphore.Test.get (); 7 | T_thread.Test.get (); 8 | T_timer.Test.get (); 9 | ] 10 | -------------------------------------------------------------------------------- /tests/core/t_char.ml: -------------------------------------------------------------------------------- 1 | open CCChar 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | eq (Some 'a') (of_int (to_int 'a'));; 6 | eq None (of_int 257);; 7 | 8 | q 9 | (Q.string_of_size (Q.Gen.return 1)) 10 | (fun s -> CCShims_.Stdlib.( = ) (to_string s.[0]) s) 11 | -------------------------------------------------------------------------------- /tests/core/t_bool.ml: -------------------------------------------------------------------------------- 1 | open CCBool 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | eq 1 (to_int true);; 6 | eq 0 (to_int false);; 7 | eq true (of_int 1);; 8 | eq false (of_int 0);; 9 | eq true (of_int 42);; 10 | eq true (of_int max_int);; 11 | eq true (of_int min_int) 12 | -------------------------------------------------------------------------------- /fuzz/list.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | script_dir=$(dirname $(readlink -f "$0")) 4 | 5 | echo "Building" 6 | 7 | dune build @all 8 | 9 | echo "" 10 | 11 | echo "Fuzzing tests available:" 12 | 13 | for file in "$script_dir"/../_build/default/fuzz/*.exe; do 14 | echo "- "$(basename $file | sed 's/\.exe$//') 15 | done 16 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags :standard -warn-error -a+8 -w -32-70 -color always -safe-string 4 | -strict-sequence) 5 | (ocamlopt_flags :standard -O3 -unbox-closures -unbox-closures-factor 20 6 | -inline 100))) 7 | 8 | (executable 9 | (name mdx_runner) 10 | (libraries containers) 11 | (modules mdx_runner)) 12 | -------------------------------------------------------------------------------- /examples/test_data/benchpress.sexp: -------------------------------------------------------------------------------- 1 | 2 | (prover 3 | (name msat) 4 | (synopsis "msat for pure sat problems") 5 | (version "git:.") 6 | (sat "^Sat") 7 | (unsat "^Unsat") 8 | (cmd "$cur_dir/../msat.exe -time $timeout $file")) 9 | 10 | (dir 11 | (path $cur_dir) 12 | (pattern ".*\\.cnf") 13 | (expect (const unknown))) 14 | -------------------------------------------------------------------------------- /src/threads/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers_thread) 3 | (public_name containers-thread) 4 | (wrapped false) 5 | (optional) 6 | (flags :standard -warn-error -a+8 -w -32 -safe-string -open CCShims_) 7 | (preprocess 8 | (action 9 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 10 | (libraries containers threads)) 11 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.22.4 2 | profile=conventional 3 | margin=80 4 | if-then-else=k-r 5 | parens-ite=true 6 | parens-tuple=multi-line-only 7 | sequence-style=terminator 8 | type-decl=compact 9 | break-cases=toplevel 10 | cases-exp-indent=2 11 | field-space=tight-decl 12 | leading-nested-match-parens=true 13 | module-item-spacing=compact 14 | quiet=true 15 | -------------------------------------------------------------------------------- /benchs/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names run_benchs run_bench_hash run_objsize) 3 | (libraries containers containers-data containers-thread benchmark gen iter 4 | qcheck oseq batteries base sek) 5 | (flags :standard -warn-error -3-5 -safe-string -color always -open CCShims_) 6 | (optional) 7 | (ocamlopt_flags :standard -O3 -color always -unbox-closures 8 | -unbox-closures-factor 20)) 9 | -------------------------------------------------------------------------------- /tests/core/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name t) 3 | (flags :standard -strict-sequence -warn-error -a+8 -open CCShims_) 4 | (modes (best exe)) 5 | (package containers) 6 | (preprocess 7 | (action 8 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 9 | (libraries containers containers.bencode containers.cbor containers.unix 10 | threads containers_testlib iter gen uutf csexp)) 11 | -------------------------------------------------------------------------------- /src/core/CCShims_syntax.mli: -------------------------------------------------------------------------------- 1 | [@@@ifge 4.8] 2 | 3 | (** Let operators on OCaml >= 4.08.0, nothing otherwise 4 | @since 2.8 *) 5 | module type LET = sig 6 | type 'a t 7 | 8 | val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t 9 | val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t 10 | val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t 11 | val ( and* ) : 'a t -> 'b t -> ('a * 'b) t 12 | end 13 | 14 | [@@@endif] 15 | -------------------------------------------------------------------------------- /src/cbor/tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name t_appendix_a) 3 | (modules t_appendix_a) 4 | (preprocess 5 | (action 6 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 7 | (libraries yojson containers containers.cbor)) 8 | 9 | (rule 10 | (alias runtest) 11 | (deps t_appendix_a.exe appendix_a.json) 12 | (package containers) 13 | (action 14 | (run ./t_appendix_a.exe ./appendix_a.json))) 15 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets README.md.corrected) 3 | (deps 4 | (package containers-data) 5 | ./src/mdx_runner.exe) 6 | (enabled_if 7 | (= %{system} "linux")) 8 | (action 9 | (run ./src/mdx_runner.exe))) 10 | 11 | (rule 12 | (alias runtest) 13 | (package containers-data) 14 | (enabled_if 15 | (= %{system} "linux")) 16 | (locks /ctest) 17 | (action 18 | (diff README.md README.md.corrected))) 19 | -------------------------------------------------------------------------------- /examples/id_sexp.ml: -------------------------------------------------------------------------------- 1 | let pp_sexp s = 2 | match s with 3 | | Ok l -> List.iter (fun s -> Format.printf "@[%a@]@." CCSexp.pp s) l 4 | | Error msg -> Format.printf "error: %s@." msg 5 | 6 | let () = 7 | match Sys.argv with 8 | | [| _ |] -> 9 | let s = CCSexp.parse_chan_list stdin in 10 | pp_sexp s 11 | | [| _; file |] -> 12 | let s = CCSexp.parse_file_list file in 13 | pp_sexp s 14 | | _ -> failwith "usage: id_sexp [file]" 15 | -------------------------------------------------------------------------------- /tests/data/t_bijection.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCBijection 4 | module M = Make (CCInt) (String);; 5 | 6 | eq 2 (M.of_list [ 1, "1"; 2, "2" ] |> M.cardinal);; 7 | eq "1" (M.of_list [ 1, "1"; 2, "2" ] |> M.find_left 1);; 8 | eq "2" (M.of_list [ 1, "1"; 2, "2" ] |> M.find_left 2);; 9 | eq 1 (M.of_list [ 1, "1"; 2, "2" ] |> M.find_right "1");; 10 | eq 2 (M.of_list [ 1, "1"; 2, "2" ] |> M.find_right "2") 11 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name containers) 3 | (public_name containers) 4 | (wrapped false) 5 | (modules_without_implementation CCShims_syntax) 6 | (preprocess 7 | (action 8 | (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) 9 | (flags :standard -warn-error -a+8 -w -32-70 -safe-string -strict-sequence 10 | -nolabels -open CCMonomorphic) 11 | (libraries seq either containers.monomorphic)) 12 | 13 | (ocamllex 14 | (modules CCSexp_lex)) 15 | -------------------------------------------------------------------------------- /tests/core/t_either.ml: -------------------------------------------------------------------------------- 1 | open CCEither 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | eq (is_left (Left 1)) true;; 6 | eq (is_left (Right 1)) false;; 7 | eq (is_left (Left 1)) true;; 8 | eq (is_left (Right 1)) false;; 9 | eq (is_right (Left 1)) false;; 10 | eq (is_right (Right 1)) true;; 11 | eq (find_left (Left 1)) (Some 1);; 12 | eq (find_left (Right 1)) None;; 13 | eq (find_right (Left 1)) None;; 14 | eq (find_right (Right 1)) (Some 1) 15 | -------------------------------------------------------------------------------- /src/data/CCMutHeap.mli: -------------------------------------------------------------------------------- 1 | (* This code is extracted from Msat ( https://github.com/Gbury/mSAT ). 2 | As such it is under the Apache 2 License. 3 | *) 4 | 5 | (** Mutable Heaps 6 | 7 | The classic binary heap in a vector. 8 | 9 | {b STATUS}: experimental, this might change in breaking ways. 10 | 11 | @since 3.1 *) 12 | 13 | module type RANKED = CCMutHeap_intf.RANKED 14 | module type S = CCMutHeap_intf.S 15 | 16 | module Make (X : RANKED) : S with type elt = X.t 17 | -------------------------------------------------------------------------------- /src/core/CCBool.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | open CCShims_ 4 | 5 | type t = bool 6 | 7 | let equal (a : bool) b = Stdlib.( = ) a b 8 | let compare (a : bool) b = Stdlib.compare a b 9 | 10 | let to_int (x : bool) : int = 11 | if x then 12 | 1 13 | else 14 | 0 15 | 16 | let of_int x : t = x <> 0 17 | 18 | type 'a printer = Format.formatter -> 'a -> unit 19 | 20 | let pp = Format.pp_print_bool 21 | -------------------------------------------------------------------------------- /src/codegen/tests/dune: -------------------------------------------------------------------------------- 1 | ; emit tests 2 | 3 | (executable 4 | (name emit_tests) 5 | (modules emit_tests) 6 | (flags :standard -warn-error -a+8) 7 | (libraries containers containers.codegen)) 8 | 9 | (rule 10 | (targets test_bitfield.ml test_bitfield.mli) 11 | (action 12 | (run ./emit_tests.exe))) 13 | 14 | ; run tests 15 | 16 | (executables 17 | (names test_bitfield) 18 | (modules test_bitfield) 19 | (flags :standard -warn-error -a+8) 20 | (libraries containers)) 21 | 22 | (rule 23 | (alias runtest) 24 | (action 25 | (run ./test_bitfield.exe))) 26 | -------------------------------------------------------------------------------- /tests/core/t_float.ml: -------------------------------------------------------------------------------- 1 | open CCFloat 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | t @@ fun () -> max nan 1. = 1.;; 6 | t @@ fun () -> min nan 1. = 1.;; 7 | t @@ fun () -> max 1. nan = 1.;; 8 | t @@ fun () -> min 1. nan = 1.;; 9 | 10 | q 11 | Q.(pair float float) 12 | (fun (x, y) -> is_nan x || is_nan y || (min x y <= x && min x y <= y)) 13 | ;; 14 | 15 | q 16 | Q.(pair float float) 17 | (fun (x, y) -> is_nan x || is_nan y || (max x y >= x && max x y >= y)) 18 | ;; 19 | 20 | eq 2. (round 1.6);; 21 | eq 1. (round 1.4);; 22 | eq 0. (round 0.) 23 | -------------------------------------------------------------------------------- /fuzz/ccsexp_csexp_reparse.ml: -------------------------------------------------------------------------------- 1 | let gen_sexp = 2 | let open! Crowbar in 3 | let ( >|= ) = map in 4 | fix (fun self -> 5 | choose 6 | [ 7 | (([ bytes ] : _ gens) >|= fun s -> `Atom s); 8 | ([ list self ] >|= fun l -> `List l); 9 | ]) 10 | 11 | let () = 12 | Crowbar.add_test ~name:"ccsexp_csexp_reparse" [ gen_sexp ] (fun s -> 13 | let str = CCCanonical_sexp.to_string s in 14 | match CCCanonical_sexp.parse_string_list str with 15 | | Ok [ s2 ] -> assert (s = s2) 16 | | Ok _ -> failwith "wrong number of sexps" 17 | | Error e -> failwith e) 18 | -------------------------------------------------------------------------------- /tests/core/t_hash.ml: -------------------------------------------------------------------------------- 1 | open CCHash 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | t @@ fun () -> int 42 >= 0;; 6 | t @@ fun () -> int max_int >= 0;; 7 | t @@ fun () -> int max_int = int max_int;; 8 | t @@ fun () -> int min_int >= 0;; 9 | t @@ fun () -> int 0 >= 0;; 10 | t @@ fun () -> char 'c' >= 0;; 11 | t @@ fun () -> int 152352 = int 152352;; 12 | t @@ fun () -> list_comm int [ 1; 2 ] = list_comm int [ 2; 1 ];; 13 | t @@ fun () -> list_comm int [ 1; 2 ] <> list_comm int [ 2; 3 ];; 14 | 15 | q Q.int (fun i -> 16 | Q.assume (i >= 0); 17 | int i = int64 (Int64.of_int i)) 18 | -------------------------------------------------------------------------------- /tests/core/t_random.ml: -------------------------------------------------------------------------------- 1 | open CCRandom 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | q Q.(list small_int) (fun l -> l = [] || List.mem (run (pick_list l)) l);; 6 | 7 | q 8 | Q.(pair small_int small_int) 9 | (fun (i, j) -> 10 | let len, n = 2 + min i j, max i j in 11 | let l = QCheck.Gen.generate1 (split_list n ~len) in 12 | match l with 13 | | None -> true 14 | | Some l -> l <> [] && List.for_all (fun x -> x > 0) l) 15 | ;; 16 | 17 | t @@ fun () -> 18 | let open Containers in 19 | ignore (List.random_choose [ 1; 2; 3 ] (Random.get_state ()) : int); 20 | true 21 | -------------------------------------------------------------------------------- /src/top/containers_top.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | type 'a printer = Format.formatter -> 'a -> unit 4 | 5 | let eval_exn str = 6 | let lexbuf = Lexing.from_string str in 7 | let phrase = !Toploop.parse_toplevel_phrase lexbuf in 8 | Toploop.execute_phrase false Format.err_formatter phrase 9 | 10 | let install_printer s = 11 | try ignore (eval_exn ("#install_printer " ^ s ^ " ;; ")) 12 | with _ -> 13 | Printexc.print_backtrace stderr; 14 | () 15 | 16 | let install_printers = List.iter install_printer 17 | let () = install_printers [ "CCHashtbl.pp"; "CCSexp.pp" ] 18 | -------------------------------------------------------------------------------- /src/core/CCBool.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Basic Bool functions *) 4 | 5 | type t = bool 6 | 7 | val compare : t -> t -> int 8 | (** [compare b1 b2] is the total ordering on booleans [b1] and [b2], similar to {!Stdlib.compare}. *) 9 | 10 | val equal : t -> t -> bool 11 | (** [equal b1 b2] is [true] if [b1] and [b2] are the same. *) 12 | 13 | val to_int : t -> int 14 | (** [to_int true = 1], [to_int false = 0]. 15 | @since 2.7 *) 16 | 17 | val of_int : int -> t 18 | (** [of_int i] is the same as [i <> 0] 19 | @since 2.7 *) 20 | 21 | type 'a printer = Format.formatter -> 'a -> unit 22 | 23 | val pp : t printer 24 | -------------------------------------------------------------------------------- /tests/data/t_zipper.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCZipper;; 4 | 5 | t @@ fun () -> is_empty empty;; 6 | t @@ fun () -> not ([ 42 ] |> make |> right |> is_empty) 7 | 8 | let zip_gen = Q.(pair (small_list int) (small_list int));; 9 | 10 | q zip_gen (fun z -> to_list z = List.rev (to_rev_list z));; 11 | q zip_gen (fun g -> is_focused g = (focused g |> CCOption.is_some));; 12 | 13 | q 14 | Q.(triple int (list small_int) (list small_int)) 15 | (fun (x, l, r) -> insert x (l, r) |> remove = (l, r)) 16 | ;; 17 | 18 | eq ([ 1 ], [ 2 ]) (drop_after ([ 1 ], [ 2; 3 ]));; 19 | eq ([ 1 ], []) (drop_after ([ 1 ], []));; 20 | eq ([ 1 ], []) (drop_after_and_focused ([ 1 ], [ 2; 3 ])) 21 | -------------------------------------------------------------------------------- /tests/core/t_fun.ml: -------------------------------------------------------------------------------- 1 | open CCFun 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | eq ~printer:Q.Print.int 10 (iterate 0 succ 10);; 6 | eq ~printer:Q.Print.int 11 (iterate 1 succ 10);; 7 | eq ~printer:Q.Print.int 12 (iterate 2 succ 10);; 8 | eq ~printer:Q.Print.int 15 (iterate 5 succ 10);; 9 | 10 | t @@ fun () -> 11 | assert_raises 12 | (function 13 | | Invalid_argument _ -> true 14 | | _ -> false) 15 | (fun () -> iterate (-1) succ 10); 16 | true 17 | ;; 18 | 19 | t @@ fun () -> CCFun.((succ %> string_of_int) 2 = "3");; 20 | t @@ fun () -> CCFun.((( * ) 3 % succ) 5 = 18);; 21 | t @@ fun () -> CCFun.(succ @@ ( * ) 2 @@ pred @@ 3 = 5);; 22 | t @@ fun () -> CCFun.(3 |> succ |> ( * ) 5 |> pred = 19) 23 | -------------------------------------------------------------------------------- /src/mdx_runner.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let just_copy () = 4 | let ic = open_in "README.md" in 5 | let len = in_channel_length ic in 6 | let buf = Bytes.create len in 7 | really_input ic buf 0 len; 8 | close_in_noerr ic; 9 | 10 | let oc = open_out "README.md.corrected" in 11 | output oc buf 0 len; 12 | flush oc; 13 | close_out_noerr oc 14 | 15 | let () = 16 | try 17 | let e = Sys.command "ocaml-mdx test README.md -o README.md.corrected" in 18 | if e <> 0 then ( 19 | printf "warning: ocaml-mdx exited with code %d\n" e; 20 | just_copy () 21 | ) else 22 | print_endline "ocaml-mdx returned 0 ✔" 23 | with Sys_error e -> 24 | printf "error when running mdx: %s\n" e; 25 | just_copy (); 26 | () 27 | -------------------------------------------------------------------------------- /tests/core/t_set.ml: -------------------------------------------------------------------------------- 1 | module T = (val Containers_testlib.make ~__FILE__ ()) 2 | include T 3 | 4 | module S = CCSet.Make (struct 5 | type t = int 6 | 7 | let compare x y = Stdlib.compare x y 8 | end) 9 | ;; 10 | 11 | eq ~printer:(fun s -> s) (S.to_string string_of_int (S.of_list [ 4; 3 ])) "3,4" 12 | ;; 13 | 14 | q 15 | Q.(list int) 16 | (fun l -> 17 | let s = S.of_list l in 18 | S.to_string string_of_int s 19 | = (CCList.sort_uniq ~cmp:CCInt.compare l 20 | |> List.map string_of_int |> String.concat ",")) 21 | ;; 22 | 23 | q 24 | Q.(list int) 25 | (fun l -> 26 | let s = S.of_list l in 27 | S.to_string ~sep:" " string_of_int s 28 | = (CCList.sort_uniq ~cmp:CCInt.compare l 29 | |> List.map string_of_int |> String.concat " ")) 30 | -------------------------------------------------------------------------------- /src/core/tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name check_labelled_mods) 3 | (modules check_labelled_mods) 4 | (flags :standard -warn-error -a -w -3-33-35-27-39-50 -nolabels) 5 | (libraries containers)) 6 | 7 | (executable 8 | (name test_hash) 9 | (modules test_hash) 10 | (flags :standard -warn-error -a+8) 11 | (libraries containers iter)) 12 | 13 | (executable 14 | (name test_random) 15 | (flags :standard -warn-error -a+8) 16 | (modules test_random) 17 | (libraries containers)) 18 | 19 | (rule 20 | (alias runtest) 21 | (locks /ctest) 22 | (package containers) 23 | (action 24 | (run ./test_random.exe))) 25 | 26 | ; what matters is that it compiles 27 | 28 | (rule 29 | (alias runtest) 30 | (locks /ctest) 31 | (package containers) 32 | (action 33 | (run ./check_labelled_mods.exe))) 34 | -------------------------------------------------------------------------------- /tests/data/t.ml: -------------------------------------------------------------------------------- 1 | Containers_testlib.run_all ~descr:"containers-data" 2 | [ 3 | T_bv.Test.get (); 4 | T_bijection.Test.get (); 5 | T_bitfield.Test.get (); 6 | T_cache.Test.get (); 7 | T_deque.Test.get (); 8 | T_fqueue.Test.get (); 9 | T_fun_vec.Test.get (); 10 | T_graph.Test.get (); 11 | T_hashset.Test.get (); 12 | T_hashtrie.Test.get (); 13 | T_het.Test.get (); 14 | T_immutarray.Test.get (); 15 | T_intmap.Test.get (); 16 | T_lazylist.Test.get (); 17 | T_misc.Test.get (); 18 | T_mutheap.Test.get (); 19 | T_persistenthashtbl.Test.get (); 20 | T_ral.Test.get (); 21 | T_ringbuffer.Test.get (); 22 | T_simplequeue.Test.get (); 23 | T_trie.Test.get (); 24 | T_wbt.Test.get (); 25 | T_zipper.Test.get (); 26 | ] 27 | -------------------------------------------------------------------------------- /src/data/top/containers_data_top.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | type 'a printer = Format.formatter -> 'a -> unit 4 | 5 | let eval_exn str = 6 | let lexbuf = Lexing.from_string str in 7 | let phrase = !Toploop.parse_toplevel_phrase lexbuf in 8 | Toploop.execute_phrase false Format.err_formatter phrase 9 | 10 | let install_printer s = 11 | try ignore (eval_exn ("#install_printer " ^ s ^ " ;; ")) 12 | with _ -> 13 | Printexc.print_backtrace stderr; 14 | () 15 | 16 | let install_printers = List.iter install_printer 17 | 18 | let () = 19 | install_printers 20 | [ 21 | "CCBV.pp"; 22 | "CCDeque.pp"; 23 | "CCFQueue.pp"; 24 | "CCFun_vec.pp"; 25 | "CCIntMap.pp"; 26 | "CCPersistentArray.pp"; 27 | ] 28 | -------------------------------------------------------------------------------- /tests/thread/t_thread.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCThread;; 4 | 5 | t @@ fun () -> 6 | let l = CCLock.create 0 in 7 | let a = Arr.spawn 101 (fun i -> CCLock.update l (( + ) i)) in 8 | Arr.join a; 9 | let n = Iter.(1 -- 100 |> fold ( + ) 0) in 10 | assert_equal ~printer:CCInt.to_string n (CCLock.get l); 11 | true 12 | ;; 13 | 14 | t @@ fun () -> 15 | let b = Barrier.create () in 16 | let res = CCLock.create 0 in 17 | let t1 = 18 | spawn (fun _ -> 19 | Barrier.wait b; 20 | CCLock.incr res) 21 | and t2 = 22 | spawn (fun _ -> 23 | Barrier.wait b; 24 | CCLock.incr res) 25 | in 26 | Thread.delay 0.2; 27 | assert_equal 0 (CCLock.get res); 28 | Barrier.activate b; 29 | Thread.join t1; 30 | Thread.join t2; 31 | assert_equal 2 (CCLock.get res); 32 | true 33 | -------------------------------------------------------------------------------- /.github/workflows/opam-dependencies.yml.bak: -------------------------------------------------------------------------------- 1 | name: Opam Dependencies 2 | 3 | on: 4 | pull_request: 5 | push: 6 | #schedule: 7 | # Prime the caches every Monday 8 | #- cron: 0 1 * * MON 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: 16 | - ubuntu-latest 17 | ocaml-compiler: 18 | - 4.14.x 19 | 20 | runs-on: ${{ matrix.os }} 21 | 22 | steps: 23 | - name: Checkout code 24 | uses: actions/checkout@v3 25 | 26 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 27 | uses: ocaml/setup-ocaml@analysis 28 | with: 29 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 30 | 31 | - run: opam install . --deps-only --with-test --with-doc 32 | 33 | - uses: ocaml/setup-ocaml/analysis@analysis 34 | -------------------------------------------------------------------------------- /src/core/CCChar.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Utils around char} 4 | 5 | @since 0.14 *) 6 | 7 | include Char 8 | 9 | let pp_buf = Buffer.add_char 10 | let pp = Format.pp_print_char 11 | let of_int_exn = Char.chr 12 | let of_int c = try Some (of_int_exn c) with Invalid_argument _ -> None 13 | let to_int = Char.code 14 | let to_string c = String.make 1 c 15 | 16 | module Infix = struct 17 | let ( = ) : t -> t -> bool = CCShims_.Stdlib.( = ) 18 | let ( <> ) : t -> t -> bool = CCShims_.Stdlib.( <> ) 19 | let ( < ) : t -> t -> bool = CCShims_.Stdlib.( < ) 20 | let ( > ) : t -> t -> bool = CCShims_.Stdlib.( > ) 21 | let ( <= ) : t -> t -> bool = CCShims_.Stdlib.( <= ) 22 | let ( >= ) : t -> t -> bool = CCShims_.Stdlib.( >= ) 23 | end 24 | 25 | include Infix 26 | -------------------------------------------------------------------------------- /tests/data/t_het.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCHet;; 4 | 5 | t @@ fun () -> 6 | let k1 : int Key.t = Key.create () in 7 | let k2 : int Key.t = Key.create () in 8 | let k3 : string Key.t = Key.create () in 9 | let k4 : float Key.t = Key.create () in 10 | 11 | let tbl = Tbl.create () in 12 | 13 | Tbl.add tbl k1 1; 14 | Tbl.add tbl k2 2; 15 | Tbl.add tbl k3 "k3"; 16 | 17 | assert_equal (Some 1) (Tbl.find tbl k1); 18 | assert_equal (Some 2) (Tbl.find tbl k2); 19 | assert_equal (Some "k3") (Tbl.find tbl k3); 20 | assert_equal None (Tbl.find tbl k4); 21 | assert_equal 3 (Tbl.length tbl); 22 | 23 | Tbl.add tbl k1 10; 24 | assert_equal (Some 10) (Tbl.find tbl k1); 25 | assert_equal 3 (Tbl.length tbl); 26 | assert_equal None (Tbl.find tbl k4); 27 | 28 | Tbl.add tbl k4 0.0; 29 | assert_equal (Some 0.0) (Tbl.find tbl k4); 30 | true 31 | -------------------------------------------------------------------------------- /tests/data/t_lazylist.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCLazy_list;; 4 | 5 | q Q.(list int) (fun l -> length (of_list l) = List.length l);; 6 | 7 | eq [ 2; 4; 6 ] 8 | (of_list [ 1; 2; 3; 4; 5; 6; 7 ] 9 | |> filter ~f:(fun x -> x mod 2 = 0) 10 | |> to_list) 11 | ;; 12 | 13 | eq [ 2; 4; 6 ] 14 | (of_gen Gen.(1 -- max_int) 15 | |> filter ~f:(fun x -> x mod 2 = 0) 16 | |> take 3 |> to_list) 17 | ;; 18 | 19 | q 20 | Q.(pair (list int) (list int)) 21 | (fun (l1, l2) -> 22 | length (append (of_list l1) (of_list l2)) = List.length l1 + List.length l2) 23 | ;; 24 | 25 | eq [ 1 ] (default ~default:(return 1) empty |> to_list);; 26 | q Q.(list int) (fun l -> l = (Gen.of_list l |> of_gen |> to_list));; 27 | q Q.(list int) (fun l -> l = to_list (of_list l));; 28 | q Q.(list int) (fun l -> l = (of_list l |> to_gen |> Gen.to_list)) 29 | -------------------------------------------------------------------------------- /src/core/CCCanonical_sexp.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Canonical S-expressions 4 | 5 | See {{: https://en.wikipedia.org/wiki/Canonical_S-expressions} wikipedia}. 6 | These S-expressions are binary safe. 7 | 8 | @since 3.3 9 | *) 10 | 11 | type 'a or_error = ('a, string) result 12 | type 'a gen = unit -> 'a option 13 | 14 | module type SEXP = CCSexp_intf.BASIC_SEXP 15 | module type S = CCSexp_intf.S0 16 | 17 | (** {2 Parser and printer} *) 18 | module Make (Sexp : SEXP) : S with type t = Sexp.t 19 | 20 | (** {2 Basics} *) 21 | 22 | type t = [ `Atom of string | `List of t list ] 23 | (** A simple, structural representation of S-expressions. 24 | Compatible with {!CCSexp}. *) 25 | 26 | include S with type t := t 27 | 28 | val equal : t -> t -> bool 29 | val compare : t -> t -> int 30 | val atom : string -> t 31 | -------------------------------------------------------------------------------- /tests/core/t.ml: -------------------------------------------------------------------------------- 1 | Containers_testlib.run_all ~descr:"containers" 2 | [ 3 | T_list.get (); 4 | T_array.get (); 5 | T_bool.get (); 6 | T_byte_buffer.get (); 7 | T_canonical_sexp.get (); 8 | T_char.get (); 9 | T_either.get (); 10 | T_eq.get (); 11 | T_float.get (); 12 | T_format.get (); 13 | T_fun.get (); 14 | T_hash.get (); 15 | T_hashtbl.get (); 16 | T_heap.get (); 17 | T_IO.get (); 18 | T_int.get (); 19 | T_int32.get (); 20 | T_int64.get (); 21 | T_map.get (); 22 | T_nativeint.get (); 23 | T_option.get (); 24 | T_ord.get (); 25 | T_parse.get (); 26 | T_random.get (); 27 | T_result.get (); 28 | T_set.get (); 29 | T_seq.get (); 30 | T_sexp.get (); 31 | T_string.get (); 32 | T_utf8string.get (); 33 | T_vector.get (); 34 | T_bencode.get (); 35 | T_cbor.get (); 36 | T_unix.get (); 37 | ] 38 | -------------------------------------------------------------------------------- /src/data/CCMixset.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Set of Heterogeneous Values} *) 4 | 5 | module IMap = Map.Make (struct 6 | type t = int 7 | 8 | let compare : int -> int -> int = compare 9 | end) 10 | 11 | type t = (unit -> unit) IMap.t 12 | and 'a key = { id: int; mutable opt: 'a option } 13 | 14 | let newkey_n_ = ref 0 15 | 16 | let newkey () = 17 | let id = !newkey_n_ in 18 | incr newkey_n_; 19 | { id; opt = None } 20 | 21 | let empty = IMap.empty 22 | 23 | let get ~key set = 24 | key.opt <- None; 25 | try 26 | (IMap.find key.id set) (); 27 | key.opt 28 | with Not_found -> None 29 | 30 | let get_exn ~key set = 31 | match get ~key set with 32 | | None -> raise Not_found 33 | | Some v -> v 34 | 35 | let set ~key v set = IMap.add key.id (fun () -> key.opt <- Some v) set 36 | let cardinal set = IMap.cardinal set 37 | -------------------------------------------------------------------------------- /fuzz/run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | script_dir=$(dirname $(readlink -f "$0")) 4 | 5 | skip_build=$2 6 | 7 | if [[ "$skip_build" != "skip_build" ]]; then 8 | echo "Building" 9 | 10 | dune build @all 11 | fi 12 | 13 | if [[ "$1" == "" ]]; then 14 | echo "Please enter a fuzzing test to run" 15 | exit 1 16 | fi 17 | 18 | name=$(echo "$1" | sed 's/\.exe$//' | sed 's/\.ml$//') 19 | 20 | echo "Creating input directory" 21 | 22 | input_dir="$script_dir"/../"fuzz-""$name""-input" 23 | 24 | output_dir="$script_dir"/../"fuzz-""$name""-output" 25 | 26 | mkdir -p "$input_dir" 27 | 28 | echo "abcd" > "$input_dir"/dummy 29 | 30 | if [ -d "$output_dir" ]; then 31 | afl-fuzz -t 1000 -i - -o "$output_dir" "$script_dir"/../_build/default/fuzz/"$name".exe @@ 32 | else 33 | mkdir -p "$output_dir" 34 | 35 | afl-fuzz -t 1000 -i "$input_dir" -o "$output_dir" "$script_dir"/../_build/default/fuzz/"$name".exe @@ 36 | fi 37 | 38 | -------------------------------------------------------------------------------- /tests/data/t_hashset.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCHashSet;; 4 | 5 | t @@ fun () -> 6 | let module IS = Make (CCInt) in 7 | IS.cardinal (IS.create 10) = 0 8 | ;; 9 | 10 | t @@ fun () -> 11 | let module IS = Make (CCInt) in 12 | IS.find (IS.of_list [ 1; 2; 3 ]) 3 = Some 3 13 | ;; 14 | 15 | t @@ fun () -> 16 | let module IS = Make (CCInt) in 17 | IS.find (IS.of_list [ 1; 2; 3 ]) 5 = None 18 | ;; 19 | 20 | t @@ fun () -> 21 | let module IS = Make (CCInt) in 22 | IS.(equal (inter (of_list [ 1; 2; 3 ]) (of_list [ 2; 5; 4 ])) (of_list [ 2 ])) 23 | ;; 24 | 25 | t @@ fun () -> 26 | let module IS = Make (CCInt) in 27 | IS.( 28 | equal 29 | (union (of_list [ 1; 2; 3 ]) (of_list [ 2; 5; 4 ])) 30 | (of_list [ 1; 2; 3; 4; 5 ])) 31 | ;; 32 | 33 | t @@ fun () -> 34 | let module IS = Make (CCInt) in 35 | IS.(equal (diff (of_list [ 1; 2; 3 ]) (of_list [ 2; 4; 5 ])) (of_list [ 1; 3 ])) 36 | -------------------------------------------------------------------------------- /src/core/CCAtomic.ml: -------------------------------------------------------------------------------- 1 | [@@@ifge 4.12] 2 | 3 | include Atomic 4 | 5 | [@@@else_] 6 | 7 | open CCShims_.Stdlib (* for == *) 8 | 9 | type 'a t = { mutable x: 'a } 10 | 11 | let[@inline] make x = { x } 12 | let[@inline] get { x } = x 13 | let[@inline] set r x = r.x <- x 14 | 15 | let[@inline never] exchange r x = 16 | (* atomic *) 17 | let y = r.x in 18 | r.x <- x; 19 | (* atomic *) 20 | y 21 | 22 | let[@inline never] compare_and_set r seen v = 23 | (* atomic *) 24 | if r.x == seen then ( 25 | r.x <- v; 26 | (* atomic *) 27 | true 28 | ) else 29 | false 30 | 31 | let[@inline never] fetch_and_add r x = 32 | (* atomic *) 33 | let v = r.x in 34 | r.x <- x + r.x; 35 | (* atomic *) 36 | v 37 | 38 | let[@inline never] incr r = 39 | (* atomic *) 40 | r.x <- 1 + r.x 41 | (* atomic *) 42 | 43 | let[@inline never] decr r = 44 | (* atomic *) 45 | r.x <- r.x - 1 46 | (* atomic *) 47 | 48 | [@@@endif] 49 | -------------------------------------------------------------------------------- /src/scc/containers_scc.mli: -------------------------------------------------------------------------------- 1 | type 'a iter = ('a -> unit) -> unit 2 | 3 | module type ARG = sig 4 | type t 5 | type node 6 | 7 | val children : t -> node -> node iter 8 | 9 | module Node_tbl : Hashtbl.S with type key = node 10 | end 11 | 12 | module type S = sig 13 | module A : ARG 14 | 15 | val scc : A.t -> A.node list -> A.node list list 16 | end 17 | 18 | module Make (A : ARG) : S with module A = A 19 | 20 | val scc : 21 | tbl:(module Hashtbl.S with type key = 'node) -> 22 | graph:'graph -> 23 | children:('graph -> 'node -> 'node iter) -> 24 | nodes:'node list -> 25 | unit -> 26 | 'node list list 27 | (** Compute the strongly connected components of the given [graph], 28 | reachable from [nodes]. 29 | 30 | @param graph the graph state 31 | @param children maps a node to its direct descendants (children) 32 | @param nodes initial nodes. 33 | @param tbl a hashtable implementation that takes nodes as keys 34 | *) 35 | -------------------------------------------------------------------------------- /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master # Set a branch name to trigger deployment 7 | 8 | jobs: 9 | deploy: 10 | name: Deploy doc 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@main 14 | 15 | - name: Use OCaml 16 | uses: ocaml/setup-ocaml@v2 17 | with: 18 | ocaml-compiler: '4.14.x' 19 | dune-cache: false 20 | 21 | - name: Deps 22 | run: opam install odig containers containers-data containers-thread 23 | 24 | - name: Build 25 | run: opam exec -- odig odoc --cache-dir=_doc/ containers containers-data containers-thread 26 | 27 | - name: Deploy 28 | uses: peaceiris/actions-gh-pages@v3 29 | with: 30 | github_token: ${{ secrets.GITHUB_TOKEN }} 31 | publish_dir: ./_doc/html/ 32 | destination_dir: dev 33 | enable_jekyll: true 34 | -------------------------------------------------------------------------------- /.github/workflows/compat.yml: -------------------------------------------------------------------------------- 1 | name: compat 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | run: 11 | name: build 12 | strategy: 13 | fail-fast: true 14 | matrix: 15 | os: 16 | - ubuntu-latest 17 | ocaml-compiler: 18 | - '4.03.x' 19 | - '4.06.x' 20 | - '4.07.x' 21 | - '4.08.x' 22 | - '4.14.x' 23 | - '5.0.x' 24 | - 'ocaml-variants.5.0.0+options,ocaml-option-bytecode-only' 25 | 26 | runs-on: ${{ matrix.os }} 27 | steps: 28 | - uses: actions/checkout@main 29 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 30 | uses: ocaml/setup-ocaml@v2 31 | with: 32 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 33 | dune-cache: true 34 | 35 | - run: opam install containers containers-data containers-thread --deps-only 36 | - run: opam exec -- dune build '@install' 37 | -------------------------------------------------------------------------------- /src/core/tests/check_labelled_mods.ml: -------------------------------------------------------------------------------- 1 | module A = struct 2 | (* test consistency of interfaces *) 3 | module FA = CCArray.Floatarray 4 | 5 | module type L = module type of CCArray with module Floatarray := FA 6 | module type LL = module type of CCArrayLabels with module Floatarray := FA 7 | 8 | let () = ignore (module CCArrayLabels : L) 9 | let () = ignore (module CCArray : LL) 10 | end 11 | 12 | module S = struct 13 | (* test consistency of interfaces *) 14 | module type L = module type of CCString 15 | module type LL = module type of CCStringLabels 16 | 17 | let () = ignore (module CCStringLabels : L) 18 | let () = ignore (module CCString : LL) 19 | end 20 | 21 | module L = struct 22 | (* test consistency of interfaces *) 23 | module type L = module type of CCList 24 | module type LL = module type of CCListLabels 25 | 26 | let () = ignore (module CCListLabels : L) 27 | let () = ignore (module CCList : LL) 28 | end 29 | 30 | let () = print_endline "labelled modules are consistent ✔" 31 | -------------------------------------------------------------------------------- /src/cbor/containers_cbor.mli: -------------------------------------------------------------------------------- 1 | (** CBOR encoder/decoder. 2 | 3 | The type is chosen to be compatible with ocaml-cbor. 4 | See {{: https://www.rfc-editor.org/rfc/rfc8949.html} the RFC}. 5 | 6 | {b note} this is experimental. 7 | 8 | {b note} this is only available on OCaml >= 4.08. Below that, the module 9 | is empty. 10 | 11 | @since 3.9 12 | *) 13 | 14 | type t = 15 | [ `Null 16 | | `Undefined 17 | | `Simple of int 18 | | `Bool of bool 19 | | `Int of int64 20 | | `Float of float 21 | | `Bytes of string 22 | | `Text of string 23 | | `Array of t list 24 | | `Map of (t * t) list 25 | | `Tag of int * t ] 26 | 27 | val pp_diagnostic : t CCFormat.printer 28 | val to_string_diagnostic : t -> string 29 | 30 | (* we use funtions from Bytes *) 31 | [@@@ifge 4.08] 32 | 33 | val encode : ?buf:Buffer.t -> t -> string 34 | val decode : string -> (t, string) result 35 | 36 | val decode_exn : string -> t 37 | (** Like {!decode}. 38 | @raise Failure if the string isn't valid *) 39 | 40 | [@@@endif] 41 | -------------------------------------------------------------------------------- /src/core/CCRef.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 References} 4 | 5 | @since 0.9 *) 6 | 7 | type 'a printer = Format.formatter -> 'a -> unit 8 | type 'a ord = 'a -> 'a -> int 9 | type 'a eq = 'a -> 'a -> bool 10 | type 'a iter = ('a -> unit) -> unit 11 | type 'a t = 'a ref 12 | 13 | let create x = ref x 14 | let map f r = ref (f !r) 15 | let iter f r = f !r 16 | let update f r = r := f !r 17 | 18 | let incr_then_get r = 19 | incr r; 20 | !r 21 | 22 | let get_then_incr r = 23 | let x = !r in 24 | incr r; 25 | x 26 | 27 | let compare f r1 r2 = f !r1 !r2 28 | let equal f r1 r2 = f !r1 !r2 29 | 30 | let swap a b = 31 | let x = !a in 32 | a := !b; 33 | b := x 34 | 35 | let protect r x f = 36 | let old = !r in 37 | r := x; 38 | try 39 | let res = f () in 40 | r := old; 41 | res 42 | with e -> 43 | r := old; 44 | raise e 45 | 46 | let to_list r = [ !r ] 47 | let to_iter r yield = yield !r 48 | let pp pp_x out r = pp_x out !r 49 | -------------------------------------------------------------------------------- /src/testlib/containers_testlib.mli: -------------------------------------------------------------------------------- 1 | type 'a eq = 'a -> 'a -> bool 2 | type 'a print = 'a -> string 3 | 4 | module Test : sig 5 | type t 6 | end 7 | 8 | module type S = sig 9 | module Q = QCheck 10 | 11 | val t : ?name:string -> (unit -> bool) -> unit 12 | val eq : ?name:string -> ?cmp:'a eq -> ?printer:'a print -> 'a -> 'a -> unit 13 | 14 | val q : 15 | ?name:string -> 16 | ?count:int -> 17 | ?long_factor:int -> 18 | ?max_gen:int -> 19 | ?max_fail:int -> 20 | ?if_assumptions_fail:[ `Fatal | `Warning ] * float -> 21 | 'a Q.arbitrary -> 22 | ('a -> bool) -> 23 | unit 24 | 25 | val assert_equal : 26 | ?printer:('a -> string) -> ?cmp:('a -> 'a -> bool) -> 'a -> 'a -> unit 27 | 28 | val assert_bool : string -> bool -> unit 29 | val assert_failure : string -> 'a 30 | val assert_raises : (exn -> bool) -> (unit -> 'b) -> unit 31 | val get : unit -> Test.t list 32 | end 33 | 34 | val make : __FILE__:string -> unit -> (module S) 35 | 36 | val run_all : 37 | ?seed:string -> ?long:bool -> descr:string -> Test.t list list -> unit 38 | -------------------------------------------------------------------------------- /tests/core/t_map.ml: -------------------------------------------------------------------------------- 1 | module T = (val Containers_testlib.make ~__FILE__ ()) 2 | include T 3 | open CCMap 4 | module M = CCMap.Make (String) 5 | 6 | let eq' = eq ~printer:CCFormat.(to_string @@ Dump.(list (pair string int)));; 7 | 8 | eq' 9 | [ "a", 1; "b", 20 ] 10 | (M.of_list [ "b", 2; "c", 3 ] 11 | |> M.update "a" (function _ -> Some 1) 12 | |> M.update "c" (fun _ -> None) 13 | |> M.update "b" (CCOption.map (fun x -> x * 10)) 14 | |> M.to_list |> List.sort CCOrd.poly) 15 | 16 | module M2 = Make (CCInt);; 17 | 18 | q 19 | Q.(list (pair small_int small_int)) 20 | M2.( 21 | fun l -> to_list (of_list l) = to_list (of_list_with ~f:(fun _ v _ -> v) l)) 22 | ;; 23 | 24 | q 25 | Q.(list (pair small_int small_int)) 26 | M2.( 27 | fun l -> 28 | to_list (of_iter @@ Iter.of_list l) 29 | = to_list (of_iter_with ~f:(fun _ v _ -> v) @@ Iter.of_list l)) 30 | ;; 31 | 32 | q 33 | Q.(list (pair small_int small_int)) 34 | M2.( 35 | fun l -> 36 | to_list (of_seq @@ CCSeq.of_list l) 37 | = to_list (of_seq_with ~f:(fun _ v _ -> v) @@ CCSeq.of_list l)) 38 | -------------------------------------------------------------------------------- /containers-thread.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "3.11" 3 | author: "Simon Cruanes" 4 | maintainer: "simon.cruanes.2007@m4x.org" 5 | license: "BSD-2-Clause" 6 | synopsis: "An extension of containers for threading" 7 | build: [ 8 | ["dune" "build" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name ] {with-doc} 10 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 11 | ] 12 | depends: [ 13 | "ocaml" { >= "4.03.0" } 14 | "dune" { >= "2.0" } 15 | "base-threads" 16 | "dune-configurator" 17 | "containers" { = version } 18 | "iter" { with-test } 19 | (("ocaml" {with-test & < "4.08"} & "qcheck-core" {>= "0.17" & with-test}) 20 | | ("ocaml" {with-test & >= "4.08"} & "qcheck-core" {>= "0.18" & with-test})) 21 | "uutf" { with-test } 22 | "odoc" { with-doc } 23 | ] 24 | tags: [ "containers" "thread" "semaphore" "blocking queue" ] 25 | homepage: "https://github.com/c-cube/ocaml-containers/" 26 | doc: "https://c-cube.github.io/ocaml-containers" 27 | dev-repo: "git+https://github.com/c-cube/ocaml-containers.git" 28 | bug-reports: "https://github.com/c-cube/ocaml-containers/issues/" 29 | -------------------------------------------------------------------------------- /src/monomorphic/CCMonomorphic.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | [@@@ifge 4.07] 4 | [@@@else_] 5 | 6 | module Stdlib = Pervasives 7 | 8 | [@@@endif] 9 | 10 | let ( = ) : int -> int -> bool = Stdlib.( = ) 11 | let ( <> ) : int -> int -> bool = Stdlib.( <> ) 12 | let ( < ) : int -> int -> bool = Stdlib.( < ) 13 | let ( > ) : int -> int -> bool = Stdlib.( > ) 14 | let ( <= ) : int -> int -> bool = Stdlib.( <= ) 15 | let ( >= ) : int -> int -> bool = Stdlib.( >= ) 16 | let compare : int -> int -> int = Stdlib.compare 17 | let min : int -> int -> int = Stdlib.min 18 | let max : int -> int -> int = Stdlib.max 19 | let ( =. ) : float -> float -> bool = Stdlib.( = ) 20 | let ( <>. ) : float -> float -> bool = Stdlib.( <> ) 21 | let ( <. ) : float -> float -> bool = Stdlib.( < ) 22 | let ( >. ) : float -> float -> bool = Stdlib.( > ) 23 | let ( <=. ) : float -> float -> bool = Stdlib.( <= ) 24 | let ( >=. ) : float -> float -> bool = Stdlib.( >= ) 25 | let ( == ) = `Consider_using_CCEqual_physical 26 | let ( != ) = `Consider_using_CCEqual_physical 27 | -------------------------------------------------------------------------------- /src/threads/CCSemaphore.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Semaphores} 4 | 5 | @since 0.13 *) 6 | 7 | type t 8 | (** A semaphore *) 9 | 10 | val create : int -> t 11 | (** [create n] creates a semaphore with initial value [n]. 12 | @raise Invalid_argument if [n <= 0]. *) 13 | 14 | val get : t -> int 15 | (** Current value. *) 16 | 17 | val acquire : int -> t -> unit 18 | (** [acquire n s] blocks until [get s >= n], then atomically 19 | sets [s := !s - n]. *) 20 | 21 | val release : int -> t -> unit 22 | (** [release n s] atomically sets [s := !s + n]. *) 23 | 24 | val with_acquire : n:int -> t -> f:(unit -> 'a) -> 'a 25 | (** [with_acquire ~n s ~f] first acquires [s] with [n] units, 26 | calls [f ()], and then releases [s] with [n] units. 27 | Safely release the semaphore even if [f ()] fails. *) 28 | 29 | val wait_until_at_least : n:int -> t -> f:(unit -> 'a) -> 'a 30 | (** [wait_until_at_least ~n s ~f] waits until [get s >= n], then calls [f ()] 31 | and returns its result. Doesn't modify the semaphore. *) 32 | -------------------------------------------------------------------------------- /containers-data.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "3.11" 3 | author: "Simon Cruanes" 4 | maintainer: "simon.cruanes.2007@m4x.org" 5 | synopsis: "A set of advanced datatypes for containers" 6 | license: "BSD-2-Clause" 7 | build: [ 8 | ["dune" "build" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name ] {with-doc} 10 | ["dune" "runtest" "-p" name "-j" jobs] {with-test & arch != "x86_32" & arch != "arm32"} 11 | ] 12 | depends: [ 13 | "ocaml" { >= "4.03.0" } 14 | "dune" { >= "2.0" } 15 | "containers" { = version } 16 | "seq" 17 | (("ocaml" {with-test & < "4.08"} & "qcheck-core" {>= "0.17" & with-test}) 18 | | ("ocaml" {with-test & >= "4.08"} & "qcheck-core" {>= "0.18" & with-test})) 19 | "iter" { with-test } 20 | "gen" { with-test } 21 | "mdx" { with-test } 22 | "odoc" { with-doc } 23 | ] 24 | tags: [ "containers" "RAL" "functional" "vector" "okasaki" ] 25 | homepage: "https://github.com/c-cube/ocaml-containers/" 26 | doc: "https://c-cube.github.io/ocaml-containers" 27 | dev-repo: "git+https://github.com/c-cube/ocaml-containers.git" 28 | bug-reports: "https://github.com/c-cube/ocaml-containers/issues/" 29 | -------------------------------------------------------------------------------- /src/bencode/containers_bencode.mli: -------------------------------------------------------------------------------- 1 | (** Basic Bencode decoder/encoder. 2 | 3 | See https://en.wikipedia.org/wiki/Bencode . 4 | 5 | @since 3.8 *) 6 | 7 | module Str_map : module type of Map.Make (String) 8 | 9 | type t = Int of int64 | String of string | List of t list | Map of t Str_map.t 10 | 11 | val equal : t -> t -> bool 12 | val hash : t -> int 13 | 14 | val pp_debug : Format.formatter -> t -> unit 15 | (** Printer for diagnostic/human consumption *) 16 | 17 | val to_string_debug : t -> string 18 | val int : int -> t 19 | val int64 : int64 -> t 20 | val string : string -> t 21 | val list : t list -> t 22 | val map_of_list : (string * t) list -> t 23 | val map : t Str_map.t -> t 24 | 25 | (** Encoding *) 26 | module Encode : sig 27 | val to_string : t -> string 28 | val to_buffer : Buffer.t -> t -> unit 29 | val to_chan : out_channel -> t -> unit 30 | val to_fmt : Format.formatter -> t -> unit 31 | end 32 | 33 | (** Decoding *) 34 | module Decode : sig 35 | val of_string : string -> t option 36 | 37 | val of_string_exn : string -> t 38 | (** Parse string. 39 | @raise Failure if the string is not valid bencode. *) 40 | end 41 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names id_sexp ccparse_sexp ccparse_irclogs) 3 | (libraries containers) 4 | (flags :standard -warn-error -a+8)) 5 | 6 | (rule 7 | (alias runtest) 8 | (locks /ctest) 9 | (deps 10 | (source_tree test_data)) 11 | (action 12 | (ignore-stdout 13 | (run ./id_sexp.exe test_data/benchpress.sexp)))) 14 | 15 | (rule 16 | (alias runtest) 17 | (locks /ctest) 18 | (deps 19 | (source_tree test_data)) 20 | (action 21 | (ignore-stdout 22 | (run ./ccparse_sexp.exe test_data/benchpress.sexp)))) 23 | 24 | (rule 25 | (targets ccparse_irclogs.ml) 26 | (enabled_if 27 | (>= %{ocaml_version} "4.08")) 28 | (action 29 | (copy ccparse_irclogs_real.cond.ml %{targets}))) 30 | 31 | (rule 32 | (targets ccparse_irclogs.ml) 33 | (enabled_if 34 | (< %{ocaml_version} "4.08")) 35 | (action 36 | (with-stdout-to 37 | %{targets} 38 | (run echo "let() = print_endline {|ok|}")))) 39 | 40 | (rule 41 | (alias runtest) 42 | (locks /ctest) 43 | (deps 44 | (source_tree test_data)) 45 | (enabled_if 46 | (>= %{ocaml_version} "4.08")) 47 | (action 48 | (ignore-stdout 49 | (run ./ccparse_irclogs.exe test_data/irc-logs.txt)))) 50 | -------------------------------------------------------------------------------- /tests/core/t_result.ml: -------------------------------------------------------------------------------- 1 | open CCResult 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | t @@ fun () -> Error "ohno 42" = fail_printf "ohno %d" 42;; 6 | t @@ fun () -> Error "ohno 42" = fail_fprintf "ohno %d" 42;; 7 | 8 | eq (Error "error\ncontext:message(number 42, foo: true)") 9 | (add_ctxf "message(number %d, foo: %B)" 42 true (Error "error")) 10 | ;; 11 | 12 | t @@ fun () -> 13 | let called_with = ref None in 14 | let f e = called_with := Some e in 15 | iter_err f (Ok 1); 16 | assert (!called_with = None); 17 | iter_err f (Error 1); 18 | assert (!called_with = Some 1); 19 | true 20 | ;; 21 | 22 | t @@ fun () -> get_or_failwith (Ok 1) = 1;; 23 | 24 | t @@ fun () -> 25 | try 26 | ignore @@ get_or_failwith (Error "e"); 27 | false 28 | with Failure msg -> msg = "e" 29 | ;; 30 | 31 | eq (get_lazy (fun _ -> 2) (Ok 1)) 1;; 32 | eq (get_lazy (fun _ -> 2) (Error "error")) 2;; 33 | eq 42 (fold_ok ( + ) 2 (Ok 40));; 34 | eq 40 (fold_ok ( + ) 40 (Error "foo"));; 35 | eq (Ok []) (flatten_l []);; 36 | eq (Ok [ 1; 2; 3 ]) (flatten_l [ Ok 1; Ok 2; Ok 3 ]);; 37 | eq (Error "ohno") (flatten_l [ Ok 1; Error "ohno"; Ok 2; Ok 3; Error "wut" ]) 38 | -------------------------------------------------------------------------------- /src/core/CCSexp.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Handling S-expressions 4 | 5 | @since 3.0 moved into containers-core, previously in [containers.sexp] 6 | *) 7 | 8 | type 'a or_error = ('a, string) result 9 | type 'a gen = unit -> 'a option 10 | 11 | module type SEXP = CCSexp_intf.SEXP 12 | (** {2 Abstract representation of S-expressions (extended)} 13 | 14 | @since 2.7 *) 15 | 16 | module type S = CCSexp_intf.S 17 | (** {2 Operations over S-expressions} 18 | 19 | @since 2.7 *) 20 | 21 | (** {2 Functorized operations} 22 | 23 | This builds a parser and printer for S-expressions represented as 24 | in the [Sexp] argument. 25 | 26 | @since 2.7 27 | 28 | @since 3.4 re-bind [loc] to [Sexp.loc] 29 | *) 30 | module Make (Sexp : SEXP) : S with type t = Sexp.t and type loc = Sexp.loc 31 | 32 | (** {2 Basics} *) 33 | 34 | type t = [ `Atom of string | `List of t list ] 35 | (** A simple, structural representation of S-expressions. *) 36 | 37 | include S with type t := t 38 | 39 | val equal : t -> t -> bool 40 | (** @since 3.0 *) 41 | 42 | val compare : t -> t -> int 43 | (** @since 3.0 *) 44 | 45 | val atom : string -> t 46 | (** Build an atom directly from a string. *) 47 | -------------------------------------------------------------------------------- /tests/core/t_option.ml: -------------------------------------------------------------------------------- 1 | open CCOption 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | eq None (filter (( = ) 0) (Some 1));; 6 | eq (Some 0) (filter (( = ) 0) (Some 0));; 7 | eq None (filter (fun _ -> true) None);; 8 | 9 | eq 10 | (try 11 | get_exn_or "ohno" (None : unit option); 12 | false 13 | with Invalid_argument s -> s = "ohno") 14 | ;; 15 | 16 | t @@ fun () -> 123 = get_exn_or "yes" (Some 123);; 17 | t @@ fun () -> sequence_l [ None; Some 1; Some 2 ] = None;; 18 | t @@ fun () -> sequence_l [ Some 1; Some 2; Some 3 ] = Some [ 1; 2; 3 ];; 19 | t @@ fun () -> sequence_l [] = Some [];; 20 | t @@ fun () -> choice_iter (Iter.of_list [ None; Some 1; Some 2 ]) = Some 1;; 21 | t @@ fun () -> choice_iter Iter.empty = None;; 22 | t @@ fun () -> choice_iter (Iter.repeat None |> Iter.take 100) = None;; 23 | t @@ fun () -> choice_seq (CCSeq.of_list [ None; Some 1; Some 2 ]) = Some 1;; 24 | t @@ fun () -> choice_seq CCSeq.empty = None;; 25 | t @@ fun () -> choice_seq (CCSeq.repeat None |> CCSeq.take 100) = None;; 26 | t @@ fun () -> flatten None = None;; 27 | t @@ fun () -> flatten (Some None) = None;; 28 | t @@ fun () -> flatten (Some (Some 1)) = Some 1;; 29 | t @@ fun () -> return_if false 1 = None;; 30 | t @@ fun () -> return_if true 1 = Some 1 31 | -------------------------------------------------------------------------------- /tests/data/t_simplequeue.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCSimple_queue;; 4 | 5 | q 6 | Q.(list small_int) 7 | (fun l -> 8 | let q = of_list l in 9 | equal CCInt.equal (Gen.unfold pop q |> of_gen) q) 10 | ;; 11 | 12 | q 13 | Q.(list small_int) 14 | (fun l -> equal CCInt.equal (of_list l |> rev) (of_list (List.rev l))) 15 | ;; 16 | 17 | q 18 | Q.(list small_int) 19 | (fun l -> 20 | let q = of_list l in 21 | equal CCInt.equal q (q |> rev |> rev)) 22 | ;; 23 | 24 | q Q.(list small_int) (fun l -> length (of_list l) = List.length l);; 25 | 26 | q 27 | Q.(list small_int) 28 | (fun l -> equal CCInt.equal (of_list l) (List.fold_left snoc empty l)) 29 | ;; 30 | 31 | q 32 | Q.(list small_int) 33 | (fun l -> equal CCInt.equal (of_iter (Iter.of_list l)) (of_list l)) 34 | ;; 35 | 36 | q Q.(list small_int) (fun l -> l = (of_list l |> to_iter |> Iter.to_list));; 37 | 38 | q 39 | Q.(pair (list small_int) (list small_int)) 40 | (fun (l1, l2) -> equal CCInt.equal (of_list l1) (of_list l2) = (l1 = l2)) 41 | ;; 42 | 43 | q 44 | Q.(pair (list small_int) (list small_int)) 45 | (fun (l1, l2) -> 46 | equal CCInt.equal 47 | (append (of_list l1) (of_list l2)) 48 | (of_list (List.append l1 l2))) 49 | -------------------------------------------------------------------------------- /src/threads/CCSemaphore.ml: -------------------------------------------------------------------------------- 1 | (** {1 Semaphores} *) 2 | 3 | type t = { mutable n: int; mutex: Mutex.t; cond: Condition.t } 4 | 5 | let create n = 6 | if n <= 0 then invalid_arg "Semaphore.create"; 7 | { n; mutex = Mutex.create (); cond = Condition.create () } 8 | 9 | let get t = t.n 10 | 11 | (* assume [t.mutex] locked, try to acquire [t] *) 12 | let acquire_once_locked_ m t = 13 | while t.n < m do 14 | Condition.wait t.cond t.mutex 15 | done; 16 | assert (t.n >= m); 17 | t.n <- t.n - m; 18 | Condition.broadcast t.cond; 19 | Mutex.unlock t.mutex 20 | 21 | let acquire m t = 22 | Mutex.lock t.mutex; 23 | acquire_once_locked_ m t 24 | 25 | (* assume [t.mutex] locked, try to release [t] *) 26 | let release_once_locked_ m t = 27 | t.n <- t.n + m; 28 | Condition.broadcast t.cond; 29 | Mutex.unlock t.mutex 30 | 31 | let release m t = 32 | Mutex.lock t.mutex; 33 | release_once_locked_ m t; 34 | () 35 | 36 | let with_acquire ~n t ~f = 37 | acquire n t; 38 | try 39 | let x = f () in 40 | release n t; 41 | x 42 | with e -> 43 | release n t; 44 | raise e 45 | 46 | let wait_until_at_least ~n t ~f = 47 | Mutex.lock t.mutex; 48 | while t.n < n do 49 | Condition.wait t.cond t.mutex 50 | done; 51 | assert (t.n >= n); 52 | Mutex.unlock t.mutex; 53 | f () 54 | -------------------------------------------------------------------------------- /containers.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "containers" 3 | version: "3.11" 4 | author: "Simon Cruanes" 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | license: "BSD-2-Clause" 7 | synopsis: "A modular, clean and powerful extension of the OCaml standard library" 8 | build: [ 9 | ["dune" "build" "-p" name "-j" jobs] 10 | ["dune" "build" "@doc" "-p" name ] {with-doc} 11 | ["dune" "runtest" "-p" name "-j" jobs] {with-test & arch != "x86_32" & arch != "arm32"} 12 | ] 13 | depends: [ 14 | "ocaml" { >= "4.03.0" } 15 | "dune" { >= "2.0" } 16 | "dune-configurator" 17 | "seq" # compat 18 | "either" # compat 19 | (("ocaml" {with-test & < "4.08"} & "qcheck-core" {>= "0.17" & with-test}) 20 | | ("ocaml" {with-test & >= "4.08"} & "qcheck-core" {>= "0.18" & with-test})) 21 | "yojson" { with-test } 22 | "iter" { with-test } 23 | "gen" { with-test } 24 | "csexp" { with-test } 25 | "uutf" { with-test } 26 | "odoc" { with-doc } 27 | ] 28 | depopts: [ 29 | "base-unix" 30 | "base-threads" 31 | ] 32 | tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] 33 | homepage: "https://github.com/c-cube/ocaml-containers/" 34 | doc: "https://c-cube.github.io/ocaml-containers" 35 | dev-repo: "git+https://github.com/c-cube/ocaml-containers.git" 36 | bug-reports: "https://github.com/c-cube/ocaml-containers/issues/" 37 | -------------------------------------------------------------------------------- /src/core/CCEqual.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Equality Combinators} *) 4 | 5 | open CCShims_ 6 | 7 | type 'a t = 'a -> 'a -> bool 8 | 9 | let poly = Stdlib.( = ) 10 | let physical = Stdlib.( == ) 11 | let int : int t = ( = ) 12 | let string : string t = Stdlib.( = ) 13 | let bool : bool t = Stdlib.( = ) 14 | let float : float t = Stdlib.( = ) 15 | let unit () () = true 16 | 17 | let rec list f l1 l2 = 18 | match l1, l2 with 19 | | [], [] -> true 20 | | [], _ | _, [] -> false 21 | | x1 :: l1', x2 :: l2' -> f x1 x2 && list f l1' l2' 22 | 23 | let array eq a b = 24 | let rec aux i = 25 | if i = Array.length a then 26 | true 27 | else 28 | eq a.(i) b.(i) && aux (i + 1) 29 | in 30 | Array.length a = Array.length b && aux 0 31 | 32 | let option f o1 o2 = 33 | match o1, o2 with 34 | | None, None -> true 35 | | Some _, None | None, Some _ -> false 36 | | Some x, Some y -> f x y 37 | 38 | let pair f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 39 | let triple f g h (x1, y1, z1) (x2, y2, z2) = f x1 x2 && g y1 y2 && h z1 z2 40 | let map f eq x y = eq (f x) (f y) 41 | let always_eq _ _ = true 42 | let never_eq _ _ = false 43 | 44 | module Infix = struct 45 | let ( >|= ) x f = map f x 46 | end 47 | 48 | include Infix 49 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGES=containers,containers-data,containers-thread 2 | 3 | all: build test 4 | 5 | build: 6 | dune build @install -p $(PACKAGES) 7 | 8 | test: build 9 | dune runtest --display=quiet --cache=disabled --no-buffer --force 10 | 11 | clean: 12 | dune clean 13 | 14 | doc: 15 | dune build @doc 16 | 17 | BENCH_TARGETS=run_benchs.exe run_bench_hash.exe 18 | 19 | benchs: 20 | dune build $(addprefix benchs/, $(BENCH_TARGETS)) --profile=release 21 | @for i in $(BENCH_TARGETS) ; do ln -sf _build/default/benchs/$$i ; done 22 | 23 | examples: 24 | dune build examples/id_sexp.exe 25 | 26 | VERSION=$(shell awk '/^version:/ {print $$2}' containers.opam) 27 | 28 | update_next_tag: 29 | @echo "update version to $(VERSION)..." 30 | sed -i "s/NEXT_VERSION/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli) 31 | sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli) 32 | 33 | WATCH?="@src/all @tests/runtest" 34 | watch: 35 | @dune build "$(WATCH)" -w 36 | 37 | reindent: 38 | @which ocp-indent || ( echo "require ocp-indent" ; exit 1 ) 39 | @find src '(' -name '*.ml' -or -name '*.mli' ')' -type f -print0 | xargs -0 echo "reindenting: " 40 | @find src '(' -name '*.ml' -or -name '*.mli' ')' -type f -print0 | xargs -0 ocp-indent -i 41 | 42 | .PHONY: all benchs test clean build doc update_next_tag watch examples 43 | -------------------------------------------------------------------------------- /tests/thread/t_timer.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCTimer;; 4 | 5 | (* NOTE: could be tighter bounds, but travis' mac OS seems to be dog slow. *) 6 | 7 | t @@ fun () -> 8 | let start = Unix.gettimeofday () in 9 | let timer = create () in 10 | let res = CCLock.create 0 in 11 | let sem = CCSemaphore.create 1 in 12 | CCSemaphore.acquire 1 sem; 13 | let stop = ref 0. in 14 | every timer 0.1 ~f:(fun () -> 15 | if CCLock.incr_then_get res > 5 then ( 16 | stop := Unix.gettimeofday (); 17 | CCSemaphore.release 1 sem; 18 | raise ExitEvery 19 | )); 20 | CCSemaphore.acquire 1 sem; 21 | (* wait *) 22 | assert_equal ~printer:CCInt.to_string 6 (CCLock.get res); 23 | assert (!stop -. start >= 0.49999); 24 | assert (!stop -. start < 2.); 25 | true 26 | ;; 27 | 28 | t @@ fun () -> 29 | (* scenario: n := 1; n := n*4 ; n := n+2; res := n *) 30 | let timer = create () in 31 | let n = CCLock.create 1 in 32 | let res = CCLock.create 0 in 33 | after timer 0.3 ~f:(fun () -> CCLock.update n (fun x -> x + 2)); 34 | ignore 35 | (Thread.create 36 | (fun _ -> 37 | Thread.delay 0.4; 38 | CCLock.set res (CCLock.get n)) 39 | ()); 40 | after timer 0.1 ~f:(fun () -> CCLock.update n (fun x -> x * 4)); 41 | Thread.delay 0.6; 42 | assert_equal ~printer:Q.Print.int 6 (CCLock.get res); 43 | true 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Simon Cruanes 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. Redistributions in binary 9 | form must reproduce the above copyright notice, this list of conditions and 10 | the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 17 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 19 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 20 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 21 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 22 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /src/monomorphic/CCMonomorphic.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Shadow unsafe functions and operators from Stdlib} *) 4 | 5 | (** @since 2.0 *) 6 | 7 | val ( = ) : int -> int -> bool 8 | val ( <> ) : int -> int -> bool 9 | val ( < ) : int -> int -> bool 10 | val ( > ) : int -> int -> bool 11 | val ( <= ) : int -> int -> bool 12 | val ( >= ) : int -> int -> bool 13 | val compare : int -> int -> int 14 | val min : int -> int -> int 15 | val max : int -> int -> int 16 | 17 | (** {2 Infix operators for Floats} *) 18 | 19 | val ( =. ) : float -> float -> bool 20 | (** @since 2.1 *) 21 | 22 | val ( <>. ) : float -> float -> bool 23 | (** @since 2.1 *) 24 | 25 | val ( <. ) : float -> float -> bool 26 | (** @since 2.1 *) 27 | 28 | val ( >. ) : float -> float -> bool 29 | (** @since 2.1 *) 30 | 31 | val ( <=. ) : float -> float -> bool 32 | (** @since 2.1 *) 33 | 34 | val ( >=. ) : float -> float -> bool 35 | (** @since 2.1 *) 36 | 37 | (** {2 Shadow Dangerous Operators} *) 38 | 39 | val ( == ) : [ `Consider_using_CCEqual_physical ] 40 | [@@ocaml.deprecated "Please use CCEqual.physical or Stdlib.(==) instead."] 41 | 42 | val ( != ) : [ `Consider_using_CCEqual_physical ] 43 | [@@ocaml.deprecated 44 | "Please use [not CCEqual.physical] or Stdlib.(!=) instead."] 45 | (** @since 2.1 *) 46 | -------------------------------------------------------------------------------- /src/core/CCPair.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Tuple Functions} *) 4 | 5 | type ('a, 'b) t = 'a * 'b 6 | 7 | let make x y = x, y 8 | let map_fst f (x, y) = f x, y 9 | let map_snd f (x, y) = x, f y 10 | let map f g (x, y) = f x, g y 11 | let map_same f (x, y) = f x, f y 12 | let map2 f g (a, b) (x, y) = f a x, g b y 13 | let map_same2 f (a, b) (x, y) = f a x, f b y 14 | let fst_map f (x, _) = f x 15 | let snd_map f (_, x) = f x 16 | let iter f (x, y) = f x y 17 | let swap (x, y) = y, x 18 | let ( <<< ) = map_fst 19 | let ( >>> ) = map_snd 20 | let ( *** ) = map 21 | let ( &&& ) f g x = f x, g x 22 | let merge f (x, y) = f x y 23 | let fold = merge 24 | let dup x = x, x 25 | let dup_map f x = x, f x 26 | let equal f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 27 | 28 | let compare f g (x1, y1) (x2, y2) = 29 | let c = f x1 x2 in 30 | if c <> 0 then 31 | c 32 | else 33 | g y1 y2 34 | 35 | let to_string ?(sep = ", ") a_to_string b_to_string (x, y) = 36 | Printf.sprintf "%s%s%s" (a_to_string x) sep (b_to_string y) 37 | 38 | type 'a printer = Format.formatter -> 'a -> unit 39 | 40 | let pp ?(pp_start = fun _ () -> ()) ?(pp_stop = fun _ () -> ()) 41 | ?(pp_sep = fun out () -> Format.fprintf out ",@ ") pa pb out (x, y) = 42 | pp_start out (); 43 | pa out x; 44 | pp_sep out (); 45 | pb out y; 46 | pp_stop out () 47 | -------------------------------------------------------------------------------- /src/core/tests/test_random.ml: -------------------------------------------------------------------------------- 1 | open CCRandom 2 | 3 | let uniformity_test ?(size_hint = 10) k rng st = 4 | let histogram = Hashtbl.create size_hint in 5 | let add x = 6 | let n = try Hashtbl.find histogram x with Not_found -> 0 in 7 | Hashtbl.replace histogram x (n + 1) 8 | in 9 | let () = 10 | for _i = 0 to k - 1 do 11 | add (rng st) 12 | done 13 | in 14 | let cardinal = float_of_int (Hashtbl.length histogram) in 15 | let kf = float_of_int k in 16 | (* average number of points assuming an uniform distribution *) 17 | let average = kf /. cardinal in 18 | (* The number of points is a sum of random variables with binomial distribution *) 19 | let p = 1. /. cardinal in 20 | (* The variance of a binomial distribution with average p is *) 21 | let variance = p *. (1. -. p) in 22 | (* Central limit theorem: a confidence interval of 4σ provides a false positive rate 23 | of 0.00634% *) 24 | let confidence = 4. in 25 | let std = confidence *. sqrt (kf *. variance) in 26 | let predicate _key n acc = 27 | let ( < ) (a : float) b = CCShims_.Stdlib.( < ) a b in 28 | acc && abs_float (average -. float_of_int n) < std 29 | in 30 | Hashtbl.fold predicate histogram true 31 | 32 | let () = 33 | let st = Random.State.make_self_init () in 34 | let ok = run ~st (uniformity_test 50_000 (split_list 10 ~len:3)) in 35 | if not ok then failwith "uniformity check failed" 36 | -------------------------------------------------------------------------------- /src/threads/CCTimer.mli: -------------------------------------------------------------------------------- 1 | (** Event timer 2 | 3 | Used to be part of [CCFuture]. 4 | @since 0.16 *) 5 | 6 | type t 7 | (** A scheduler for events. It runs in its own thread. *) 8 | 9 | val create : unit -> t 10 | (** A new timer. *) 11 | 12 | val set_exn_handler : t -> (exn -> unit) -> unit 13 | (** [set_exn_handler timer f] registers [f] so that any exception 14 | raised by a task scheduled in [timer] is given to [f]. *) 15 | 16 | exception Stopped 17 | 18 | val after : t -> float -> f:(unit -> _) -> unit 19 | (** Call the callback [f] after the given number of seconds. 20 | @raise Stopped if the timer was stopped. *) 21 | 22 | val at : t -> float -> f:(unit -> _) -> unit 23 | (** Create a future that evaluates to [()] at the given Unix timestamp. 24 | @raise Stopped if the timer was stopped. *) 25 | 26 | exception ExitEvery 27 | 28 | val every : ?delay:float -> t -> float -> f:(unit -> _) -> unit 29 | (** [every timer n ~f] calls [f ()] every [n] seconds. 30 | [f()] can raise ExitEvery to stop the cycle. 31 | @param delay if provided, the first call to [f ()] is delayed by 32 | that many seconds. 33 | @raise Stopped if the timer was stopped. *) 34 | 35 | val stop : t -> unit 36 | (** Stop the given timer, cancelling pending tasks. Idempotent. 37 | From now on, calling most other operations on the timer will raise Stopped. *) 38 | 39 | val active : t -> bool 40 | (** Return [true] until [stop t] has been called. *) 41 | -------------------------------------------------------------------------------- /src/threads/CCThread.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Threads} *) 4 | 5 | type t = Thread.t 6 | 7 | let spawn f = Thread.create f () 8 | let spawn1 f x = Thread.create f x 9 | let spawn2 f x y = Thread.create (fun () -> f x y) () 10 | let detach f = ignore (Thread.create f ()) 11 | 12 | let finally_ f x ~h = 13 | try 14 | let res = f x in 15 | ignore (h ()); 16 | res 17 | with e -> 18 | ignore (h ()); 19 | raise e 20 | 21 | module Arr = struct 22 | let spawn n f = Array.init n (fun i -> Thread.create f i) 23 | let join a = Array.iter Thread.join a 24 | end 25 | 26 | module Barrier = struct 27 | type t = { lock: Mutex.t; cond: Condition.t; mutable activated: bool } 28 | 29 | let create () = 30 | { lock = Mutex.create (); cond = Condition.create (); activated = false } 31 | 32 | let with_lock_ b f = 33 | Mutex.lock b.lock; 34 | finally_ f () ~h:(fun () -> Mutex.unlock b.lock) 35 | 36 | let reset b = with_lock_ b (fun () -> b.activated <- false) 37 | 38 | let wait b = 39 | with_lock_ b (fun () -> 40 | while not b.activated do 41 | Condition.wait b.cond b.lock 42 | done) 43 | 44 | let activate b = 45 | with_lock_ b (fun () -> 46 | if not b.activated then ( 47 | b.activated <- true; 48 | Condition.broadcast b.cond 49 | )) 50 | 51 | let activated b = with_lock_ b (fun () -> b.activated) 52 | end 53 | -------------------------------------------------------------------------------- /tests/data/t_bitfield.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCBitField;; 4 | 5 | t @@ fun () -> 6 | let module B = CCBitField.Make () in 7 | let x = B.mk_field () in 8 | let y = B.mk_field () in 9 | let z = B.mk_field () in 10 | 11 | let f = B.empty |> B.set x true |> B.set y true in 12 | 13 | assert_bool "z_false" (not (B.get z f)); 14 | 15 | assert_bool "z_true" (f |> B.set z true |> B.get z); 16 | true 17 | ;; 18 | 19 | t @@ fun () -> 20 | let module B = CCBitField.Make () in 21 | let _ = B.mk_field () in 22 | B.freeze (); 23 | assert_bool "must raise" 24 | (try 25 | ignore (B.mk_field ()); 26 | false 27 | with Frozen -> true); 28 | true 29 | ;; 30 | 31 | t @@ fun () -> 32 | let module B = CCBitField.Make () in 33 | let x = B.mk_field () in 34 | let y = B.mk_field () in 35 | let z = B.mk_field () in 36 | let u = B.mk_field () in 37 | B.freeze (); 38 | 39 | let f = B.empty |> B.set y true |> B.set z true in 40 | 41 | assert_equal ~printer:CCInt.to_string 6 (f :> int); 42 | 43 | assert_equal false (B.get x f); 44 | assert_equal true (B.get y f); 45 | assert_equal true (B.get z f); 46 | 47 | let f' = B.set u true f in 48 | 49 | assert_equal false (B.get x f'); 50 | assert_equal true (B.get y f'); 51 | assert_equal true (B.get z f'); 52 | assert_equal true (B.get u f'); 53 | true 54 | ;; 55 | 56 | t @@ fun () -> all_bits_ 0 1 = 1;; 57 | t @@ fun () -> all_bits_ 0 2 = 3;; 58 | t @@ fun () -> all_bits_ 0 3 = 7;; 59 | t @@ fun () -> all_bits_ 0 4 = 15 60 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Build and Test 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | run: 11 | name: build 12 | strategy: 13 | fail-fast: true 14 | matrix: 15 | os: 16 | - macos-latest 17 | - ubuntu-latest 18 | #- windows-latest 19 | ocaml-compiler: 20 | - '4.03.x' 21 | - '4.14.x' 22 | - '5.0.x' 23 | - 'ocaml-variants.5.0.0+options,ocaml-option-bytecode-only' 24 | 25 | runs-on: ${{ matrix.os }} 26 | steps: 27 | - uses: actions/checkout@main 28 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 29 | uses: ocaml/setup-ocaml@v2 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 32 | dune-cache: true 33 | 34 | - run: opam install -t containers containers-data containers-thread --deps-only 35 | if: matrix.os == 'ubuntu-latest' 36 | 37 | - run: | 38 | opam install -t containers --deps-only ; 39 | opam install containers-data containers-thread --deps-only # no test deps 40 | if: matrix.os != 'ubuntu-latest' 41 | 42 | - run: opam exec -- dune build '@install' 43 | 44 | - run: opam exec -- dune runtest 45 | if: ${{ matrix.os == 'ubuntu-latest' }} 46 | 47 | - run: opam exec -- dune runtest -j 1 -p containers # test only core on non-ubuntu platform 48 | if: ${{ matrix.os != 'ubuntu-latest' }} 49 | 50 | -------------------------------------------------------------------------------- /tests/data/t_cache.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCCache;; 4 | 5 | t @@ fun () -> 6 | let c = unbounded ~eq:Int64.equal 256 in 7 | let fib = 8 | with_cache_rec c (fun self n -> 9 | match n with 10 | | 1L | 2L -> 1L 11 | | _ -> CCInt64.(self (n - 1L) + self (n - 2L))) 12 | in 13 | assert_equal 55L (fib 10L); 14 | assert_equal 832040L (fib 30L); 15 | assert_equal 12586269025L (fib 50L); 16 | assert_equal 190392490709135L (fib 70L); 17 | true 18 | ;; 19 | 20 | t @@ fun () -> 21 | let eq (i1, _) (i2, _) = i1 = i2 and hash (i, _) = CCInt.hash i in 22 | let c = lru ~eq ~hash 2 in 23 | ignore (with_cache c CCFun.id (1, true)); 24 | ignore (with_cache c CCFun.id (1, false)); 25 | with_cache c CCFun.id (1, false) = (1, true) 26 | ;; 27 | 28 | t @@ fun () -> 29 | let f = 30 | let r = ref 0 in 31 | fun _ -> 32 | incr r; 33 | !r 34 | in 35 | let c = lru ~eq:CCInt.equal 2 in 36 | let res1 = with_cache c f 1 in 37 | let res2 = with_cache c f 2 in 38 | let res3 = with_cache c f 3 in 39 | let res1_bis = with_cache c f 1 in 40 | res1 <> res2 && res2 <> res3 && res3 <> res1_bis && res1_bis <> res1 41 | ;; 42 | 43 | t @@ fun () -> 44 | let f = 45 | let r = ref 0 in 46 | fun _ -> 47 | incr r; 48 | !r 49 | in 50 | let c = lru ~eq:CCEqual.unit 2 in 51 | let x = with_cache c f () in 52 | assert_equal 1 x; 53 | assert_equal 1 (size c); 54 | clear c; 55 | assert_equal 0 (size c); 56 | let y = with_cache c f () in 57 | assert_equal 2 y; 58 | true 59 | -------------------------------------------------------------------------------- /src/core/CCRef.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Helpers for references 4 | @since 0.9 *) 5 | 6 | type 'a printer = Format.formatter -> 'a -> unit 7 | type 'a ord = 'a -> 'a -> int 8 | type 'a eq = 'a -> 'a -> bool 9 | type 'a iter = ('a -> unit) -> unit 10 | type 'a t = 'a ref 11 | 12 | val map : ('a -> 'b) -> 'a t -> 'b t 13 | (** Transform the value. *) 14 | 15 | val create : 'a -> 'a t 16 | (** Alias to {!ref}. *) 17 | 18 | val iter : ('a -> unit) -> 'a t -> unit 19 | (** Call the function on the content of the reference. *) 20 | 21 | val update : ('a -> 'a) -> 'a t -> unit 22 | (** Update the reference's content with the given function. *) 23 | 24 | val incr_then_get : int t -> int 25 | (** [incr_then_get r] increments [r] and returns its new value, think [++r]. 26 | @since 0.17 *) 27 | 28 | val get_then_incr : int t -> int 29 | (** [get_then_incr r] increments [r] and returns its old value, think [r++]. 30 | @since 0.17 *) 31 | 32 | val swap : 'a t -> 'a t -> unit 33 | (** [swap t1 t2] puts [!t2] in [t1] and [!t1] in [t2]. 34 | @since 1.4 *) 35 | 36 | val protect : 'a t -> 'a -> (unit -> 'b) -> 'b 37 | (** [protect r x f] sets [r := x]; calls [f()]; restores [r] to its old value; 38 | and returns the result of [f()]. 39 | @since 3.10 *) 40 | 41 | val compare : 'a ord -> 'a t ord 42 | val equal : 'a eq -> 'a t eq 43 | val to_list : 'a t -> 'a list 44 | 45 | val to_iter : 'a t -> 'a iter 46 | (** @since 3.0 *) 47 | 48 | val pp : 'a printer -> 'a t printer 49 | -------------------------------------------------------------------------------- /src/core/containersLabels.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Drop-In replacement to Stdlib *) 4 | 5 | module Array = CCArrayLabels 6 | module Bool = CCBool 7 | module Byte_buffer = CCByte_buffer 8 | module Char = CCChar 9 | module Equal = CCEqualLabels 10 | module Either = CCEither 11 | module Float = CCFloat 12 | module Format = CCFormat 13 | module Fun = CCFun 14 | module Hash = CCHash 15 | 16 | (** @since 0.14 *) 17 | module Hashtbl = struct 18 | include ( 19 | Hashtbl : 20 | module type of Hashtbl 21 | with type statistics = Hashtbl.statistics 22 | and module Make = Hashtbl.Make 23 | and type ('a, 'b) t = ('a, 'b) Hashtbl.t) 24 | 25 | include CCHashtbl.Poly 26 | 27 | module type S' = CCHashtbl.S 28 | 29 | module Make' = CCHashtbl.Make 30 | end 31 | 32 | module Heap = CCHeap 33 | module Int = CCInt 34 | module Int32 = CCInt32 35 | module Int64 = CCInt64 36 | module IO = CCIO 37 | module List = CCListLabels 38 | module Map = CCMap 39 | module Nativeint = CCNativeint 40 | module Option = CCOption 41 | module Ord = CCOrd 42 | module Pair = CCPair 43 | module Parse = CCParse 44 | module Random = CCRandom 45 | module Ref = CCRef 46 | module Result = CCResult 47 | module Seq = CCSeq 48 | module Set = CCSet 49 | module String = CCStringLabels 50 | module Vector = CCVector 51 | module Monomorphic = CCMonomorphic 52 | module Utf8_string = CCUtf8_string 53 | module Sexp = CCSexp 54 | module Sexp_intf = CCSexp_intf 55 | module Stdlib = CCShims_.Stdlib 56 | include Monomorphic 57 | -------------------------------------------------------------------------------- /src/data/CCMixset.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Set of Heterogeneous Values 4 | 5 | {[ 6 | let k1 : int key = newkey () in 7 | let k2 : int key = newkey () in 8 | let k3 : string key = newkey () in 9 | let set = 10 | empty 11 | |> set ~key:k1 1 12 | |> set ~key:k2 2 13 | |> set ~key:k3 "3" 14 | in 15 | assert (get ~key:k1 set = Some 1); 16 | assert (get ~key:k2 set = Some 2); 17 | assert (get ~key:k3 set = Some "3"); 18 | () 19 | ]} 20 | 21 | @since 0.11 *) 22 | 23 | type t 24 | (** A set of values of heterogeneous types *) 25 | 26 | type 'a key 27 | (** A unique "key" to access a value of type ['a] in a [set] *) 28 | 29 | val newkey : unit -> 'a key 30 | (** [newkey ()] creates a new unique key that can be used to access 31 | a ['a] value in a set. Each key created with [newkey] is distinct 32 | from any other key, even if they have the same type. 33 | 34 | Not thread-safe. *) 35 | 36 | val empty : t 37 | (** Empty set. *) 38 | 39 | val set : key:'a key -> 'a -> t -> t 40 | (** [set ~key v set] maps [key] to [v] in [set]. It means that 41 | for every [set], [get ~key (set ~key v set) = Some v]. *) 42 | 43 | val get : key:'a key -> t -> 'a option 44 | (** [get ~key set] obtains the value for [key] in [set], if any. *) 45 | 46 | val get_exn : key:'a key -> t -> 'a 47 | (** Same as {!get}, but can fail. 48 | @raise Not_found if the key is not present. *) 49 | 50 | val cardinal : t -> int 51 | (** Number of mappings. *) 52 | -------------------------------------------------------------------------------- /src/core/CCEqualLabels.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Equality Combinators (Labeled version of {!CCEqual}) *) 4 | 5 | (** @since 1.2 *) 6 | 7 | type 'a t = 'a -> 'a -> bool 8 | (** Equality function. Must be transitive, symmetric, and reflexive. *) 9 | 10 | val poly : 'a t 11 | (** Standard polymorphic equality. *) 12 | 13 | val physical : 'a t 14 | (** Standard physical equality. 15 | @since 2.0 *) 16 | 17 | val int : int t 18 | val string : string t 19 | val bool : bool t 20 | val float : float t 21 | val unit : unit t 22 | val list : 'a t -> 'a list t 23 | val array : 'a t -> 'a array t 24 | val option : 'a t -> 'a option t 25 | val pair : 'a t -> 'b t -> ('a * 'b) t 26 | val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 27 | 28 | val map : f:('a -> 'b) -> 'b t -> 'a t 29 | (** [map f eq] is the equality function that, given objects [x] and [y], 30 | projects [x] and [y] using [f] (e.g. using a record field) and then 31 | compares those projections with [eq]. 32 | Example: 33 | [map fst int] compares values of type [(int * 'a)] by their 34 | first component. *) 35 | 36 | val always_eq : _ t 37 | (** Always returns true. All values are equal. 38 | @since 3.9 *) 39 | 40 | val never_eq : _ t 41 | (** Always returns false. No values are, so this 42 | is not even reflexive (i.e. [x=x] is false). 43 | Be careful! 44 | @since 3.9 *) 45 | 46 | module Infix : sig 47 | val ( >|= ) : 'b t -> ('a -> 'b) -> 'a t 48 | (** Infix equivalent of {!map}. *) 49 | end 50 | 51 | include module type of Infix 52 | -------------------------------------------------------------------------------- /src/core/CCEqual.mli: -------------------------------------------------------------------------------- 1 | (* AUTOGENERATED FROM CCEqualLabels.mli *) 2 | 3 | (* This file is free software, part of containers. See file "license" for more details. *) 4 | 5 | (** Equality Combinators *) 6 | 7 | (** @since 1.2 *) 8 | 9 | type 'a t = 'a -> 'a -> bool 10 | (** Equality function. Must be transitive, symmetric, and reflexive. *) 11 | 12 | val poly : 'a t 13 | (** Standard polymorphic equality. *) 14 | 15 | val physical : 'a t 16 | (** Standard physical equality. 17 | @since 2.0 *) 18 | 19 | val int : int t 20 | val string : string t 21 | val bool : bool t 22 | val float : float t 23 | val unit : unit t 24 | val list : 'a t -> 'a list t 25 | val array : 'a t -> 'a array t 26 | val option : 'a t -> 'a option t 27 | val pair : 'a t -> 'b t -> ('a * 'b) t 28 | val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 29 | 30 | val map : ('a -> 'b) -> 'b t -> 'a t 31 | (** [map f eq] is the equality function that, given objects [x] and [y], 32 | projects [x] and [y] using [f] (e.g. using a record field) and then 33 | compares those projections with [eq]. 34 | Example: 35 | [map fst int] compares values of type [(int * 'a)] by their 36 | first component. *) 37 | 38 | val always_eq : _ t 39 | (** Always returns true. All values are equal. 40 | @since 3.0 *) 41 | 42 | val never_eq : _ t 43 | (** Always returns false. No values are, so this 44 | is not even reflexive (i.e. [x=x] is false). 45 | Be careful! 46 | @since 3.0 *) 47 | 48 | module Infix : sig 49 | val ( >|= ) : 'b t -> ('a -> 'b) -> 'a t 50 | (** Infix equivalent of {!map}. *) 51 | end 52 | 53 | include module type of Infix 54 | -------------------------------------------------------------------------------- /src/data/CCMutHeap_intf.ml: -------------------------------------------------------------------------------- 1 | (* This code is extracted from Msat ( https://github.com/Gbury/mSAT ). *) 2 | 3 | (** {1 Imperative Heaps} *) 4 | 5 | module type RANKED = sig 6 | type t 7 | 8 | val idx : t -> int 9 | (** Index in heap. return -1 if never set *) 10 | 11 | val set_idx : t -> int -> unit 12 | (** Update index in heap *) 13 | 14 | val lt : t -> t -> bool 15 | (** [cmp a b] is true iff [a < b] *) 16 | end 17 | 18 | module type S = sig 19 | type elt 20 | (** Type of elements *) 21 | 22 | type t 23 | (** Heap of {!elt}, whose priority is increased or decreased 24 | incrementally (see {!decrease} for instance) *) 25 | 26 | val create : unit -> t 27 | (** Create a heap *) 28 | 29 | val decrease : t -> elt -> unit 30 | (** [decrease h x] decreases the value associated to [x] within [h] *) 31 | 32 | val increase : t -> elt -> unit 33 | (** [increase h x] increases the value associated to [x] within [h] *) 34 | 35 | val in_heap : elt -> bool 36 | 37 | val size : t -> int 38 | (** Number of integers within the heap *) 39 | 40 | val is_empty : t -> bool 41 | 42 | val clear : t -> unit 43 | (** Clear the content of the heap *) 44 | 45 | val insert : t -> elt -> unit 46 | (** Insert a new element into the heap *) 47 | 48 | (*val update : (int -> int -> bool) -> t -> int -> unit*) 49 | 50 | val remove_min : t -> elt 51 | (** Remove and return the integer that has the lowest value from the heap 52 | @raise Not_found if the heap is empty *) 53 | 54 | val filter : t -> (elt -> bool) -> unit 55 | (** Filter out values that don't satisfy the predicate *) 56 | end 57 | -------------------------------------------------------------------------------- /src/core/containers.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Drop-In replacement to Stdlib *) 4 | 5 | module Array = CCArray 6 | module Bool = CCBool 7 | module Byte_buffer = CCByte_buffer 8 | module Char = CCChar 9 | module Equal = CCEqual 10 | module Either = CCEither 11 | module Float = CCFloat 12 | module Format = CCFormat 13 | module Fun = CCFun 14 | module Hash = CCHash 15 | 16 | (** @since 0.14 *) 17 | module Hashtbl = struct 18 | include ( 19 | Hashtbl : 20 | module type of Hashtbl 21 | with type statistics = Hashtbl.statistics 22 | and module Make = Hashtbl.Make 23 | and type ('a, 'b) t = ('a, 'b) Hashtbl.t) 24 | 25 | include CCHashtbl.Poly 26 | 27 | module type S' = CCHashtbl.S 28 | 29 | module Make' = CCHashtbl.Make 30 | end 31 | 32 | module Heap = CCHeap 33 | module Int = CCInt 34 | module Int32 = CCInt32 35 | module Int64 = CCInt64 36 | module IO = CCIO 37 | module List = CCList 38 | module Map = CCMap 39 | module Nativeint = CCNativeint 40 | module Option = CCOption 41 | module Ord = CCOrd 42 | module Pair = CCPair 43 | module Parse = CCParse 44 | module Random = CCRandom 45 | module Ref = CCRef 46 | module Result = CCResult 47 | module Seq = CCSeq 48 | module Set = CCSet 49 | module String = CCString 50 | module Vector = CCVector 51 | module Monomorphic = CCMonomorphic 52 | module Utf8_string = CCUtf8_string 53 | module Unit = CCUnit 54 | module Atomic = CCAtomic 55 | module Sexp = CCSexp 56 | module Sexp_intf = CCSexp_intf 57 | module Canonical_sexp = CCCanonical_sexp 58 | module Stdlib = CCShims_.Stdlib 59 | include Monomorphic 60 | -------------------------------------------------------------------------------- /src/data/CCZipper.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 List Zipper} *) 4 | 5 | type 'a t = 'a list * 'a list 6 | 7 | let empty = [], [] 8 | 9 | let is_empty = function 10 | | [], [] -> true 11 | | _ -> false 12 | 13 | let to_list (l, r) = List.rev_append l r 14 | let to_rev_list (l, r) = List.rev_append r l 15 | let make l = [], l 16 | 17 | let left = function 18 | | x :: l, r -> l, x :: r 19 | | [], r -> [], r 20 | 21 | let left_exn = function 22 | | x :: l, r -> l, x :: r 23 | | [], _ -> invalid_arg "zipper.left_exn" 24 | 25 | let right = function 26 | | l, x :: r -> x :: l, r 27 | | l, [] -> l, [] 28 | 29 | let right_exn = function 30 | | l, x :: r -> x :: l, r 31 | | _, [] -> invalid_arg "zipper.right_exn" 32 | 33 | let modify f z = 34 | match z with 35 | | l, [] -> 36 | (match f None with 37 | | None -> z 38 | | Some x -> l, [ x ]) 39 | | l, x :: r -> 40 | (match f (Some x) with 41 | | None -> l, r 42 | | Some _ -> l, x :: r) 43 | 44 | let is_focused = function 45 | | _, _ :: _ -> true 46 | | _, [] -> false 47 | 48 | let focused = function 49 | | _, x :: _ -> Some x 50 | | _, [] -> None 51 | 52 | let focused_exn = function 53 | | _, x :: _ -> x 54 | | _, [] -> raise Not_found 55 | 56 | let insert x (l, r) = l, x :: r 57 | 58 | let remove (l, r) = 59 | match r with 60 | | [] -> l, [] 61 | | _ :: r' -> l, r' 62 | 63 | let drop_before (_, r) = [], r 64 | 65 | let drop_after (l, r) = 66 | match r with 67 | | [] -> l, [] 68 | | x :: _ -> l, [ x ] 69 | 70 | let drop_after_and_focused (l, _) = l, [] 71 | -------------------------------------------------------------------------------- /tests/thread/t_bq.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCBlockingQueue;; 4 | 5 | t @@ fun () -> 6 | let q = create 1 in 7 | let t1 = 8 | CCThread.spawn (fun () -> 9 | push q 1; 10 | push q 2) 11 | in 12 | let t2 = 13 | CCThread.spawn (fun () -> 14 | push q 3; 15 | push q 4) 16 | in 17 | let l = CCLock.create [] in 18 | let t3 = 19 | CCThread.spawn (fun () -> 20 | for _i = 1 to 4 do 21 | let x = take q in 22 | CCLock.update l (fun l -> x :: l) 23 | done) 24 | in 25 | Thread.join t1; 26 | Thread.join t2; 27 | Thread.join t3; 28 | assert_equal [ 1; 2; 3; 4 ] (List.sort Stdlib.compare (CCLock.get l)); 29 | true 30 | ;; 31 | 32 | t @@ fun () -> 33 | let n = 1000 in 34 | let lists = 35 | [| 36 | CCList.(1 -- n); CCList.(n + 1 -- (2 * n)); CCList.((2 * n) + 1 -- (3 * n)); 37 | |] 38 | in 39 | let q = create 2 in 40 | let senders = 41 | CCThread.Arr.spawn 3 (fun i -> 42 | if i = 1 then 43 | push_list q lists.(i) 44 | (* test push_list *) 45 | else 46 | List.iter (push q) lists.(i)) 47 | in 48 | let res = CCLock.create [] in 49 | let receivers = 50 | CCThread.Arr.spawn 3 (fun i -> 51 | if i = 1 then ( 52 | let l = take_list q n in 53 | CCLock.update res (fun acc -> l @ acc) 54 | ) else 55 | for _j = 1 to n do 56 | let x = take q in 57 | CCLock.update res (fun acc -> x :: acc) 58 | done) 59 | in 60 | CCThread.Arr.join senders; 61 | CCThread.Arr.join receivers; 62 | let l = CCLock.get res |> List.sort Stdlib.compare in 63 | assert_equal CCList.(1 -- (3 * n)) l; 64 | true 65 | -------------------------------------------------------------------------------- /tests/core/t_ord.ml: -------------------------------------------------------------------------------- 1 | open CCOrd 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | t @@ fun () -> equiv 1 2;; 6 | t @@ fun () -> equiv ~-1 ~-10;; 7 | t @@ fun () -> equiv 0 0;; 8 | t @@ fun () -> equiv ~-1 ~-1;; 9 | t @@ fun () -> not (equiv 0 1);; 10 | t @@ fun () -> not (equiv 1 ~-1);; 11 | t @@ fun () -> not (equiv 1 0);; 12 | q Q.(pair int int) (fun (x, y) -> equiv x y = equiv y x);; 13 | 14 | q 15 | Q.(triple int int int) 16 | (fun (x, y, z) -> 17 | if equiv x y && equiv y z then 18 | equiv x z 19 | else 20 | true) 21 | ;; 22 | 23 | t @@ fun () -> bool true false > 0;; 24 | t @@ fun () -> bool false true < 0;; 25 | t @@ fun () -> bool true true = 0;; 26 | t @@ fun () -> bool false false = 0;; 27 | q Q.(option int) (fun o -> option int None o <= 0);; 28 | t @@ fun () -> pair int string (1, "b") (2, "a") < 0;; 29 | t @@ fun () -> pair int string (1, "b") (0, "a") > 0;; 30 | t @@ fun () -> pair int string (1, "b") (1, "b") = 0;; 31 | t @@ fun () -> list int [ 1; 2; 3 ] [ 1; 2; 3; 4 ] < 0;; 32 | t @@ fun () -> list int [ 1; 2; 3; 4 ] [ 1; 2; 3 ] > 0;; 33 | t @@ fun () -> list int [ 1; 2; 3; 4 ] [ 1; 3; 4 ] < 0;; 34 | 35 | q 36 | Q.(pair (list int) (list int)) 37 | CCOrd.(fun (l1, l2) -> equiv (list int l1 l2) (Stdlib.compare l1 l2)) 38 | ;; 39 | 40 | t @@ fun () -> array int [| 1; 2; 3 |] [| 1; 2; 3; 4 |] < 0;; 41 | t @@ fun () -> array int [| 1; 2; 3; 4 |] [| 1; 2; 3 |] > 0;; 42 | t @@ fun () -> array int [| 1; 2; 3; 4 |] [| 1; 3; 4 |] < 0;; 43 | 44 | q 45 | Q.(pair (array int) (array int)) 46 | CCOrd.( 47 | fun (a1, a2) -> 48 | equiv (array int a1 a2) (list int (Array.to_list a1) (Array.to_list a2))) 49 | -------------------------------------------------------------------------------- /src/threads/CCBlockingQueue.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Blocking Queue} 4 | 5 | This queue has a limited size. Pushing a value on the queue when it 6 | is full will block. 7 | 8 | @since 0.16 *) 9 | 10 | type 'a t 11 | (** Safe-thread queue for values of type ['a] *) 12 | 13 | val create : int -> 'a t 14 | (** Create a new queue of size [n]. Using [n=max_int] amounts to using 15 | an infinite queue (2^61 items is a lot to fit in memory); using [n=1] 16 | amounts to using a box with 0 or 1 elements inside. 17 | @raise Invalid_argument if [n < 1]. *) 18 | 19 | val push : 'a t -> 'a -> unit 20 | (** [push q x] pushes [x] into [q], blocking if the queue is full. *) 21 | 22 | val take : 'a t -> 'a 23 | (** Take the first element, blocking if needed. *) 24 | 25 | val push_list : 'a t -> 'a list -> unit 26 | (** Push items of the list, one by one. *) 27 | 28 | val take_list : 'a t -> int -> 'a list 29 | (** [take_list n q] takes [n] elements out of [q]. *) 30 | 31 | val try_take : 'a t -> 'a option 32 | (** Take the first element if the queue is not empty, return [None] 33 | otherwise. *) 34 | 35 | val try_push : 'a t -> 'a -> bool 36 | (** [try_push q x] pushes [x] into [q] if [q] is not full, in which 37 | case it returns [true]. 38 | If it fails because [q] is full, it returns [false]. *) 39 | 40 | val peek : 'a t -> 'a option 41 | (** [peek q] returns [Some x] if [x] is the first element of [q], 42 | otherwise it returns [None]. *) 43 | 44 | val size : _ t -> int 45 | (** Number of elements currently in the queue. *) 46 | 47 | val capacity : _ t -> int 48 | (** Number of values the queue can hold. *) 49 | -------------------------------------------------------------------------------- /src/core/CCEither.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | type 'a iter = ('a -> unit) -> unit 4 | type 'a equal = 'a -> 'a -> bool 5 | type 'a ord = 'a -> 'a -> int 6 | type 'a printer = Format.formatter -> 'a -> unit 7 | 8 | (** {2 Basics} *) 9 | 10 | type ('a, 'b) t = ('a, 'b) Either.t = Left of 'a | Right of 'b 11 | 12 | let left l = Left l 13 | let right r = Right r 14 | 15 | let is_left = function 16 | | Left _ -> true 17 | | Right _ -> false 18 | 19 | let is_right = function 20 | | Left _ -> false 21 | | Right _ -> true 22 | 23 | let find_left = function 24 | | Left l -> Some l 25 | | Right _ -> None 26 | 27 | let find_right = function 28 | | Left _ -> None 29 | | Right r -> Some r 30 | 31 | let map_left f = function 32 | | Left l -> Left (f l) 33 | | Right r -> Right r 34 | 35 | let map_right f = function 36 | | Left l -> Left l 37 | | Right r -> Right (f r) 38 | 39 | let map ~left ~right = function 40 | | Left l -> Left (left l) 41 | | Right r -> Right (right r) 42 | 43 | let fold ~left ~right = function 44 | | Left l -> left l 45 | | Right r -> right r 46 | 47 | let iter = fold 48 | let for_all = fold 49 | 50 | let equal ~left ~right e1 e2 = 51 | match e1, e2 with 52 | | Left l1, Left l2 -> left l1 l2 53 | | Right r1, Right r2 -> right r1 r2 54 | | _ -> false 55 | 56 | let compare ~left ~right e1 e2 = 57 | match e1, e2 with 58 | | Left _, Right _ -> -1 59 | | Right _, Left _ -> 1 60 | | Left l1, Left l2 -> left l1 l2 61 | | Right r1, Right r2 -> right r1 r2 62 | 63 | (** {2 IO} *) 64 | 65 | let pp ~left ~right fmt = function 66 | | Left l -> Format.fprintf fmt "Left@ (@[%a@])" left l 67 | | Right r -> Format.fprintf fmt "Right@ (@[%a@])" right r 68 | -------------------------------------------------------------------------------- /src/data/CCLazy_list.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Lazy List 4 | 5 | @since 0.17 *) 6 | 7 | type +'a t = 'a node lazy_t 8 | and +'a node = Nil | Cons of 'a * 'a t 9 | 10 | val empty : 'a t 11 | (** Empty list. *) 12 | 13 | val return : 'a -> 'a t 14 | (** Return a computed value. *) 15 | 16 | val is_empty : _ t -> bool 17 | (** Evaluate the head. *) 18 | 19 | val length : _ t -> int 20 | (** [length l] returns the number of elements in [l], eagerly (linear time). 21 | Caution, will not terminate if [l] is infinite. *) 22 | 23 | val cons : 'a -> 'a t -> 'a t 24 | 25 | val head : 'a t -> ('a * 'a t) option 26 | (** Evaluate head, return it, or [None] if the list is empty. *) 27 | 28 | val map : f:('a -> 'b) -> 'a t -> 'b t 29 | (** Lazy map. *) 30 | 31 | val filter : f:('a -> bool) -> 'a t -> 'a t 32 | (** Filter values. 33 | @since 0.18 *) 34 | 35 | val take : int -> 'a t -> 'a t 36 | (** Take at most n values. 37 | @since 0.18 *) 38 | 39 | val append : 'a t -> 'a t -> 'a t 40 | (** Lazy concatenation. *) 41 | 42 | val flat_map : f:('a -> 'b t) -> 'a t -> 'b t 43 | (** Monadic flatten + map. *) 44 | 45 | val default : default:'a t -> 'a t -> 'a t 46 | (** Choice operator. 47 | @since 2.1 *) 48 | 49 | module Infix : sig 50 | val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t 51 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 52 | 53 | val ( <|> ) : 'a t -> 'a t -> 'a t 54 | (** Alias to {!default}. 55 | @since 2.1 *) 56 | end 57 | 58 | include module type of Infix 59 | 60 | type 'a gen = unit -> 'a option 61 | 62 | val of_gen : 'a gen -> 'a t 63 | val of_list : 'a list -> 'a t 64 | val to_list : 'a t -> 'a list 65 | val to_list_rev : 'a t -> 'a list 66 | val to_gen : 'a t -> 'a gen 67 | -------------------------------------------------------------------------------- /src/core/CCChar.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Utils around char 4 | 5 | @since 0.14 *) 6 | 7 | include module type of struct 8 | include Char 9 | end 10 | (** @inline *) 11 | 12 | val compare : t -> t -> int 13 | (** The comparison function for characters, with the same specification as 14 | {!Stdlib.compare}. Along with the type [t], this function [compare] 15 | allows the module [Char] to be passed as argument to the functors 16 | {!Set.Make} and {!Map.Make}. *) 17 | 18 | val of_int_exn : int -> t 19 | (** Alias to {!Char.chr}. 20 | Return the character with the given ASCII code. 21 | @raise Invalid_argument if the int is not within [0 … 255]. 22 | @since 1.0 *) 23 | 24 | val of_int : int -> t option 25 | (** Safe version of {!of_int_exn}. 26 | @since 1.0 *) 27 | 28 | val to_int : t -> int 29 | (** Alias to {!Char.code}. 30 | Return the ASCII code of the argument. 31 | @since 1.0 *) 32 | 33 | val to_string : t -> string 34 | (** [to_string c] returns a string containing [c] 35 | @since 2.7 *) 36 | 37 | val pp_buf : Buffer.t -> t -> unit 38 | (** Renamed from [pp] since 2.0. *) 39 | 40 | val pp : Format.formatter -> t -> unit 41 | (** Renamed from [print] since 2.0. *) 42 | 43 | (** {2 Infix Operators} 44 | 45 | @since 3.3 *) 46 | 47 | module Infix : sig 48 | val ( = ) : t -> t -> bool 49 | (** @since 3.3 *) 50 | 51 | val ( <> ) : t -> t -> bool 52 | (** @since 3.3 *) 53 | 54 | val ( < ) : t -> t -> bool 55 | (** @since 3.3 *) 56 | 57 | val ( > ) : t -> t -> bool 58 | (** @since 3.3 *) 59 | 60 | val ( <= ) : t -> t -> bool 61 | (** @since 3.3 *) 62 | 63 | val ( >= ) : t -> t -> bool 64 | (** @since 3.3 *) 65 | end 66 | 67 | include module type of Infix 68 | -------------------------------------------------------------------------------- /src/data/CCMixtbl.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Hash Table with Heterogeneous Keys} *) 4 | 5 | type 'b injection = { 6 | get: (unit -> unit) -> 'b option; 7 | set: 'b -> unit -> unit; 8 | } 9 | 10 | type 'a t = ('a, unit -> unit) Hashtbl.t 11 | 12 | let create n = Hashtbl.create n 13 | 14 | let create_inj () = 15 | let r = ref None in 16 | let get f = 17 | r := None; 18 | f (); 19 | !r 20 | and set v () = r := Some v in 21 | { get; set } 22 | 23 | let get ~inj tbl x = try inj.get (Hashtbl.find tbl x) with Not_found -> None 24 | let set ~inj tbl x y = Hashtbl.replace tbl x (inj.set y) 25 | let length tbl = Hashtbl.length tbl 26 | let clear tbl = Hashtbl.clear tbl 27 | let remove tbl x = Hashtbl.remove tbl x 28 | let copy tbl = Hashtbl.copy tbl 29 | 30 | let is_some = function 31 | | None -> false 32 | | Some _ -> true 33 | 34 | let mem ~inj tbl x = 35 | try is_some (inj.get (Hashtbl.find tbl x)) with Not_found -> false 36 | 37 | let find ~inj tbl x = 38 | match inj.get (Hashtbl.find tbl x) with 39 | | None -> raise Not_found 40 | | Some v -> v 41 | 42 | let iter_keys tbl f = Hashtbl.iter (fun x _ -> f x) tbl 43 | let fold_keys tbl acc f = Hashtbl.fold (fun x _ acc -> f acc x) tbl acc 44 | 45 | (** {2 Iterators} *) 46 | 47 | type 'a iter = ('a -> unit) -> unit 48 | 49 | let keys_iter tbl yield = Hashtbl.iter (fun x _ -> yield x) tbl 50 | 51 | let bindings_of ~inj tbl yield = 52 | Hashtbl.iter 53 | (fun k value -> 54 | match inj.get value with 55 | | None -> () 56 | | Some v -> yield (k, v)) 57 | tbl 58 | 59 | type value = Value : ('b injection -> 'b option) -> value 60 | 61 | let bindings tbl yield = 62 | Hashtbl.iter (fun x y -> yield (x, Value (fun inj -> inj.get y))) tbl 63 | -------------------------------------------------------------------------------- /tests/thread/t_semaphore.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCSemaphore;; 4 | 5 | t @@ fun () -> 6 | let s = create 1 in 7 | let r = CCLock.create false in 8 | let _ = 9 | Thread.create 10 | (fun s -> 11 | acquire 5 s; 12 | CCLock.set r true) 13 | s 14 | in 15 | Thread.yield (); 16 | assert_equal false (CCLock.get r); 17 | release 4 s; 18 | Thread.delay 0.2; 19 | assert_equal true (CCLock.get r); 20 | assert_equal 0 (get s); 21 | true 22 | ;; 23 | 24 | t @@ fun () -> 25 | let s = create 5 in 26 | let n = CCLock.create 0 in 27 | let a = 28 | Array.init 100 (fun i -> 29 | Thread.create 30 | (fun _ -> 31 | for _i = 1 to 100 do 32 | with_acquire 33 | ~n:(1 + (i mod 5)) 34 | s 35 | ~f:(fun () -> 36 | Thread.yield (); 37 | CCLock.incr n) 38 | done) 39 | ()) 40 | in 41 | Array.iter Thread.join a; 42 | assert_equal ~printer:CCInt.to_string 5 (get s); 43 | assert_equal ~printer:CCInt.to_string 10_000 (CCLock.get n); 44 | true 45 | ;; 46 | 47 | t @@ fun () -> 48 | let output _s = () in 49 | let s = create 2 in 50 | let res = CCLock.create false in 51 | let id = 52 | Thread.create 53 | (fun () -> 54 | output "start"; 55 | wait_until_at_least ~n:5 s ~f:(fun () -> 56 | assert (get s >= 5); 57 | output "modify now"; 58 | CCLock.set res true)) 59 | () 60 | in 61 | output "launched thread"; 62 | Thread.yield (); 63 | assert (not (CCLock.get res)); 64 | output "release 2"; 65 | release 2 s; 66 | Thread.yield (); 67 | assert (not (CCLock.get res)); 68 | output "release 1"; 69 | release 1 s; 70 | (* should work now *) 71 | Thread.delay 0.2; 72 | Thread.join id; 73 | output "check"; 74 | assert (CCLock.get res); 75 | true 76 | -------------------------------------------------------------------------------- /tests/core/t_unix.ml: -------------------------------------------------------------------------------- 1 | module T = (val Containers_testlib.make ~__FILE__ ()) 2 | include T 3 | open CCUnix;; 4 | 5 | t @@ fun () -> escape_str "foo" = "foo";; 6 | t @@ fun () -> escape_str "foo bar" = "'foo bar'";; 7 | t @@ fun () -> escape_str "fo'o b'ar" = "'fo'\\''o b'\\''ar'";; 8 | t @@ fun () -> call_full ~stdin:(`Str "abc") "cat" |> stdout = "abc";; 9 | t @@ fun () -> call_full "echo %s" (escape_str "a'b'c") |> stdout = "a'b'c\n";; 10 | t @@ fun () -> call_full "echo %s" "a'b'c" |> stdout = "abc\n";; 11 | t @@ fun () -> call_stdout ~stdin:(`Str "abc") "cat" = "abc";; 12 | t @@ fun () -> call_stdout "echo %s" (escape_str "a'b'c") = "a'b'c\n";; 13 | t @@ fun () -> call_stdout "echo %s" "a'b'c" = "abc\n";; 14 | 15 | t @@ fun () -> 16 | let m = 200 in 17 | let n = 50 in 18 | let write_atom filename s = 19 | with_file_lock ~kind:`Write filename (fun () -> 20 | CCIO.with_out ~flags:[ Open_append; Open_creat ] filename (fun oc -> 21 | output_string oc s; 22 | flush oc)) 23 | in 24 | let f filename = 25 | for _j = 1 to m do 26 | write_atom filename "foo\n" 27 | done 28 | in 29 | CCIO.File.with_temp ~prefix:"containers_" ~suffix:".txt" (fun filename -> 30 | let a = Array.init n (fun _ -> Thread.create f filename) in 31 | Array.iter Thread.join a; 32 | let lines = CCIO.with_in filename CCIO.read_lines_l in 33 | assert_equal ~printer:string_of_int (n * m) (List.length lines); 34 | assert (List.for_all (( = ) "foo") lines)); 35 | true 36 | ;; 37 | 38 | t @@ fun () -> 39 | let filename = 40 | with_temp_dir "test_containers" (fun dir -> 41 | let name = Filename.concat dir "test" in 42 | CCIO.with_out name (fun oc -> 43 | output_string oc "content"; 44 | flush oc); 45 | assert (Sys.file_exists name); 46 | name) 47 | in 48 | assert (not (Sys.file_exists filename)); 49 | true 50 | -------------------------------------------------------------------------------- /tests/data/t_mutheap.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | 4 | type elt = { x: string; mutable rank: int; mutable idx: int } 5 | 6 | module Elt = struct 7 | type t = elt 8 | 9 | let idx x = x.idx 10 | let set_idx x i = x.idx <- i 11 | 12 | let lt a b = 13 | if a.rank = b.rank then 14 | a.x < b.x 15 | else 16 | a.rank < b.rank 17 | end 18 | 19 | module H = CCMutHeap.Make (Elt);; 20 | 21 | t @@ fun () -> 22 | let h = H.create () in 23 | let x1 = { x = "a"; rank = 10; idx = -1 } in 24 | let x2 = { x = "b"; rank = 10; idx = -1 } in 25 | let x3 = { x = "c"; rank = 10; idx = -1 } in 26 | H.insert h x1; 27 | assert (H.in_heap x1); 28 | assert (not (H.in_heap x2)); 29 | assert (not (H.in_heap x3)); 30 | H.insert h x2; 31 | H.insert h x3; 32 | 33 | assert (Elt.lt x1 x2); 34 | assert (Elt.lt x2 x3); 35 | 36 | let x = H.remove_min h in 37 | assert (x == x1); 38 | 39 | let x = H.remove_min h in 40 | assert (x == x2); 41 | 42 | let x = H.remove_min h in 43 | assert (x == x3); 44 | 45 | assert ( 46 | try 47 | ignore (H.remove_min h); 48 | false 49 | with Not_found -> true); 50 | true 51 | ;; 52 | 53 | t @@ fun () -> 54 | let h = H.create () in 55 | let x1 = { x = "a"; rank = 10; idx = -1 } in 56 | let x2 = { x = "b"; rank = 10; idx = -1 } in 57 | let x3 = { x = "c"; rank = 10; idx = -1 } in 58 | H.insert h x1; 59 | H.insert h x2; 60 | H.insert h x3; 61 | 62 | x3.rank <- 2; 63 | H.decrease h x3; 64 | 65 | assert (Elt.lt x3 x1); 66 | assert (Elt.lt x3 x2); 67 | 68 | let x = H.remove_min h in 69 | assert (x == x3); 70 | 71 | x1.rank <- 20; 72 | H.increase h x1; 73 | 74 | let x = H.remove_min h in 75 | assert (x == x2); 76 | 77 | let x = H.remove_min h in 78 | assert (x == x1); 79 | 80 | assert ( 81 | try 82 | ignore (H.remove_min h); 83 | false 84 | with Not_found -> true); 85 | true 86 | -------------------------------------------------------------------------------- /benchs/run_bench_hash.ml: -------------------------------------------------------------------------------- 1 | (** Test hash functions *) 2 | 3 | type tree = Empty | Node of int * tree list 4 | 5 | let mk_node i l = Node (i, l) 6 | 7 | let random_tree = 8 | CCRandom.( 9 | fix ~base:(return Empty) 10 | ~subn:[ (int 10, fun sublist -> pure mk_node <*> small_int <*> sublist) ] 11 | (int_range 15 150)) 12 | 13 | let random_list = 14 | CCRandom.(int 5 >>= fun len -> CCList.random_len len random_tree) 15 | 16 | let rec eq t1 t2 = 17 | match t1, t2 with 18 | | Empty, Empty -> true 19 | | Node (i1, l1), Node (i2, l2) -> i1 = i2 && CCList.equal eq l1 l2 20 | | Node _, _ | _, Node _ -> false 21 | 22 | let rec hash_tree t = 23 | match t with 24 | | Empty -> CCHash.string "empty" 25 | | Node (i, l) -> CCHash.(combine2 (int i) (list hash_tree l)) 26 | 27 | module H = Hashtbl.Make (struct 28 | type t = tree 29 | 30 | let equal = eq 31 | let hash = hash_tree 32 | end) 33 | 34 | let print_hashcons_stats st = 35 | let open Hashtbl in 36 | Format.printf "tbl stats: %d elements, num buckets: %d, max bucket: %d@." 37 | st.num_bindings st.num_buckets st.max_bucket_length; 38 | Array.iteri 39 | (fun i n -> Format.printf " %d\t buckets have length %d@." n i) 40 | st.bucket_histogram 41 | 42 | let () = 43 | let st = Random.State.make_self_init () in 44 | let n = 50_000 in 45 | Format.printf "generate %d elements...\n" n; 46 | let l = CCRandom.run ~st (CCList.random_len n random_tree) in 47 | (* with custom hashtable *) 48 | Format.printf "### custom hashtable\n"; 49 | let tbl = H.create 256 in 50 | List.iter (fun t -> H.replace tbl t ()) l; 51 | print_hashcons_stats (H.stats tbl); 52 | (* with default hashtable *) 53 | Format.printf "### default hashtable\n"; 54 | let tbl' = Hashtbl.create 256 in 55 | List.iter (fun t -> Hashtbl.replace tbl' t ()) l; 56 | print_hashcons_stats (Hashtbl.stats tbl'); 57 | () 58 | -------------------------------------------------------------------------------- /src/threads/CCThread.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Threads} 4 | 5 | {b status: unstable} 6 | @since 0.13 *) 7 | 8 | type t = Thread.t 9 | 10 | val spawn : (unit -> _) -> t 11 | (** [spawn f] creates a new thread that runs [f ()]. *) 12 | 13 | val spawn1 : ('a -> _) -> 'a -> t 14 | (** [spawn1 f x] is like [spawn (fun () -> f x)]. 15 | @since 0.16 *) 16 | 17 | val spawn2 : ('a -> 'b -> _) -> 'a -> 'b -> t 18 | (** [spawn2 f x y] is like [spawn (fun () -> f x y)]. 19 | @since 0.16 *) 20 | 21 | val detach : (unit -> 'a) -> unit 22 | (** [detach f] is the same as [ignore (spawn f)]. *) 23 | 24 | (** {2 Array of threads} *) 25 | module Arr : sig 26 | val spawn : int -> (int -> 'a) -> t array 27 | (** [Arr.spawn n f] creates an array [res] of length [n], such that 28 | [res.(i) = spawn (fun () -> f i)]. *) 29 | 30 | val join : t array -> unit 31 | (** [Arr.join a] joins every thread in [a]. *) 32 | end 33 | 34 | (** {2 Single-Use Barrier} *) 35 | 36 | module Barrier : sig 37 | type t 38 | (** Barrier, used to synchronize threads *) 39 | 40 | val create : unit -> t 41 | (** Create a barrier. *) 42 | 43 | val reset : t -> unit 44 | (** Reset to initial (non-triggered) state. *) 45 | 46 | val wait : t -> unit 47 | (** [wait b] waits for barrier [b] to be activated by [activate b]. 48 | All threads calling this wait until [activate b] is called. 49 | If [b] is already activated, [wait b] does nothing. *) 50 | 51 | val activate : t -> unit 52 | (** [activate b] unblocks all threads that were waiting on [b]. *) 53 | 54 | val activated : t -> bool 55 | (** [activated b] returns [true] iff [activate b] was called, and [reset b] 56 | was not called since. In other words, [activated b = true] means 57 | [wait b] will not block. *) 58 | end 59 | -------------------------------------------------------------------------------- /src/core/tests/test_hash.ml: -------------------------------------------------------------------------------- 1 | (* test hash functions a bit *) 2 | 3 | module H = CCHash 4 | 5 | module Hist = struct 6 | type t = { tbl: (int, int) Hashtbl.t; mutable n_samples: int } 7 | 8 | let create () : t = { tbl = Hashtbl.create 32; n_samples = 0 } 9 | 10 | let add self x = 11 | Hashtbl.replace self.tbl x (1 + try Hashtbl.find self.tbl x with _ -> 0); 12 | self.n_samples <- 1 + self.n_samples 13 | 14 | let add_n self x n = 15 | Hashtbl.replace self.tbl x (n + try Hashtbl.find self.tbl x with _ -> 0); 16 | self.n_samples <- n + self.n_samples 17 | 18 | let pp out (self : t) : unit = 19 | let max = Hashtbl.fold (fun k _ n -> max k n) self.tbl 0 in 20 | let min = Hashtbl.fold (fun k _ n -> min k n) self.tbl max in 21 | for i = min to max do 22 | let n = try Hashtbl.find self.tbl i with _ -> 0 in 23 | Format.fprintf out "[v=%-4d, n-inputs %-6d] %s@." i n 24 | (String.make (int_of_float @@ ceil (log (float n))) '#') 25 | done 26 | end 27 | 28 | let reset_line = "\x1b[2K\r" 29 | 30 | let t_int n1 n2 = 31 | Printf.printf "test hash_int on %d--%d\n" n1 n2; 32 | let count = Hashtbl.create 128 in 33 | for i = n1 to n2 do 34 | Printf.printf "%shash %d…%!" reset_line i; 35 | let h = H.int i in 36 | Hashtbl.replace count h (1 + CCHashtbl.get_or count h ~default:0); 37 | if i mod 1024 * 1024 * 1024 = 0 then Gc.major () 38 | done; 39 | Printf.printf "%s%!" reset_line; 40 | (* reverse table *) 41 | let by_count = 42 | CCHashtbl.to_iter count 43 | |> Iter.map (fun (_h, n) -> n) 44 | |> Iter.count ~hash:H.int 45 | in 46 | let hist = Hist.create () in 47 | by_count (fun (n, i) -> Hist.add_n hist n i); 48 | Format.printf "histogram:@.%a@." Hist.pp hist; 49 | (*assert (Hist.check_uniform hist);*) 50 | () 51 | 52 | let () = 53 | t_int 0 2_000_000; 54 | t_int (-4_000_000) (-3_500_000); 55 | () 56 | -------------------------------------------------------------------------------- /tests/core/t_canonical_sexp.ml: -------------------------------------------------------------------------------- 1 | open CCCanonical_sexp 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T 4 | 5 | let csexp_bijective s = to_string s |> parse_string = Ok s;; 6 | 7 | eq 8 | ~printer:CCFormat.(to_string (Dump.result pp)) 9 | (Ok (`List [ `Atom "" ])) 10 | (parse_string {|(0:)|}) 11 | ;; 12 | 13 | eq 14 | ~printer:CCFormat.(to_string (Dump.result pp)) 15 | (Ok (`List [ `Atom "a"; `Atom "b " ])) 16 | (parse_string {|(1:a2:b )|}) 17 | ;; 18 | 19 | t @@ fun () -> csexp_bijective (`List [ `Atom "" ]) 20 | 21 | let sexp_gen = 22 | let mkatom a = `Atom a and mklist l = `List l in 23 | let atom = Q.Gen.(map mkatom (string_size ~gen:char (1 -- 30))) in 24 | let gen = 25 | Q.Gen.( 26 | sized 27 | (fix (fun self n st -> 28 | match n with 29 | | 0 -> atom st 30 | | _ -> 31 | frequency 32 | [ 33 | 1, atom; 2, map mklist (list_size (0 -- 10) (self (n / 10))); 34 | ] 35 | st))) 36 | in 37 | let rec small = function 38 | | `Atom s -> String.length s 39 | | `List l -> List.fold_left (fun n x -> n + small x) 0 l 40 | and print = function 41 | | `Atom s -> Printf.sprintf "`Atom \"%s\"" s 42 | | `List l -> "`List " ^ Q.Print.list print l 43 | and shrink = function 44 | | `Atom s -> Q.Iter.map mkatom (Q.Shrink.string s) 45 | | `List l -> Q.Iter.map mklist (Q.Shrink.list ~shrink l) 46 | in 47 | Q.make ~print ~small ~shrink gen 48 | ;; 49 | 50 | q ~count:100 sexp_gen csexp_bijective;; 51 | 52 | t @@ fun () -> 53 | let s1 = 54 | `List 55 | (CCList.init 100_000 (fun i -> 56 | `List [ `Atom "-"; `Atom (string_of_int i); `Atom ")(\n]" ])) 57 | in 58 | let str = to_string s1 in 59 | (match parse_string str with 60 | | Ok s2 -> assert_equal s1 s2 61 | | Error e -> assert_failure e); 62 | true 63 | -------------------------------------------------------------------------------- /tests/core/t_bencode.ml: -------------------------------------------------------------------------------- 1 | module T = (val Containers_testlib.make ~__FILE__ ()) 2 | include T 3 | open Containers_bencode;; 4 | 5 | eq ~printer:to_string_debug (map_of_list []) (Decode.of_string_exn "de");; 6 | 7 | eq ~printer:to_string_debug 8 | (list [ int 1; int 2; string "foo" ]) 9 | (Decode.of_string_exn "li1ei2e3:fooe") 10 | 11 | module B = Containers_bencode 12 | 13 | let rec size = function 14 | | Int _ | String _ -> 1 15 | | List l -> List.fold_left (fun n x -> n + size x) 0 l 16 | | Map m -> Str_map.fold (fun _ v n -> size v + n) m 0 17 | 18 | let g_rand_b = 19 | Q.Gen.( 20 | sized_size (0 -- 7) 21 | @@ fix 22 | @@ fun self n -> 23 | let str n = string_size ~gen:char (0 -- n) in 24 | let base = [ int >|= B.int; str 100 >|= B.string ] in 25 | match n with 26 | | 0 -> oneof base 27 | | n -> 28 | frequency 29 | @@ List.map (fun x -> 2, x) base 30 | @ [ 31 | 1, list_size (0 -- 10) (self (n - 1)) >|= B.list; 32 | ( 1, 33 | list_size (0 -- 10) (pair (str 10) (self (n - 1))) >|= B.map_of_list 34 | ); 35 | ]) 36 | 37 | let rec shrink_b self = 38 | Q.( 39 | Iter.( 40 | match self with 41 | | Int i -> Shrink.int64 i >|= B.int64 42 | | String s -> Shrink.string s >|= B.string 43 | | List l -> Shrink.list ~shrink:shrink_b l >|= B.list 44 | | Map l -> 45 | let l = Str_map.fold (fun k v l -> (k, v) :: l) l [] in 46 | Shrink.list 47 | ~shrink:(fun (k, v) -> 48 | Shrink.string k 49 | >|= (fun k -> k, v) 50 | <+> (shrink_b v >|= fun v -> k, v)) 51 | l 52 | >|= B.map_of_list)) 53 | 54 | let rand_b = 55 | Q.make ~print:to_string_debug 56 | ~stats:[ "size", size ] 57 | ~shrink:shrink_b g_rand_b 58 | ;; 59 | 60 | q rand_b (fun b -> 61 | let s = Encode.to_string b in 62 | equal (Decode.of_string_exn s) b) 63 | -------------------------------------------------------------------------------- /src/data/CCBitField.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Efficient Bit Field for up to 31 or 61 fiels 4 | 5 | This module defines efficient bitfields 6 | up to 31 or 61 bits (depending on the architecture) in 7 | a relatively type-safe way. 8 | 9 | {[ 10 | module B = CCBitField.Make(struct end);; 11 | 12 | let x = B.mk_field () 13 | let y = B.mk_field () 14 | let z = B.mk_field () 15 | 16 | let f = B.empty |> B.set x true |> B.set y true;; 17 | 18 | assert (not (B.get z f)) ;; 19 | 20 | assert (f |> B.set z true |> B.get z);; 21 | 22 | ]} 23 | *) 24 | 25 | exception TooManyFields 26 | (** Raised when too many fields are packed into one bitfield. *) 27 | 28 | exception Frozen 29 | (** Raised when a frozen bitfield is modified. *) 30 | 31 | val max_width : int 32 | (** System-dependent maximum width for a bitfield, typically 30 or 62. *) 33 | 34 | (** {2 Bitfield Signature} *) 35 | module type S = sig 36 | type t = private int 37 | (** Generative type of bitfields. Each instantiation of the functor 38 | should create a new, incompatible type *) 39 | 40 | val empty : t 41 | (** Empty bitfields (all bits 0). *) 42 | 43 | type field 44 | 45 | val get : field -> t -> bool 46 | (** Get the value of this field. *) 47 | 48 | val set : field -> bool -> t -> t 49 | (** Set the value of this field. *) 50 | 51 | val mk_field : unit -> field 52 | (** Make a new field. *) 53 | 54 | val freeze : unit -> unit 55 | (** Prevent new fields from being added. From now on, creating 56 | a field will raise Frozen. *) 57 | 58 | val total_width : unit -> int 59 | (** Current width of the bitfield. *) 60 | end 61 | 62 | (** Create a new bitfield type *) 63 | module Make : functor (_ : sig end) -> S 64 | 65 | (**/**) 66 | 67 | val all_bits_ : int -> int -> int 68 | 69 | (**/**) 70 | -------------------------------------------------------------------------------- /src/core/CCByte_buffer.mli: -------------------------------------------------------------------------------- 1 | (** Byte buffer. 2 | 3 | A dynamic vector of bytes. 4 | @since 3.7 5 | *) 6 | 7 | type t 8 | type 'a iter = ('a -> unit) -> unit 9 | 10 | val create : ?cap:int -> unit -> t 11 | (** Create a new buffer with given initial capacity. *) 12 | 13 | val length : t -> int 14 | (** Current length. *) 15 | 16 | val is_empty : t -> bool 17 | (** [is_empty b] is [length b=0] *) 18 | 19 | val capacity : t -> int 20 | (** Current capacity (size of the array returned by {!bytes}) *) 21 | 22 | val bytes : t -> bytes 23 | (** Access the underlying byte buffer. This buffer can change after 24 | operations that affect the capacity (e.g. {!add_char}). *) 25 | 26 | val clear : t -> unit 27 | 28 | val ensure_cap : t -> int -> unit 29 | (** [ensure_cap self n] ensures that [capacity self >= n]. *) 30 | 31 | val shrink_to : t -> int -> unit 32 | (** [shrink_to buf n] reduces [length buf] to at most [n]. 33 | Does nothing if the length is already <= n. *) 34 | 35 | val add_char : t -> char -> unit 36 | (** Push a character at the end. *) 37 | 38 | val append_bytes : t -> bytes -> unit 39 | val append_subbytes : t -> bytes -> int -> int -> unit 40 | val append_string : t -> string -> unit 41 | val append_substring : t -> string -> int -> int -> unit 42 | val append_buf : t -> Buffer.t -> unit 43 | val append_iter : t -> char iter -> unit 44 | val append_seq : t -> char Seq.t -> unit 45 | val get : t -> int -> char 46 | val unsafe_get : t -> int -> char 47 | val set : t -> int -> char -> unit 48 | val unsafe_set : t -> int -> char -> unit 49 | 50 | val contents : t -> string 51 | (** Copy the internal data to a string *) 52 | 53 | val contents_bytes : t -> bytes 54 | (** Copy the internal data to a byte buffer *) 55 | 56 | val iter : (char -> unit) -> t -> unit 57 | val fold_left : ('a -> char -> 'a) -> 'a -> t -> 'a 58 | val of_iter : char iter -> t 59 | val of_seq : char Seq.t -> t 60 | val to_iter : t -> char iter 61 | val to_seq : t -> char Seq.t 62 | -------------------------------------------------------------------------------- /src/data/CCBitField.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Bit Field} *) 4 | 5 | exception TooManyFields 6 | exception Frozen 7 | 8 | let max_width = Sys.word_size - 2 9 | 10 | module type S = sig 11 | type t = private int 12 | (** Generative type of bitfields. Each instantiation of the functor 13 | should create a new, incompatible type *) 14 | 15 | val empty : t 16 | (** Empty bitfields (all bits 0) *) 17 | 18 | type field 19 | 20 | val get : field -> t -> bool 21 | (** Get the value of this field *) 22 | 23 | val set : field -> bool -> t -> t 24 | (** Set the value of this field *) 25 | 26 | val mk_field : unit -> field 27 | (** Make a new field *) 28 | 29 | val freeze : unit -> unit 30 | (** Prevent new fields from being added. From now on, creating 31 | a field will raise Frozen *) 32 | 33 | val total_width : unit -> int 34 | (** Current width of the bitfield *) 35 | end 36 | 37 | (* all bits from 0 to w-1 set to true *) 38 | let rec all_bits_ acc w = 39 | if w = 0 then 40 | acc 41 | else ( 42 | let acc = acc lor ((1 lsl w) - 1) in 43 | all_bits_ acc (w - 1) 44 | ) 45 | 46 | (* increment and return previous value *) 47 | let get_then_incr n = 48 | let x = !n in 49 | incr n; 50 | x 51 | 52 | module Make (X : sig end) : S = struct 53 | type t = int 54 | 55 | let empty = 0 56 | let width_ = ref 0 57 | let frozen_ = ref false 58 | 59 | type field = int (* a mask *) 60 | 61 | let get field x = x land field <> 0 62 | 63 | let set field b x = 64 | if b then 65 | x lor field 66 | else 67 | x land lnot field 68 | 69 | let mk_field () = 70 | if !frozen_ then raise Frozen; 71 | let n = get_then_incr width_ in 72 | if n > max_width then raise TooManyFields; 73 | let mask = 1 lsl n in 74 | mask 75 | 76 | let freeze () = frozen_ := true 77 | let total_width () = !width_ 78 | end 79 | -------------------------------------------------------------------------------- /tests/core/t_hashtbl.ml: -------------------------------------------------------------------------------- 1 | module T = (val Containers_testlib.make ~__FILE__ ()) 2 | include T 3 | open CCHashtbl;; 4 | 5 | eq "c" 6 | (let tbl = of_list [ 1, "a"; 2, "b" ] in 7 | get_or tbl 3 ~default:"c") 8 | ;; 9 | 10 | eq "b" 11 | (let tbl = of_list [ 1, "a"; 2, "b" ] in 12 | get_or tbl 2 ~default:"c") 13 | ;; 14 | 15 | t @@ fun () -> 16 | of_list [ 1, "a"; 2, "b" ] 17 | |> map_list (fun x y -> string_of_int x ^ y) 18 | |> List.sort Stdlib.compare = [ "1a"; "2b" ] 19 | ;; 20 | 21 | t @@ fun () -> 22 | let tbl = Hashtbl.create 32 in 23 | update tbl ~f:(fun _ _ -> Some "1") ~k:1; 24 | assert_equal (Some "1") (get tbl 1); 25 | update tbl 26 | ~f:(fun _ v -> 27 | match v with 28 | | Some _ -> assert false 29 | | None -> Some "2") 30 | ~k:2; 31 | assert_equal (Some "2") (get tbl 2); 32 | assert_equal 2 (Hashtbl.length tbl); 33 | update tbl ~f:(fun _ _ -> None) ~k:1; 34 | assert_equal None (get tbl 1); 35 | true 36 | ;; 37 | 38 | t @@ fun () -> 39 | let tbl = Hashtbl.create 32 in 40 | let v1 = get_or_add tbl ~f:(fun _ -> "1") ~k:1 in 41 | assert_equal "1" v1; 42 | assert_equal (Some "1") (get tbl 1); 43 | let v2 = get_or_add tbl ~f:(fun _ -> "2") ~k:2 in 44 | assert_equal "2" v2; 45 | assert_equal (Some "2") (get tbl 2); 46 | assert_equal "2" (get_or_add tbl ~f:(fun _ -> assert false) ~k:2); 47 | assert_equal 2 (Hashtbl.length tbl); 48 | true 49 | 50 | module TI = Make (CCInt);; 51 | 52 | eq "c" 53 | (let tbl = TI.of_list [ 1, "a"; 2, "b" ] in 54 | TI.get_or tbl 3 ~default:"c") 55 | ;; 56 | 57 | eq "b" 58 | (let tbl = TI.of_list [ 1, "a"; 2, "b" ] in 59 | TI.get_or tbl 2 ~default:"c") 60 | ;; 61 | 62 | t @@ fun () -> 63 | let tbl = TI.create 32 in 64 | TI.incr tbl 1; 65 | TI.incr tbl 2; 66 | TI.incr tbl 1; 67 | assert_equal 2 (TI.find tbl 1); 68 | assert_equal 1 (TI.find tbl 2); 69 | assert_equal 2 (TI.length tbl); 70 | TI.decr tbl 2; 71 | assert_equal 0 (TI.get_or tbl 2 ~default:0); 72 | assert_equal 1 (TI.length tbl); 73 | assert (not (TI.mem tbl 2)); 74 | true 75 | -------------------------------------------------------------------------------- /tests/data/t_fun_vec.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCFun_vec 4 | 5 | let _listuniq = 6 | let g = Q.(small_list (pair small_int small_int)) in 7 | Q.map_same_type 8 | (fun l -> 9 | CCList.sort_uniq ~cmp:(fun a b -> Stdlib.compare (fst a) (fst b)) l) 10 | g 11 | ;; 12 | 13 | t @@ fun () -> is_empty empty;; 14 | t @@ fun () -> not (is_empty (return 2));; 15 | t @@ fun () -> length (return 2) = 1;; 16 | 17 | q _listuniq (fun l -> 18 | let m = of_list l in 19 | List.for_all (fun (i, y) -> get_exn i m = y) @@ List.mapi CCPair.make l) 20 | ;; 21 | 22 | (* regression test for #298 *) 23 | t @@ fun () -> 24 | let rec consume x = 25 | match CCFun_vec.pop x with 26 | | None -> () 27 | | Some (_, x) -> consume x 28 | in 29 | consume (of_list CCList.(1 -- 100)); 30 | true 31 | ;; 32 | 33 | q 34 | Q.(pair int (small_list int)) 35 | (fun (x, l) -> 36 | let q0 = of_list l in 37 | let q = push x q0 in 38 | assert_equal (length q) (length q0 + 1); 39 | let y, q = pop_exn q in 40 | assert_equal x y; 41 | assert_equal (to_list q) (to_list q0); 42 | true) 43 | ;; 44 | 45 | q 46 | Q.(pair (fun1 Observable.int bool) (small_list int)) 47 | (fun (f, l) -> 48 | let f = Q.Fn.apply f in 49 | List.map f l = (of_list l |> map f |> to_list)) 50 | ;; 51 | 52 | q 53 | Q.(pair (small_list int) (small_list int)) 54 | (fun (l1, l2) -> l1 @ l2 = (append (of_list l1) (of_list l2) |> to_list)) 55 | ;; 56 | 57 | q Q.(small_list int) (fun l -> l = to_list (of_list l));; 58 | 59 | q _listuniq (fun l -> 60 | List.sort Stdlib.compare l 61 | = (l |> Iter.of_list |> of_iter |> to_iter |> Iter.to_list 62 | |> List.sort Stdlib.compare)) 63 | ;; 64 | 65 | q _listuniq (fun l -> 66 | List.sort Stdlib.compare l 67 | = (l |> Gen.of_list |> of_gen |> to_gen |> Gen.to_list 68 | |> List.sort Stdlib.compare)) 69 | ;; 70 | 71 | t @@ fun () -> choose empty = None;; 72 | t @@ fun () -> choose (of_list [ 1, 1; 2, 2 ]) <> None 73 | -------------------------------------------------------------------------------- /tests/core/t_IO.ml: -------------------------------------------------------------------------------- 1 | open CCIO 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | t @@ fun () -> 6 | let s = String.make 200 'y' in 7 | let s = Printf.sprintf "a\nb\n %s\nlast line\n" s in 8 | File.with_temp ~prefix:"test_containers" ~suffix:"" (fun name -> 9 | with_out name @@ fun oc -> 10 | output_string oc s; 11 | flush oc; 12 | let s' = with_in name read_all in 13 | assert_equal ~printer:(fun s -> s) s s'); 14 | true 15 | ;; 16 | 17 | q 18 | Q.(list_of_size Gen.(0 -- 40) printable_string) 19 | (fun l -> 20 | let l' = ref [] in 21 | File.with_temp ~prefix:"test_containers" ~suffix:"" (fun name -> 22 | with_out name @@ fun oc -> 23 | write_lines_l oc l; 24 | flush oc; 25 | l' := with_in name read_lines_l); 26 | String.concat "\n" l = String.concat "\n" !l') 27 | ;; 28 | 29 | q 30 | Q.(list_of_size Gen.(0 -- 40) printable_string) 31 | (fun l -> 32 | let l' = ref [] in 33 | File.with_temp ~prefix:"test_containers" ~suffix:"" (fun name -> 34 | with_out name @@ fun oc -> 35 | write_lines oc (Gen.of_list l); 36 | flush oc; 37 | l' := with_in name (fun ic -> read_lines_gen ic |> Gen.to_list)); 38 | String.concat "\n" l = String.concat "\n" !l') 39 | ;; 40 | 41 | q 42 | Q.(list_of_size Gen.(0 -- 40) printable_string) 43 | (fun l -> 44 | let s = ref "" in 45 | File.with_temp ~prefix:"test_containers1" ~suffix:"" (fun name1 -> 46 | with_out name1 @@ fun oc1 -> 47 | write_gen ~sep:"" oc1 (Gen.of_list l); 48 | flush oc1; 49 | File.with_temp ~prefix:"test_containers2" ~suffix:"" (fun name2 -> 50 | with_out name2 @@ fun oc2 -> 51 | CCIO.with_in name1 (fun ic1 -> copy_into ic1 oc2); 52 | flush oc2; 53 | s := with_in name2 read_all)); 54 | String.concat "" l = !s) 55 | ;; 56 | 57 | t @@ fun () -> 58 | File.walk "." 59 | |> Gen.for_all (function 60 | | `File, f -> not (Sys.is_directory f) 61 | | `Dir, f -> Sys.is_directory f) 62 | -------------------------------------------------------------------------------- /tests/thread/t_lock.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCLock;; 4 | 5 | t @@ fun () -> 6 | let l = create 0 in 7 | let try_incr l = 8 | update l (fun x -> 9 | Thread.yield (); 10 | x + 1) 11 | in 12 | for _i = 1 to 10 do 13 | ignore (Thread.create try_incr l) 14 | done; 15 | Thread.delay 0.10; 16 | assert_equal 10 (get l); 17 | true 18 | ;; 19 | 20 | t @@ fun () -> 21 | let l = create 0 in 22 | let test_it l = 23 | with_lock_as_ref l ~f:(fun r -> 24 | (* increment and decrement *) 25 | for j = 0 to 100 do 26 | let x = LockRef.get r in 27 | LockRef.set r (x + 10); 28 | if j mod 5 = 0 then Thread.yield (); 29 | let y = LockRef.get r in 30 | LockRef.set r (y - 10) 31 | done) 32 | in 33 | for _i = 1 to 100 do 34 | ignore (Thread.create test_it l) 35 | done; 36 | Thread.delay 0.10; 37 | 0 = get l 38 | ;; 39 | 40 | t @@ fun () -> 41 | let l = create 5 in 42 | update l (fun x -> x + 1); 43 | get l = 6 44 | ;; 45 | 46 | t @@ fun () -> 47 | let l = create 5 in 48 | update_map l (fun x -> x + 1, string_of_int x) = "5" && get l = 6 49 | ;; 50 | 51 | t @@ fun () -> 52 | let l = create 0 in 53 | set l 4; 54 | get l = 4 55 | ;; 56 | 57 | t @@ fun () -> 58 | let l = create 0 in 59 | set l 4; 60 | set l 5; 61 | get l = 5 62 | ;; 63 | 64 | t @@ fun () -> 65 | let l = create 0 in 66 | let a = Array.init 100 (fun _ -> Thread.create (fun _ -> incr l) ()) in 67 | Array.iter Thread.join a; 68 | assert_equal ~printer:CCInt.to_string 100 (get l); 69 | true 70 | ;; 71 | 72 | t @@ fun () -> 73 | let l = create 0 in 74 | incr l; 75 | get l = 1 76 | ;; 77 | 78 | t @@ fun () -> 79 | let l = create 0 in 80 | decr l; 81 | get l = ~-1 82 | ;; 83 | 84 | t @@ fun () -> 85 | let l = create 0 in 86 | 1 = incr_then_get l && 1 = get l 87 | ;; 88 | 89 | t @@ fun () -> 90 | let l = create 0 in 91 | 0 = get_then_incr l && 1 = get l 92 | ;; 93 | 94 | t @@ fun () -> 95 | let l = create 10 in 96 | 9 = decr_then_get l && 9 = get l 97 | ;; 98 | 99 | t @@ fun () -> 100 | let l = create 10 in 101 | 10 = get_then_decr l && 9 = get l 102 | -------------------------------------------------------------------------------- /src/codegen/tests/emit_tests.ml: -------------------------------------------------------------------------------- 1 | module CG = Containers_codegen 2 | module Vec = CCVector 3 | 4 | let spf = Printf.sprintf 5 | 6 | let emit_bitfields () = 7 | let module B = CG.Bitfield in 8 | let ml = Vec.create () in 9 | let mli = Vec.create () in 10 | (let b = B.make ~name:"t" () in 11 | B.field_bit b "x"; 12 | B.field_bit b "y"; 13 | B.field_bit b "z"; 14 | B.field_int b ~width:5 "foo"; 15 | 16 | Vec.push ml (CG.Code.in_struct "T1" [ B.gen_ml b ]); 17 | Vec.push mli (CG.Code.in_sig "T1" [ B.gen_mli b ]); 18 | (* check width *) 19 | Vec.push ml 20 | (CG.Code.mk_str (spf "let() = assert (%d = 8);;" (B.total_width b))); 21 | ()); 22 | 23 | Vec.push ml 24 | @@ CG.Code.mk_str 25 | {| 26 | let n_fails = ref 0;; 27 | at_exit (fun () -> if !n_fails > 0 then exit 1);; 28 | let assert_true line s = 29 | if not s then ( incr n_fails; Printf.eprintf "test failure at %d\n%!" line);; 30 | 31 | |}; 32 | 33 | let test1 = 34 | {| 35 | assert_true __LINE__ T1.(get_y (empty |> set_x true |> set_y true |> set_foo 10));; 36 | assert_true __LINE__ T1.(get_x (empty |> set_x true |> set_y true |> set_foo 10));; 37 | assert_true __LINE__ T1.(get_y (empty |> set_x true |> set_z true 38 | |> set_y false |> set_x false |> set_y true));; 39 | assert_true __LINE__ T1.(get_z (empty |> set_z true));; 40 | assert_true __LINE__ T1.(not @@ get_x (empty |> set_z true));; 41 | assert_true __LINE__ T1.(not @@ get_y (empty |> set_z true |> set_x true));; 42 | assert_true __LINE__ T1.(not @@ get_y (empty |> set_z true |> set_foo 18));; 43 | (* check width of foo *) 44 | assert_true __LINE__ T1.(try ignore (empty |> set_foo (1 lsl 6)); false with _ -> true);; 45 | assert_true __LINE__ T1.(12 = get_foo (empty |> set_x true |> set_foo 12 |> set_x false));; 46 | assert_true __LINE__ T1.(24 = get_foo (empty |> set_y true |> set_foo 24 |> set_z true));; 47 | |} 48 | |> CG.Code.mk_str 49 | in 50 | Vec.push ml test1; 51 | 52 | CG.emit_file "test_bitfield.ml" (Vec.to_list ml); 53 | CG.emit_file "test_bitfield.mli" (Vec.to_list mli); 54 | () 55 | 56 | let () = 57 | emit_bitfields (); 58 | () 59 | -------------------------------------------------------------------------------- /src/core/CCOrd.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Comparisons} *) 4 | 5 | open CCShims_ 6 | 7 | type 'a t = 'a -> 'a -> int 8 | (** Comparison (total ordering) between two elements, that returns an int *) 9 | 10 | let poly = Stdlib.compare 11 | let compare = Stdlib.compare 12 | let opp f x y = -f x y 13 | 14 | let equiv i j = 15 | if i < 0 then 16 | j < 0 17 | else if i > 0 then 18 | j > 0 19 | else 20 | j = 0 21 | 22 | let int (x : int) y = Stdlib.compare x y 23 | let string (x : string) y = Stdlib.compare x y 24 | let bool (x : bool) y = Stdlib.compare x y 25 | let float (x : float) y = Stdlib.compare x y 26 | 27 | (** {2 Lexicographic Combination} *) 28 | 29 | let ( ) c (ord, x, y) = 30 | if c = 0 then 31 | ord x y 32 | else 33 | c 34 | 35 | let option c o1 o2 = 36 | match o1, o2 with 37 | | None, None -> 0 38 | | None, Some _ -> -1 39 | | Some _, None -> 1 40 | | Some x1, Some x2 -> c x1 x2 41 | 42 | let pair o_x o_y (x1, y1) (x2, y2) = 43 | let c = o_x x1 x2 in 44 | if c = 0 then 45 | o_y y1 y2 46 | else 47 | c 48 | 49 | let triple o_x o_y o_z (x1, y1, z1) (x2, y2, z2) = 50 | let c = o_x x1 x2 in 51 | if c = 0 then ( 52 | let c' = o_y y1 y2 in 53 | if c' = 0 then 54 | o_z z1 z2 55 | else 56 | c' 57 | ) else 58 | c 59 | 60 | let rec list ord l1 l2 = 61 | match l1, l2 with 62 | | [], [] -> 0 63 | | [], _ -> -1 64 | | _, [] -> 1 65 | | x1 :: l1', x2 :: l2' -> 66 | let c = ord x1 x2 in 67 | if c = 0 then 68 | list ord l1' l2' 69 | else 70 | c 71 | 72 | let array ord a1 a2 = 73 | let rec aux i = 74 | if i = Array.length a1 then 75 | if Array.length a1 = Array.length a2 then 76 | 0 77 | else 78 | -1 79 | else if i = Array.length a2 then 80 | 1 81 | else ( 82 | let c = ord a1.(i) a2.(i) in 83 | if c = 0 then 84 | aux (i + 1) 85 | else 86 | c 87 | ) 88 | in 89 | aux 0 90 | 91 | let map f ord a b = ord (f a) (f b) 92 | let ( >|= ) x f = map f x 93 | 94 | module Infix = struct 95 | let ( >|= ) = ( >|= ) 96 | let ( ) = ( ) 97 | end 98 | -------------------------------------------------------------------------------- /examples/ccparse_irclogs_real.cond.ml: -------------------------------------------------------------------------------- 1 | (* parse IRC logs *) 2 | 3 | type datetime = { 4 | year: int; 5 | month: int; 6 | day: int; 7 | hour: int; 8 | min: int; 9 | sec: int; 10 | } 11 | 12 | let pp_datetime out d = 13 | let { year; month; day; hour; min; sec } = d in 14 | CCFormat.( 15 | fprintf out "{y=%d;M=%d;d=%d;h=%d;m=%d;s=%d}" year month day hour min sec) 16 | 17 | type msg = { timestamp: datetime; user: string; msg: string } 18 | 19 | let pp_msg out m = 20 | CCFormat.fprintf out "{@[time=%a;@ user=%S;@ msg=%S@]}" pp_datetime 21 | m.timestamp m.user m.msg 22 | 23 | open CCParse 24 | 25 | let p_datetime : datetime t = 26 | let int = U.int in 27 | let* date, time = split_2 ~on_char:' ' in 28 | let* y, m, d = recurse date (split_3 ~on_char:'-') in 29 | let* year = recurse y int in 30 | let* month = recurse m int in 31 | let* day = recurse d int in 32 | let* hour, min, sec = 33 | recurse time 34 | (let* hour = int in 35 | char ':' 36 | *> let* min = int in 37 | char ':' 38 | *> let+ sec = int in 39 | hour, min, sec) 40 | in 41 | let dt = { year; month; day; hour; min; sec } in 42 | return dt 43 | 44 | let p_line = 45 | let* line = lookahead all in 46 | 47 | if Slice.is_empty line then 48 | return None 49 | else 50 | let* fields = split_list ~on_char:'\t' in 51 | match fields with 52 | | [ date; user; rest ] -> 53 | let+ timestamp = recurse date p_datetime 54 | and+ user = 55 | recurse user 56 | (chars_if (function 57 | | '>' -> false 58 | | _ -> true)) 59 | and+ msg = recurse rest (all_str >|= String.trim) in 60 | Some { timestamp; user; msg } 61 | | _ -> 62 | failf "expected 3 fields, got [%s]" 63 | (String.concat ";" @@ List.map String.escaped 64 | @@ List.map Slice.to_string fields) 65 | 66 | let p_file = each_line (parsing "line" p_line) >|= CCList.keep_some 67 | 68 | let () = 69 | let s = CCIO.File.read_exn Sys.argv.(1) in 70 | match parse_string p_file s with 71 | | Ok l -> 72 | Format.printf "parsed:@."; 73 | List.iter (Format.printf "%a@." pp_msg) l 74 | | Error e -> 75 | Format.printf "parse error: %s@." e; 76 | exit 1 77 | -------------------------------------------------------------------------------- /src/core/CCEither.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Either Monad 4 | 5 | Module that is compatible with Either form OCaml 4.12 but can be use with any 6 | ocaml version compatible with container 7 | 8 | @since 3.2 9 | *) 10 | 11 | type 'a iter = ('a -> unit) -> unit 12 | type 'a equal = 'a -> 'a -> bool 13 | type 'a ord = 'a -> 'a -> int 14 | type 'a printer = Format.formatter -> 'a -> unit 15 | 16 | (** {2 Basics} *) 17 | 18 | type ('a, 'b) t = ('a, 'b) Either.t = Left of 'a | Right of 'b 19 | 20 | val left : 'a -> ('a, 'b) t 21 | (** [left l] is [Left l] *) 22 | 23 | val right : 'b -> ('a, 'b) t 24 | (** [right r] is [Right r] *) 25 | 26 | val is_left : ('a, 'b) t -> bool 27 | (** [is_left x] checks if [x = Left _] *) 28 | 29 | val is_right : ('a, 'b) t -> bool 30 | (** [is_right x] checks if [x = Right _] *) 31 | 32 | val find_left : ('a, 'b) t -> 'a option 33 | (** [find_left x] returns [l] if [x = Left l] and [None] otherwise. *) 34 | 35 | val find_right : ('a, 'b) t -> 'b option 36 | (** [find_right x] returns [r] if [x = Left r] and [None] otherwise. *) 37 | 38 | val map_left : ('a1 -> 'a2) -> ('a1, 'b) t -> ('a2, 'b) t 39 | (** Map of the Left variant. *) 40 | 41 | val map_right : ('b1 -> 'b2) -> ('a, 'b1) t -> ('a, 'b2) t 42 | (** Map of the Right variant. *) 43 | 44 | val map : 45 | left:('a1 -> 'a2) -> right:('b1 -> 'b2) -> ('a1, 'b1) t -> ('a2, 'b2) t 46 | (** Map using [left] or [right]. *) 47 | 48 | val fold : left:('a -> 'c) -> right:('b -> 'c) -> ('a, 'b) t -> 'c 49 | (** Fold using [left] or [right]. *) 50 | 51 | val iter : left:('a -> unit) -> right:('b -> unit) -> ('a, 'b) t -> unit 52 | (** Iter using [left] or [right]. *) 53 | 54 | val for_all : left:('a -> bool) -> right:('b -> bool) -> ('a, 'b) t -> bool 55 | (** Check some property on [Left] or [Right] variant. *) 56 | 57 | val equal : 58 | left:('a -> 'a -> bool) -> 59 | right:('b -> 'b -> bool) -> 60 | ('a, 'b) t -> 61 | ('a, 'b) t -> 62 | bool 63 | 64 | val compare : 65 | left:('a -> 'a -> int) -> 66 | right:('b -> 'b -> int) -> 67 | ('a, 'b) t -> 68 | ('a, 'b) t -> 69 | int 70 | 71 | (** {2 IO} *) 72 | 73 | val pp : left:'a printer -> right:'b printer -> ('a, 'b) t printer 74 | (** Pretty printer. *) 75 | -------------------------------------------------------------------------------- /tests/data/t_immutarray.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCImmutArray 4 | 5 | let print_array f a = to_list a |> Array.of_list |> Q.Print.(array f);; 6 | 7 | eq ~printer:(print_array Q.Print.int) (of_list [ 0 ]) (set (of_list [ 5 ]) 0 0) 8 | ;; 9 | 10 | eq ~printer:(print_array Q.Print.int) 11 | (of_list [ 1; 3; 4; 5 ]) 12 | (set (of_list [ 1; 2; 4; 5 ]) 1 3) 13 | 14 | let eq' = eq ~printer:(print_array Q.Print.int);; 15 | 16 | eq' empty (append empty empty);; 17 | eq' (of_list [ 1; 2; 3 ]) (append empty (of_list [ 1; 2; 3 ]));; 18 | eq' (of_list [ 1; 2; 3 ]) (append (of_list [ 1; 2; 3 ]) empty);; 19 | 20 | eq' 21 | (of_list [ 3; 1; 4; 1; 5 ]) 22 | (append (of_list [ 3; 1 ]) (of_list [ 4; 1; 5 ])) 23 | ;; 24 | 25 | eq 26 | ~printer:Q.Print.(list (pair int string)) 27 | [ 2, "baz"; 1, "bar"; 0, "foo" ] 28 | (foldi (fun l i a -> (i, a) :: l) [] (of_list [ "foo"; "bar"; "baz" ])) 29 | 30 | let eq' = eq ~printer:Q.Print.bool;; 31 | 32 | eq' true (for_all (fun _ -> false) empty);; 33 | eq' false (for_all (fun _ -> false) (singleton 3));; 34 | eq' true (for_all (fun n -> n mod 2 = 0) (of_list [ 2; 4; 8 ]));; 35 | eq' false (for_all (fun n -> n mod 2 = 0) (of_list [ 2; 4; 5; 8 ]));; 36 | eq' false (exists (fun _ -> true) empty);; 37 | eq' true (exists (fun _ -> true) (singleton 3));; 38 | eq' false (exists (fun _ -> false) (singleton 3));; 39 | eq' false (exists (fun n -> n mod 2 = 1) (of_list [ 2; 4; 8 ]));; 40 | eq' true (exists (fun n -> n mod 2 = 1) (of_list [ 2; 4; 5; 8 ]));; 41 | 42 | q 43 | Q.(list bool) 44 | (fun l -> 45 | let a = of_list l in 46 | not @@ exists (fun b -> b) a = for_all not a) 47 | ;; 48 | 49 | q 50 | Q.(list bool) 51 | (fun l -> 52 | let a = of_list l in 53 | not @@ for_all (fun b -> b) a = exists not a) 54 | ;; 55 | 56 | q 57 | Q.(list bool) 58 | (fun l -> exists (fun b -> b) (of_list l) = List.fold_left ( || ) false l) 59 | ;; 60 | 61 | q 62 | Q.(list bool) 63 | (fun l -> for_all (fun b -> b) (of_list l) = List.fold_left ( && ) true l) 64 | ;; 65 | 66 | q 67 | Q.(list int) 68 | (fun l -> 69 | let g = Iter.of_list l in 70 | of_iter g |> to_iter |> Iter.to_list = l) 71 | ;; 72 | 73 | q 74 | Q.(list int) 75 | (fun l -> 76 | let g = Gen.of_list l in 77 | of_gen g |> to_gen |> Gen.to_list = l) 78 | -------------------------------------------------------------------------------- /src/core/CCFun.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Basic Functions} *) 4 | 5 | let opaque_identity x = x 6 | 7 | (* import standard implementations, if any *) 8 | 9 | include Sys 10 | include CCShims_.Stdlib 11 | 12 | [@@@ifge 4.8] 13 | 14 | include Fun 15 | 16 | [@@@else_] 17 | 18 | external id : 'a -> 'a = "%identity" 19 | 20 | let[@inline] flip f x y = f y x 21 | let[@inline] const x _ = x 22 | let[@inline] negate f x = not (f x) 23 | 24 | let[@inline] protect ~finally f = 25 | try 26 | let x = f () in 27 | finally (); 28 | x 29 | with e -> 30 | finally (); 31 | raise e 32 | 33 | [@@@endif] 34 | 35 | let compose f g x = g (f x) 36 | let compose_binop f g x y = g (f x) (f y) 37 | let curry f x y = f (x, y) 38 | let uncurry f (x, y) = f x y 39 | 40 | let tap f x = 41 | ignore (f x); 42 | x 43 | 44 | let lexicographic f1 f2 x y = 45 | let c = f1 x y in 46 | if c <> 0 then 47 | c 48 | else 49 | f2 x y 50 | 51 | let finally ~h ~f = 52 | try 53 | let x = f () in 54 | ignore (h ()); 55 | x 56 | with e -> 57 | ignore (h ()); 58 | raise e 59 | 60 | let finally1 ~h f x = 61 | try 62 | let res = f x in 63 | ignore (h ()); 64 | res 65 | with e -> 66 | ignore (h ()); 67 | raise e 68 | 69 | let finally2 ~h f x y = 70 | try 71 | let res = f x y in 72 | ignore (h ()); 73 | res 74 | with e -> 75 | ignore (h ()); 76 | raise e 77 | 78 | let rec iterate n f x = 79 | if n < 0 then 80 | invalid_arg "CCFun.iterate" 81 | else if n = 0 then 82 | x 83 | else 84 | iterate (n - 1) f (f x) 85 | 86 | module Infix = struct 87 | (* default implem for some operators *) 88 | let ( |> ) = CCShims_.Stdlib.( |> ) 89 | let ( @@ ) = CCShims_.Stdlib.( @@ ) 90 | let ( %> ) = compose 91 | let[@inline] ( % ) f g x = f (g x) 92 | 93 | [@@@ifge 4.8] 94 | 95 | let ( let@ ) = ( @@ ) 96 | 97 | [@@@endif] 98 | end 99 | 100 | include Infix 101 | 102 | module Monad (X : sig 103 | type t 104 | end) = 105 | struct 106 | type 'a t = X.t -> 'a 107 | 108 | let[@inline] return x _ = x 109 | let[@inline] ( >|= ) f g x = g (f x) 110 | let[@inline] ( >>= ) f g x = g (f x) x 111 | end 112 | [@@inline] 113 | -------------------------------------------------------------------------------- /examples/ccparse_sexp.ml: -------------------------------------------------------------------------------- 1 | open CCParse 2 | 3 | type sexp = Atom of string | List of sexp list 4 | 5 | let rec pp_sexpr out (s : sexp) : unit = 6 | match s with 7 | | Atom s -> Format.fprintf out "%S" s 8 | | List l -> 9 | Format.fprintf out "(@["; 10 | List.iteri 11 | (fun i s -> 12 | if i > 0 then Format.fprintf out "@ "; 13 | pp_sexpr out s) 14 | l; 15 | Format.fprintf out "@])" 16 | 17 | let str_of_sexp = CCFormat.to_string pp_sexpr 18 | 19 | let skip_white_and_comments = 20 | fix @@ fun self -> 21 | skip_white 22 | *> try_or (char ';') 23 | ~f:(fun _ -> 24 | skip_chars (function 25 | | '\n' -> false 26 | | _ -> true) 27 | *> self) 28 | ~else_:(return ()) 29 | 30 | let atom = 31 | chars_fold_transduce `Start ~f:(fun acc c -> 32 | match acc, c with 33 | | `Start, '"' -> `Continue `In_quote 34 | | `Start, (' ' | '\t' | '\n' | '(' | ')' | ';') -> `Fail "atom" 35 | | `Normal, (' ' | '\t' | '\n' | '(' | ')' | ';') -> `Stop 36 | | `Done, _ -> `Stop 37 | | `In_quote, '"' -> `Continue `Done (* consume *) 38 | | `In_quote, '\\' -> `Continue `Escape 39 | | `In_quote, c -> `Yield (`In_quote, c) 40 | | `Escape, 'n' -> `Yield (`In_quote, '\n') 41 | | `Escape, 't' -> `Yield (`In_quote, '\t') 42 | | `Escape, '"' -> `Yield (`In_quote, '"') 43 | | `Escape, '\\' -> `Yield (`In_quote, '\\') 44 | | `Escape, c -> `Fail (Printf.sprintf "unknown escape code \\%c" c) 45 | | (`Start | `Normal), c -> `Yield (`Normal, c) 46 | | _ -> `Fail "invalid atom") 47 | >>= function 48 | | `In_quote, _ -> fail "unclosed \"" 49 | | `Escape, _ -> fail "unfinished escape sequence" 50 | | _, "" -> fail "expected non-empty atom" 51 | | _, s -> return (Atom s) 52 | 53 | let psexp = 54 | fix @@ fun self -> 55 | skip_white_and_comments 56 | *> try_or (char '(') 57 | ~f:(fun _ -> 58 | sep ~by:skip_white_and_comments self 59 | <* skip_white_and_comments <* char ')' 60 | >|= fun l -> List l) 61 | ~else_:atom 62 | 63 | let psexp_l = many_until ~until:(skip_white_and_comments *> eoi) psexp 64 | 65 | let () = 66 | let s = CCIO.File.read_exn Sys.argv.(1) in 67 | match parse_string psexp_l s with 68 | | Ok l -> 69 | Format.printf "parsed:@."; 70 | List.iter (Format.printf "%a@." pp_sexpr) l 71 | | Error e -> 72 | Format.printf "parse error: %s@." e; 73 | exit 1 74 | -------------------------------------------------------------------------------- /tests/data/t_graph.ml: -------------------------------------------------------------------------------- 1 | module Test = (val Containers_testlib.make ~__FILE__ ()) 2 | open Test 3 | open CCGraph;; 4 | 5 | t @@ fun () -> 6 | let l = 7 | let tbl = mk_table ~eq:CCInt.equal 128 in 8 | Traverse.Event.dfs ~tbl ~eq:CCInt.equal ~graph:divisors_graph 9 | (Iter.return 345614) 10 | |> Iter.to_list 11 | in 12 | let expected = 13 | [ 14 | `Enter (345614, 0, []); 15 | `Edge (345614, (), 172807, `Forward); 16 | `Enter (172807, 1, [ 345614, (), 172807 ]); 17 | `Edge (172807, (), 1, `Forward); 18 | `Enter (1, 2, [ 172807, (), 1; 345614, (), 172807 ]); 19 | `Exit 1; 20 | `Exit 172807; 21 | `Edge (345614, (), 2, `Forward); 22 | `Enter (2, 3, [ 345614, (), 2 ]); 23 | `Edge (2, (), 1, `Cross); 24 | `Exit 2; 25 | `Edge (345614, (), 1, `Cross); 26 | `Exit 345614; 27 | ] 28 | in 29 | assert_equal expected l; 30 | true 31 | ;; 32 | 33 | t @@ fun () -> 34 | let tbl = mk_table ~eq:CCInt.equal 128 in 35 | let l = topo_sort ~eq:CCInt.equal ~tbl ~graph:divisors_graph (Iter.return 42) in 36 | List.for_all 37 | (fun (i, j) -> 38 | let idx_i = CCList.find_idx (( = ) i) l |> CCOption.get_exn_or "" |> fst in 39 | let idx_j = CCList.find_idx (( = ) j) l |> CCOption.get_exn_or "" |> fst in 40 | idx_i < idx_j) 41 | [ 42, 21; 14, 2; 3, 1; 21, 7; 42, 3 ] 42 | ;; 43 | 44 | t @@ fun () -> 45 | let tbl = mk_table ~eq:CCInt.equal 128 in 46 | let l = 47 | topo_sort ~eq:CCInt.equal ~rev:true ~tbl ~graph:divisors_graph 48 | (Iter.return 42) 49 | in 50 | List.for_all 51 | (fun (i, j) -> 52 | let idx_i = CCList.find_idx (( = ) i) l |> CCOption.get_exn_or "" |> fst in 53 | let idx_j = CCList.find_idx (( = ) j) l |> CCOption.get_exn_or "" |> fst in 54 | idx_i > idx_j) 55 | [ 42, 21; 14, 2; 3, 1; 21, 7; 42, 3 ] 56 | ;; 57 | 58 | (* example from https://en.wikipedia.org/wiki/Strongly_connected_component *) 59 | t @@ fun () -> 60 | let set_eq ?(eq = ( = )) l1 l2 = 61 | CCList.subset ~eq l1 l2 && CCList.subset ~eq l2 l1 62 | in 63 | let graph = 64 | of_list ~eq:CCString.equal 65 | [ 66 | "a", "b"; 67 | "b", "e"; 68 | "e", "a"; 69 | "b", "f"; 70 | "e", "f"; 71 | "f", "g"; 72 | "g", "f"; 73 | "b", "c"; 74 | "c", "g"; 75 | "c", "d"; 76 | "d", "c"; 77 | "d", "h"; 78 | "h", "d"; 79 | "h", "g"; 80 | ] 81 | in 82 | let tbl = mk_table ~eq:CCString.equal 128 in 83 | let res = scc ~tbl ~graph (Iter.return "a") |> Iter.to_list in 84 | assert_bool "scc" 85 | (set_eq ~eq:(set_eq ?eq:None) res 86 | [ [ "a"; "b"; "e" ]; [ "f"; "g" ]; [ "c"; "d"; "h" ] ]); 87 | true 88 | -------------------------------------------------------------------------------- /src/data/CCBijection.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Functor to build a bijection 4 | Represents 1-to-1 mappings between two types. Each element from the "left" 5 | is mapped to one "right" value, and conversely. 6 | 7 | @since 2.1 *) 8 | 9 | type 'a iter = ('a -> unit) -> unit 10 | 11 | module type OrderedType = sig 12 | type t 13 | 14 | val compare : t -> t -> int 15 | end 16 | 17 | module type S = sig 18 | type t 19 | type left 20 | type right 21 | 22 | val empty : t 23 | val is_empty : t -> bool 24 | val equal : t -> t -> bool 25 | val compare : t -> t -> int 26 | 27 | val add : left -> right -> t -> t 28 | (** Add [left] and [right] correspondence to bijection such that 29 | [left] and [right] are unique in their respective sets and only 30 | correspond to each other. *) 31 | 32 | val cardinal : t -> int 33 | (** Number of bindings. O(n) time. *) 34 | 35 | val mem : left -> right -> t -> bool 36 | (** Check both sides for key membership. *) 37 | 38 | val mem_left : left -> t -> bool 39 | (** Check for membership of correspondence using [left] key. *) 40 | 41 | val mem_right : right -> t -> bool 42 | (** Check for membership of correspondence using [right] key. *) 43 | 44 | val find_left : left -> t -> right 45 | (** @raise Not_found if left is not found. *) 46 | 47 | val find_right : right -> t -> left 48 | (** @raise Not_found if right is not found. *) 49 | 50 | val remove : left -> right -> t -> t 51 | (** Remove the [left], [right] binding if it exists. Return the 52 | same bijection otherwise. *) 53 | 54 | val remove_left : left -> t -> t 55 | (** Remove the binding with [left] key if it exists. Return the 56 | same bijection otherwise. *) 57 | 58 | val remove_right : right -> t -> t 59 | (** Remove the binding with [right] key if it exists. Return the 60 | same bijection otherwise. *) 61 | 62 | val list_left : t -> (left * right) list 63 | (** Return the bindings as a list of ([left], [right]) values. *) 64 | 65 | val list_right : t -> (right * left) list 66 | (** Return the bindings as a list of [(right, left)] values. *) 67 | 68 | val add_iter : (left * right) iter -> t -> t 69 | val of_iter : (left * right) iter -> t 70 | val to_iter : t -> (left * right) iter 71 | val add_list : (left * right) list -> t -> t 72 | val of_list : (left * right) list -> t 73 | val to_list : t -> (left * right) list 74 | end 75 | 76 | module Make (L : OrderedType) (R : OrderedType) : 77 | S with type left = L.t and type right = R.t 78 | -------------------------------------------------------------------------------- /src/data/CCHet.mli: -------------------------------------------------------------------------------- 1 | (** Associative containers with Heterogeneous Values 2 | 3 | This is similar to {!CCMixtbl}, but the injection is directly used as 4 | a key. 5 | 6 | @since 0.17 *) 7 | 8 | (* This file is free software, part of containers. See file "license" for more details. *) 9 | 10 | type 'a iter = ('a -> unit) -> unit 11 | type 'a gen = unit -> 'a option 12 | 13 | (** Keys with a type witness. *) 14 | module Key : sig 15 | type 'a t 16 | (** A key of type ['a t] is used to access the portion of the 17 | map or table that associates keys of type ['a] to values. *) 18 | 19 | val create : unit -> 'a t 20 | (** Make a new key. This is generative, so calling [create ()] twice with the 21 | same return type will produce incompatible keys that cannot see each 22 | other's bindings. *) 23 | 24 | val equal : 'a t -> 'a t -> bool 25 | (** Compare two keys that have compatible types. *) 26 | end 27 | 28 | type pair = Pair : 'a Key.t * 'a -> pair 29 | 30 | (** {2 Imperative table indexed by [Key]} *) 31 | module Tbl : sig 32 | type t 33 | 34 | val create : ?size:int -> unit -> t 35 | val mem : t -> _ Key.t -> bool 36 | val add : t -> 'a Key.t -> 'a -> unit 37 | val remove : t -> _ Key.t -> unit 38 | val length : t -> int 39 | val find : t -> 'a Key.t -> 'a option 40 | 41 | val clear : t -> unit 42 | (** clear the table (like {!Hashtbl.clear}) 43 | @since 3.11 *) 44 | 45 | val reset : t -> unit 46 | (** reset the table (like {!Hashtbl.reset}) 47 | @since 3.11 *) 48 | 49 | val find_exn : t -> 'a Key.t -> 'a 50 | (** @raise Not_found if the key is not in the table. *) 51 | 52 | val iter : (pair -> unit) -> t -> unit 53 | val to_iter : t -> pair iter 54 | val of_iter : pair iter -> t 55 | val add_iter : t -> pair iter -> unit 56 | val add_list : t -> pair list -> unit 57 | val of_list : pair list -> t 58 | val to_list : t -> pair list 59 | end 60 | 61 | (** {2 Immutable map} *) 62 | module Map : sig 63 | type t 64 | 65 | val empty : t 66 | val mem : _ Key.t -> t -> bool 67 | val add : 'a Key.t -> 'a -> t -> t 68 | val remove : _ Key.t -> t -> t 69 | val length : t -> int 70 | val cardinal : t -> int 71 | val find : 'a Key.t -> t -> 'a option 72 | 73 | val find_exn : 'a Key.t -> t -> 'a 74 | (** @raise Not_found if the key is not in the table. *) 75 | 76 | val iter : (pair -> unit) -> t -> unit 77 | val to_iter : t -> pair iter 78 | val of_iter : pair iter -> t 79 | val add_iter : t -> pair iter -> t 80 | val add_list : t -> pair list -> t 81 | val of_list : pair list -> t 82 | val to_list : t -> pair list 83 | end 84 | -------------------------------------------------------------------------------- /src/threads/CCLock.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Utils around Mutex} *) 4 | 5 | type 'a t = { mutex: Mutex.t; mutable content: 'a } 6 | type 'a lock = 'a t 7 | 8 | let create content = { mutex = Mutex.create (); content } 9 | 10 | let with_lock l f = 11 | Mutex.lock l.mutex; 12 | try 13 | let x = f l.content in 14 | Mutex.unlock l.mutex; 15 | x 16 | with e -> 17 | Mutex.unlock l.mutex; 18 | raise e 19 | 20 | let try_with_lock l f = 21 | if Mutex.try_lock l.mutex then ( 22 | try 23 | let x = f l.content in 24 | Mutex.unlock l.mutex; 25 | Some x 26 | with e -> 27 | Mutex.unlock l.mutex; 28 | raise e 29 | ) else 30 | None 31 | 32 | module LockRef = struct 33 | type 'a t = 'a lock 34 | 35 | let get t = t.content 36 | let set t x = t.content <- x 37 | let update t f = t.content <- f t.content 38 | end 39 | 40 | let with_lock_as_ref l ~f = 41 | Mutex.lock l.mutex; 42 | try 43 | let x = f l in 44 | Mutex.unlock l.mutex; 45 | x 46 | with e -> 47 | Mutex.unlock l.mutex; 48 | raise e 49 | 50 | let mutex l = l.mutex 51 | let update l f = with_lock l (fun x -> l.content <- f x) 52 | 53 | let update_map l f = 54 | with_lock l (fun x -> 55 | let x', y = f x in 56 | l.content <- x'; 57 | y) 58 | 59 | let get l = 60 | Mutex.lock l.mutex; 61 | let x = l.content in 62 | Mutex.unlock l.mutex; 63 | x 64 | 65 | let set l x = 66 | Mutex.lock l.mutex; 67 | l.content <- x; 68 | Mutex.unlock l.mutex 69 | 70 | let incr l = update l Stdlib.succ 71 | let decr l = update l Stdlib.pred 72 | 73 | let incr_then_get l = 74 | Mutex.lock l.mutex; 75 | l.content <- l.content + 1; 76 | let x = l.content in 77 | Mutex.unlock l.mutex; 78 | x 79 | 80 | let get_then_incr l = 81 | Mutex.lock l.mutex; 82 | let x = l.content in 83 | l.content <- l.content + 1; 84 | Mutex.unlock l.mutex; 85 | x 86 | 87 | let decr_then_get l = 88 | Mutex.lock l.mutex; 89 | l.content <- l.content - 1; 90 | let x = l.content in 91 | Mutex.unlock l.mutex; 92 | x 93 | 94 | let get_then_decr l = 95 | Mutex.lock l.mutex; 96 | let x = l.content in 97 | l.content <- l.content - 1; 98 | Mutex.unlock l.mutex; 99 | x 100 | 101 | let get_then_set l = 102 | Mutex.lock l.mutex; 103 | let x = l.content in 104 | l.content <- true; 105 | Mutex.unlock l.mutex; 106 | x 107 | 108 | let get_then_clear l = 109 | Mutex.lock l.mutex; 110 | let x = l.content in 111 | l.content <- false; 112 | Mutex.unlock l.mutex; 113 | x 114 | -------------------------------------------------------------------------------- /doc/containers.md: -------------------------------------------------------------------------------- 1 | # More about OCaml-containers 2 | 3 | This document contains more information on some modules of Containers. 4 | 5 | ```ocaml 6 | # #require "containers";; 7 | ``` 8 | 9 | ## Hash combinators: `CCHash` 10 | 11 | Although OCaml provides polymorphic hash tables (`('a,'b) Hashtbl.t`) 12 | using the polymorphic equality `(=)` and hash `Hashtbl.hash`, it is often 13 | safer and more efficient to use `Hashtbl.Make` (or the extended `CCHashtbl.Make`) 14 | with custom equality and hash functions. 15 | 16 | `CCHash` provides combinators for writing hash functions: 17 | 18 | ```ocaml 19 | # module H = CCHash;; 20 | module H = CCHash 21 | 22 | # let hash1 : (int * bool) list H.t = H.(list (pair int bool));; 23 | val hash1 : (int * bool) list H.t = 24 | ``` 25 | 26 | ```ocaml non-deterministic=output 27 | # hash1 [1, true; 2, false; 3, true];; 28 | - : int = 636041136 29 | # hash1 CCList.(1 -- 1000 |> map (fun i->i, i mod 2 = 0));; 30 | - : int = 845685523 31 | # hash1 CCList.(1 -- 1001 |> map (fun i->i, i mod 2 = 0));; 32 | - : int = 381026697 33 | ``` 34 | 35 | The polymorphic hash function is still present, as `CCHash.poly`. 36 | The functions `CCHash.list_comm` and `CCHash.array_comm` allow to hash 37 | lists and arrays while ignoring the order of elements: all permutations 38 | of the input will have the same hash. 39 | 40 | ## Parser Combinator: `CCParse` 41 | 42 | The module `CCParse` defines basic parser combinators on strings. 43 | Adapting [angstrom's tutorial example](https://github.com/inhabitedtype/angstrom#usage) 44 | gives the following snippet. 45 | Note that backtracking is explicit in `CCParse`, hence 46 | the use of `try_` to allow it in some places. 47 | Explicit memoization with `memo` and `fix_memo` is also possible. 48 | 49 | ```ocaml 50 | open CCParse.Infix 51 | module P = CCParse 52 | 53 | let parens p = P.try_ (P.char '(') *> p <* P.char ')' 54 | let add = P.char '+' *> P.return (+) 55 | let sub = P.char '-' *> P.return (-) 56 | let mul = P.char '*' *> P.return ( * ) 57 | let div = P.char '/' *> P.return ( / ) 58 | let integer = 59 | P.chars1_if (function '0'..'9'->true|_->false) >|= int_of_string 60 | 61 | let chainl1 e op = 62 | P.fix (fun r -> 63 | e >>= fun x -> P.try_ (op <*> P.return x <*> r) <|> P.return x) 64 | 65 | let expr : int P.t = 66 | P.fix (fun expr -> 67 | let factor = parens expr <|> integer in 68 | let term = chainl1 factor (mul <|> div) in 69 | chainl1 term (add <|> sub)) 70 | ``` 71 | 72 | Now we can parse strings using `expr`: 73 | 74 | ```ocaml 75 | # P.parse_string expr "4*1+2";; (* Ok 6 *) 76 | - : int P.or_error = Result.Ok 6 77 | 78 | # P.parse_string expr "4*(1+2)";; (* Ok 12 *) 79 | - : int P.or_error = Result.Ok 12 80 | ``` 81 | 82 | -------------------------------------------------------------------------------- /src/data/CCZipper.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** List Zipper 4 | 5 | @since 1.0 *) 6 | 7 | type 'a t = 'a list * 'a list 8 | (** The pair [l, r] represents the list [List.rev_append l r], but 9 | with the focus on [r] *) 10 | 11 | val empty : 'a t 12 | (** Empty zipper. *) 13 | 14 | val is_empty : _ t -> bool 15 | (** Empty zipper? Returns [true] iff the two lists are empty. *) 16 | 17 | val to_list : 'a t -> 'a list 18 | (** Convert the zipper back to a list. 19 | [to_list (l,r)] is [List.rev_append l r]. *) 20 | 21 | val to_rev_list : 'a t -> 'a list 22 | (** Convert the zipper back to a {i reversed} list. 23 | In other words, [to_list (l,r)] is [List.rev_append r l]. *) 24 | 25 | val make : 'a list -> 'a t 26 | (** Create a zipper pointing at the first element of the list. *) 27 | 28 | val left : 'a t -> 'a t 29 | (** Go to the left, or do nothing if the zipper is already at leftmost pos. *) 30 | 31 | val left_exn : 'a t -> 'a t 32 | (** Go to the left, or 33 | @raise Invalid_argument if the zipper is already at leftmost pos. *) 34 | 35 | val right : 'a t -> 'a t 36 | (** Go to the right, or do nothing if the zipper is already at rightmost pos. *) 37 | 38 | val right_exn : 'a t -> 'a t 39 | (** Go to the right, or 40 | @raise Invalid_argument if the zipper is already at rightmost pos. *) 41 | 42 | val modify : ('a option -> 'a option) -> 'a t -> 'a t 43 | (** Modify the current element, if any, by returning a new element, or 44 | returning [None] if the element is to be deleted. *) 45 | 46 | val insert : 'a -> 'a t -> 'a t 47 | (** Insert an element at the current position. If an element was focused, 48 | [insert x l] adds [x] just before it, and focuses on [x]. *) 49 | 50 | val remove : 'a t -> 'a t 51 | (** [remove l] removes the current element, if any. *) 52 | 53 | val is_focused : _ t -> bool 54 | (** Is the zipper focused on some element? That is, will {!focused} 55 | return a [Some v]? *) 56 | 57 | val focused : 'a t -> 'a option 58 | (** Return the focused element, if any. [focused zip = Some _] iff 59 | [empty zip = false]. *) 60 | 61 | val focused_exn : 'a t -> 'a 62 | (** Return the focused element, or 63 | @raise Not_found if the zipper is at an end. *) 64 | 65 | val drop_before : 'a t -> 'a t 66 | (** Drop every element on the "left" (calling {!left} then will do nothing). *) 67 | 68 | val drop_after : 'a t -> 'a t 69 | (** Drop every element on the "right" (calling {!right} then will do nothing), 70 | keeping the focused element, if any. *) 71 | 72 | val drop_after_and_focused : 'a t -> 'a t 73 | (** Drop every element on the "right" (calling {!right} then will do nothing), 74 | {i including} the focused element if it is present. *) 75 | -------------------------------------------------------------------------------- /src/data/CCLazy_list.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Lazy List} *) 4 | 5 | type +'a t = 'a node lazy_t 6 | and +'a node = Nil | Cons of 'a * 'a t 7 | 8 | let empty = Lazy.from_val Nil 9 | let return x = Lazy.from_val (Cons (x, empty)) 10 | 11 | let is_empty = function 12 | | (lazy Nil) -> true 13 | | (lazy (Cons _)) -> false 14 | 15 | let cons x tl = Lazy.from_val (Cons (x, tl)) 16 | 17 | let head = function 18 | | (lazy Nil) -> None 19 | | (lazy (Cons (x, tl))) -> Some (x, tl) 20 | 21 | let length l = 22 | let rec aux acc l = 23 | match l with 24 | | (lazy Nil) -> acc 25 | | (lazy (Cons (_, tl))) -> aux (acc + 1) tl 26 | in 27 | aux 0 l 28 | 29 | let rec map ~f l = 30 | lazy 31 | (match l with 32 | | (lazy Nil) -> Nil 33 | | (lazy (Cons (x, tl))) -> Cons (f x, map ~f tl)) 34 | 35 | let filter ~f l = 36 | let rec aux f l = 37 | match l with 38 | | (lazy Nil) -> Nil 39 | | (lazy (Cons (x, tl))) when f x -> Cons (x, lazy (aux f tl)) 40 | | (lazy (Cons (_, tl))) -> aux f tl 41 | in 42 | lazy (aux f l) 43 | 44 | let rec take n l = 45 | lazy 46 | (match l with 47 | | _ when n = 0 -> Nil 48 | | (lazy Nil) -> Nil 49 | | (lazy (Cons (x, tl))) -> Cons (x, take (n - 1) tl)) 50 | 51 | let rec append a b = 52 | lazy 53 | (match a with 54 | | (lazy Nil) -> Lazy.force b 55 | | (lazy (Cons (x, tl))) -> Cons (x, append tl b)) 56 | 57 | let rec flat_map ~f l = 58 | lazy 59 | (match l with 60 | | (lazy Nil) -> Nil 61 | | (lazy (Cons (x, tl))) -> 62 | let res = append (f x) (flat_map ~f tl) in 63 | Lazy.force res) 64 | 65 | let default ~default l = 66 | lazy 67 | (match l with 68 | | (lazy Nil) -> Lazy.force default 69 | | (lazy l) -> l) 70 | 71 | module Infix = struct 72 | let ( >|= ) x f = map ~f x 73 | let ( >>= ) x f = flat_map ~f x 74 | let ( <|> ) a b = default ~default:b a 75 | end 76 | 77 | include Infix 78 | 79 | type 'a gen = unit -> 'a option 80 | 81 | let rec of_gen g = 82 | lazy 83 | (match g () with 84 | | None -> Nil 85 | | Some x -> Cons (x, of_gen g)) 86 | 87 | let rec of_list = function 88 | | [] -> empty 89 | | x :: tl -> cons x (of_list tl) 90 | 91 | let to_list_rev l = 92 | let rec aux acc = function 93 | | (lazy Nil) -> acc 94 | | (lazy (Cons (x, tl))) -> aux (x :: acc) tl 95 | in 96 | aux [] l 97 | 98 | let to_list l = List.rev (to_list_rev l) 99 | 100 | let to_gen l = 101 | let l = ref l in 102 | fun () -> 103 | match !l with 104 | | (lazy Nil) -> None 105 | | (lazy (Cons (x, tl))) -> 106 | l := tl; 107 | Some x 108 | -------------------------------------------------------------------------------- /src/data/CCImmutArray.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Immutable Arrays} *) 4 | 5 | (* TODO: transient API? for batch modifications *) 6 | 7 | type 'a t = 'a array 8 | 9 | let empty = [||] 10 | let length = Array.length 11 | let singleton x = [| x |] 12 | let doubleton x y = [| x; y |] 13 | let make n x = Array.make n x 14 | let init n f = Array.init n f 15 | let get = Array.get 16 | 17 | let set a n x = 18 | let a' = Array.copy a in 19 | a'.(n) <- x; 20 | a' 21 | 22 | let sub = Array.sub 23 | (* Would this not be better implemented with CCArray_slice *) 24 | 25 | let map = Array.map 26 | let mapi = Array.mapi 27 | 28 | let append a b = 29 | let na = length a in 30 | Array.init 31 | (na + length b) 32 | (fun i -> 33 | if i < na then 34 | a.(i) 35 | else 36 | b.(i - na)) 37 | 38 | let iter = Array.iter 39 | let iteri = Array.iteri 40 | let fold = Array.fold_left 41 | 42 | let foldi f acc a = 43 | let n = ref 0 in 44 | Array.fold_left 45 | (fun acc x -> 46 | let acc = f acc !n x in 47 | incr n; 48 | acc) 49 | acc a 50 | 51 | exception ExitNow 52 | 53 | let for_all p a = 54 | try 55 | Array.iter (fun x -> if not (p x) then raise ExitNow) a; 56 | true 57 | with ExitNow -> false 58 | 59 | let exists p a = 60 | try 61 | Array.iter (fun x -> if p x then raise ExitNow) a; 62 | false 63 | with ExitNow -> true 64 | 65 | (** {2 Conversions} *) 66 | 67 | type 'a iter = ('a -> unit) -> unit 68 | type 'a gen = unit -> 'a option 69 | 70 | let of_list = Array.of_list 71 | let to_list = Array.to_list 72 | let of_array_unsafe a = a (* careful with that axe, Eugene *) 73 | 74 | let to_iter a k = iter k a 75 | 76 | let of_iter s = 77 | let l = ref [] in 78 | s (fun x -> l := x :: !l); 79 | Array.of_list (List.rev !l) 80 | 81 | let rec gen_to_list_ acc g = 82 | match g () with 83 | | None -> List.rev acc 84 | | Some x -> gen_to_list_ (x :: acc) g 85 | 86 | let of_gen g = 87 | let l = gen_to_list_ [] g in 88 | Array.of_list l 89 | 90 | let to_gen a = 91 | let i = ref 0 in 92 | fun () -> 93 | if !i < Array.length a then ( 94 | let x = a.(!i) in 95 | incr i; 96 | Some x 97 | ) else 98 | None 99 | 100 | (** {2 IO} *) 101 | 102 | type 'a printer = Format.formatter -> 'a -> unit 103 | 104 | let pp ?(pp_start = fun _ () -> ()) ?(pp_stop = fun _ () -> ()) 105 | ?(pp_sep = fun out () -> Format.fprintf out ",@ ") pp_item out a = 106 | pp_start out (); 107 | for k = 0 to Array.length a - 1 do 108 | if k > 0 then pp_sep out (); 109 | pp_item out a.(k) 110 | done; 111 | pp_stop out () 112 | -------------------------------------------------------------------------------- /fuzz/run_all.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cpu_count=$(grep -c ^processor /proc/cpuinfo) 4 | 5 | simul_test_count=$[cpu_count-1] 6 | 7 | test_timeout="10m" 8 | 9 | script_dir=$(dirname $(readlink -f "$0")) 10 | 11 | log_dir="$script_dir"/../fuzz-logs 12 | 13 | echo "Building" 14 | 15 | dune build @all 16 | 17 | echo "" 18 | 19 | start_date=$(date "+%Y-%m-%d %H:%M") 20 | start_time=$(date "+%s") 21 | 22 | names=() 23 | 24 | i=0 25 | for file in "$script_dir"/../_build/default/fuzz/*.exe; do 26 | name=$(basename $file | sed 's/\.exe$//') 27 | names[$i]=$name 28 | i=$[i+1] 29 | done 30 | 31 | test_count=${#names[@]} 32 | 33 | echo "Fuzzing tests available:" 34 | 35 | for name in ${names[@]}; do 36 | echo "- "$name 37 | done 38 | 39 | echo "" 40 | echo "Fuzzing start time:" $start_date 41 | echo "" 42 | 43 | echo "Starting $test_count tests" 44 | echo "" 45 | 46 | mkdir -p "$log_dir" 47 | 48 | i=0 49 | while (( $i < $test_count )); do 50 | if (( $test_count - $i >= $simul_test_count )); then 51 | tests_to_run=$simul_test_count 52 | else 53 | tests_to_run=$[test_count - i] 54 | fi 55 | 56 | echo "Running $tests_to_run tests in parallel" 57 | 58 | for (( c=0; c < $tests_to_run; c++ )); do 59 | name=${names[$i]} 60 | if [[ "$name" != "" ]]; then 61 | echo " Starting $name" 62 | 63 | (AFL_NO_UI=1 timeout "$test_timeout" "$script_dir"/run.sh "$name" skip_build > "$log_dir"/"$name".log) & 64 | 65 | i=$[i+1] 66 | fi 67 | done 68 | 69 | echo "Waiting for $test_timeout" 70 | 71 | sleep $test_timeout 72 | 73 | echo "Terminating tests" 74 | 75 | pkill afl-fuzz 76 | 77 | sleep 5 78 | 79 | echo "" 80 | echo "$[test_count - i] / $test_count tests remaining" 81 | echo "" 82 | done 83 | 84 | end_date=$(date "+%Y-%m-%d %H:%M") 85 | end_time=$(date "+%s") 86 | 87 | echo "" 88 | echo "Test end:" $end_date 89 | 90 | echo "" 91 | 92 | echo "Time elapsed:" $[(end_time - start_time) / 60] "minutes" 93 | 94 | test_fail_count=0 95 | tests_failed=() 96 | 97 | for name in ${names[@]}; do 98 | output_dir="$script_dir"/../"fuzz-""$name""-output" 99 | 100 | crashes_dir="$output_dir"/crashes 101 | 102 | if [ -z "$(ls -A $crashes_dir)" ]; then 103 | # crashes dir is empty 104 | : 105 | else 106 | # crashes dir is not empty 107 | test_fail_count=$[$test_fail_count + 1] 108 | tests_failed+=("$name") 109 | fi 110 | done 111 | 112 | echo "========================================" 113 | 114 | if [[ $test_fail_count == 0 ]]; then 115 | echo "All $test_count tests passed" 116 | exit_code=0 117 | else 118 | echo "$test_fail_count tests failed" 119 | echo "" 120 | echo "List of tests failed :" 121 | for t in ${tests_failed[@]}; do 122 | echo " "$t 123 | done 124 | exit_code=1 125 | fi 126 | 127 | -------------------------------------------------------------------------------- /src/core/CCOrd.mli: -------------------------------------------------------------------------------- 1 | (** Order combinators *) 2 | 3 | (* This file is free software, part of containers. See file "license" for more details. *) 4 | 5 | (** {2 Comparisons} *) 6 | 7 | type 'a t = 'a -> 'a -> int 8 | (** Comparison (total ordering) between two elements, that returns an int. *) 9 | 10 | val poly : 'a t 11 | (** Polymorphic "magic" comparison. Use with care, as it will fail on 12 | some types. 13 | @since 3.6 *) 14 | 15 | val compare : 'a t 16 | [@@deprecated "use CCOrd.poly instead, this name is too general"] 17 | (** Polymorphic "magic" comparison. 18 | @deprecated since 3.6 in favor of {!poly}. The reason is that 19 | [compare] is easily shadowed, can shadow other comparators, and is just 20 | generally not very descriptive. *) 21 | 22 | val opp : 'a t -> 'a t 23 | (** Opposite order. For example, [opp cmp a b < 0] iff [cmp b a > 0]. 24 | This can be used to sort values in the opposite order, among other things. *) 25 | 26 | val equiv : int -> int -> bool 27 | (** Returns [true] iff the two comparison results are the same. *) 28 | 29 | val int : int t 30 | val string : string t 31 | val bool : bool t 32 | val float : float t 33 | 34 | (** {2 Lexicographic Combination} *) 35 | 36 | val ( ) : int -> 'a t * 'a * 'a -> int 37 | (** [c1 (ord, x, y)] returns the same as [c1] if [c1] is not [0]; 38 | otherwise it uses [ord] to compare the two values [x] and [y], 39 | of type ['a]. 40 | 41 | Example: 42 | {[CCInt.compare 1 3 43 | (String.compare, "a", "b") 44 | (CCBool.compare, true, false)]} 45 | 46 | Same example, using only CCOrd:: 47 | {[CCOrd.(int 1 3 48 | (string, "a", "b") 49 | (bool, true, false))]} 50 | *) 51 | 52 | val option : 'a t -> 'a option t 53 | (** Comparison of optional values. [None] is smaller than any [Some _]. 54 | @since 0.15 *) 55 | 56 | val pair : 'a t -> 'b t -> ('a * 'b) t 57 | val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 58 | 59 | val list : 'a t -> 'a list t 60 | (** Lexicographic combination on lists. *) 61 | 62 | val array : 'a t -> 'a array t 63 | 64 | val map : ('a -> 'b) -> 'b t -> 'a t 65 | (** [map f ord] is the comparison function that, given objects [x] and [y], 66 | projects [x] and [y] using [f] (e.g. using a record field) and then 67 | compares those projections with [ord]. 68 | Example: 69 | [map fst CCInt.compare] compares values of type [(int * 'a)] by their 70 | first component. *) 71 | 72 | val ( >|= ) : 'b t -> ('a -> 'b) -> 'a t 73 | (** Infix equivalent of {!map}. *) 74 | 75 | module Infix : sig 76 | val ( ) : int -> 'a t * 'a * 'a -> int 77 | (** [c1 (ord, x, y)] returns the same as [c1] if [c1] is not [0]; 78 | otherwise it uses [ord] to compare the two values [x] and [y], 79 | of type ['a]. *) 80 | 81 | val ( >|= ) : 'b t -> ('a -> 'b) -> 'a t 82 | (** Infix equivalent of {!map}. *) 83 | end 84 | -------------------------------------------------------------------------------- /src/data/CCMultiSet.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Multiset *) 4 | 5 | type 'a iter = ('a -> unit) -> unit 6 | 7 | module type S = sig 8 | type elt 9 | type t 10 | 11 | val empty : t 12 | val is_empty : t -> bool 13 | val mem : t -> elt -> bool 14 | val count : t -> elt -> int 15 | val singleton : elt -> t 16 | val add : t -> elt -> t 17 | val remove : t -> elt -> t 18 | 19 | val add_mult : t -> elt -> int -> t 20 | (** [add_mult set x n] adds [n] occurrences of [x] to [set]. 21 | @raise Invalid_argument if [n < 0]. 22 | @since 0.6 *) 23 | 24 | val remove_mult : t -> elt -> int -> t 25 | (** [remove_mult set x n] removes at most [n] occurrences of [x] from [set]. 26 | @raise Invalid_argument if [n < 0]. 27 | @since 0.6 *) 28 | 29 | val remove_all : t -> elt -> t 30 | (** [remove_all set x] removes all occurrences of [x] from [set]. 31 | @since 0.22 *) 32 | 33 | val update : t -> elt -> (int -> int) -> t 34 | (** [update set x f] calls [f n] where [n] is the current multiplicity 35 | of [x] in [set] ([0] to indicate its absence); the result of [f n] 36 | is the new multiplicity of [x]. 37 | @raise Invalid_argument if [f n < 0]. 38 | @since 0.6 *) 39 | 40 | val min : t -> elt 41 | (** Minimal element w.r.t the total ordering on elements. *) 42 | 43 | val max : t -> elt 44 | (** Maximal element w.r.t the total ordering on elements. *) 45 | 46 | val union : t -> t -> t 47 | (** [union a b] contains as many occurrences of an element [x] 48 | as [count a x + count b x]. *) 49 | 50 | val meet : t -> t -> t 51 | (** [meet a b] is a multiset such that 52 | [count (meet a b) x = max (count a x) (count b x)]. *) 53 | 54 | val intersection : t -> t -> t 55 | (** [intersection a b] is a multiset such that 56 | [count (intersection a b) x = min (count a x) (count b x)]. *) 57 | 58 | val diff : t -> t -> t 59 | (** MultiSet difference. 60 | [count (diff a b) x = max (count a x - count b x) 0]. *) 61 | 62 | val contains : t -> t -> bool 63 | (** [contains a x = (count m x > 0)]. *) 64 | 65 | val compare : t -> t -> int 66 | val equal : t -> t -> bool 67 | 68 | val cardinal : t -> int 69 | (** Number of distinct elements. *) 70 | 71 | val iter : t -> (int -> elt -> unit) -> unit 72 | val fold : t -> 'b -> ('b -> int -> elt -> 'b) -> 'b 73 | val of_list : elt list -> t 74 | val to_list : t -> elt list 75 | val to_iter : t -> elt iter 76 | val of_iter : elt iter -> t 77 | 78 | val of_list_mult : (elt * int) list -> t 79 | (** @since 0.19 *) 80 | 81 | val to_list_mult : t -> (elt * int) list 82 | (** @since 0.19 *) 83 | 84 | val to_iter_mult : t -> (elt * int) iter 85 | (** @since 0.19 *) 86 | 87 | val of_iter_mult : (elt * int) iter -> t 88 | (** @since 0.19 *) 89 | end 90 | 91 | module Make (O : Set.OrderedType) : S with type elt = O.t 92 | -------------------------------------------------------------------------------- /tests/core/t_cbor.ml: -------------------------------------------------------------------------------- 1 | include (val Containers_testlib.make ~__FILE__ ()) 2 | module Cbor = Containers_cbor 3 | 4 | [@@@ifge 4.08] 5 | 6 | let gen_c : Cbor.t Q.Gen.t = 7 | let open Q.Gen in 8 | sized @@ fix 9 | @@ fun self size -> 10 | let recurse = self (size - 1) in 11 | let base = 12 | [ 13 | 1, return `Null; 14 | 1, return `Undefined; 15 | ( 3, 16 | let+ x = int >|= Int64.of_int in 17 | `Int x ); 18 | ( 1, 19 | let+ b = bool in 20 | `Bool b ); 21 | ( 1, 22 | let+ x = 0 -- 19 in 23 | `Simple x ); 24 | ( 1, 25 | let+ x = 26 -- 127 in 26 | `Simple x ); 27 | ( 1, 28 | let+ f = float in 29 | `Float f ); 30 | ( 2, 31 | let+ s = string_size ~gen:printable (0 -- 150) in 32 | `Text s ); 33 | ( 2, 34 | let+ s = string_size ~gen:char (0 -- 150) in 35 | `Bytes s ); 36 | ] 37 | in 38 | let g_base = frequency base in 39 | let rec_ = 40 | [ 41 | ( 2, 42 | let+ l = 43 | if size > 10 then 44 | list_size (0 -- 1024) g_base 45 | else 46 | list_size (0 -- 10) recurse 47 | in 48 | `Array l ); 49 | ( 2, 50 | let+ l = 51 | if size > 10 then 52 | list_size (0 -- 1024) (pair g_base g_base) 53 | else 54 | list_size (0 -- 5) (pair g_base recurse) 55 | in 56 | `Map l ); 57 | ] 58 | in 59 | frequency 60 | (if size > 0 then 61 | base @ rec_ 62 | else 63 | base) 64 | 65 | let rec shrink (c : Cbor.t) : Cbor.t Q.Iter.t = 66 | let open Q.Iter in 67 | match c with 68 | | `Null | `Undefined | `Bool false -> empty 69 | | `Bool true -> return (`Bool false) 70 | | `Simple i -> 71 | let+ i = Q.Shrink.int i in 72 | `Simple i 73 | | `Int i -> 74 | let+ i = Q.Shrink.int (Int64.to_int i) in 75 | `Int (Int64.of_int i) 76 | | `Tag (t, i) -> 77 | let+ i = shrink i in 78 | `Tag (t, i) 79 | | `Float _ -> empty 80 | | `Array l -> 81 | let+ l = Q.Shrink.list ~shrink l in 82 | `Array l 83 | | `Map l -> 84 | let shrink_pair (a, b) = 85 | (let+ a = shrink a in 86 | a, b) 87 | <+> let+ b = shrink b in 88 | a, b 89 | in 90 | let+ l = Q.Shrink.list ~shrink:shrink_pair l in 91 | `Map l 92 | | `Text s -> 93 | let+ s = Q.Shrink.string s in 94 | `Text s 95 | | `Bytes s -> 96 | let+ s = Q.Shrink.string s in 97 | `Bytes s 98 | 99 | let arb = Q.make ~shrink ~print:Cbor.to_string_diagnostic gen_c;; 100 | 101 | q ~count:10_000 arb @@ fun c -> 102 | let s = Cbor.encode c in 103 | let c' = Cbor.decode_exn s in 104 | if not (c = c') then 105 | Q.Test.fail_reportf "@[roundtrip failed:@ from %a@ to %a@]" 106 | Cbor.pp_diagnostic c Cbor.pp_diagnostic c'; 107 | true 108 | 109 | [@@@endif] 110 | -------------------------------------------------------------------------------- /src/codegen/containers_codegen.mli: -------------------------------------------------------------------------------- 1 | (** {1 Code generators} 2 | 3 | The code generator library is designed to be used from a build system 4 | (for example, from [dune]) to generate efficient code for features 5 | that are harder to provide at runtime. 6 | 7 | The idea is that the build system should invoke some OCaml script 8 | that depends on [containers.codegen]; the script uses the DSL below 9 | to describe what code to generate (e.g. a description of a bitfield type) 10 | and emits a [.ml] file (and possibly a [.mli] file). 11 | 12 | For example, the build script might contain: 13 | 14 | {[ 15 | module CG = Containers_codegen 16 | let () = 17 | let module B = CG.Bitfield in 18 | let b = B.make ~name:"t" () in 19 | B.field_bit b "x"; 20 | B.field_bit b "y"; 21 | B.field_bit b "z"; 22 | B.field_int b ~width:5 "foo"; 23 | 24 | CG.emit_file "foo.mli" (B.gen_mli b); 25 | CG.emit_file "foo.ml" (B.gen_ml b); 26 | () 27 | ]} 28 | 29 | and this will produce [foo.ml] and [foo.mli] with a bitfield containing 30 | [x], [y], and [z]. 31 | 32 | *) 33 | 34 | module Fmt = CCFormat 35 | 36 | type code 37 | 38 | (** {2 Representation of OCaml code} *) 39 | module Code : sig 40 | type t = code 41 | 42 | val pp : t Fmt.printer 43 | val to_string : t -> string 44 | val mk_pp : unit Fmt.printer -> t 45 | val mk_str : string -> t 46 | val in_struct : string -> t list -> t 47 | val in_sig : string -> t list -> t 48 | end 49 | 50 | (** {2 Generate efficient bitfields that fit in an integer} *) 51 | module Bitfield : sig 52 | type t 53 | 54 | val make : ?emit_failure_if_too_wide:bool -> name:string -> unit -> t 55 | (** Make a new bitfield with the given name. 56 | @param name the name of the generated type 57 | @param emit_failure_if_too_wide if true, generated code includes a runtime 58 | assertion that {!Sys.int_size} is wide enough to support this type *) 59 | 60 | val field_bit : t -> string -> unit 61 | (** [field_bit ty name] adds a field of size [1] to the bitfield [ty], 62 | with name [name]. The generate code will provide get/set for 63 | a boolean. *) 64 | 65 | val field_int : t -> width:int -> string -> unit 66 | (** [field_int ty name ~width] adds a field of size [width] to 67 | the bitfield with name [name]. 68 | The accessors will be for integers of [width] bits, and the 69 | setter might assert that the provided integer fits. *) 70 | 71 | val total_width : t -> int 72 | (** Total width in bits of the given bitfield. *) 73 | 74 | val gen_mli : t -> code 75 | (** Generate code for the type signature for the given bitfield *) 76 | 77 | val gen_ml : t -> code 78 | (** Generate code for the implementation for the given bitfield *) 79 | end 80 | 81 | val emit_file : string -> code list -> unit 82 | (** [emit_file file cs] emits code fragments [cs] into the given file 83 | at path [file] *) 84 | 85 | val emit_chan : out_channel -> code list -> unit 86 | val emit_string : code list -> string 87 | -------------------------------------------------------------------------------- /benchs/objsize.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (*i $Id$ i*) 17 | 18 | (*i*) 19 | open Obj 20 | (*i*) 21 | 22 | (*s Pointers already visited are stored in a hash-table, where 23 | comparisons are done using physical equality. *) 24 | 25 | module H = Hashtbl.Make (struct 26 | type t = Obj.t 27 | 28 | let equal = ( == ) 29 | let hash o = Hashtbl.hash (magic o : int) 30 | end) 31 | 32 | let node_table = (H.create 257 : unit H.t) 33 | 34 | let in_table o = 35 | try 36 | H.find node_table o; 37 | true 38 | with Not_found -> false 39 | 40 | let add_in_table o = H.add node_table o () 41 | let reset_table () = H.clear node_table 42 | 43 | (*s Objects are traversed recursively, as soon as their tags are less than 44 | [no_scan_tag]. [count] records the numbers of words already visited. *) 45 | 46 | let size_of_double = size (repr 1.0) 47 | let count = ref 0 48 | 49 | let rec traverse t = 50 | if not (in_table t) then ( 51 | add_in_table t; 52 | if is_block t then ( 53 | let n = size t in 54 | let tag = tag t in 55 | if tag < no_scan_tag then ( 56 | count := !count + 1 + n; 57 | for i = 0 to n - 1 do 58 | let f = field t i in 59 | if is_block f then traverse f 60 | done 61 | ) else if tag = string_tag then 62 | count := !count + 1 + n 63 | else if tag = double_tag then 64 | count := !count + size_of_double 65 | else if tag = double_array_tag then 66 | count := !count + 1 + (size_of_double * n) 67 | else 68 | incr count 69 | ) 70 | ) 71 | 72 | (*s Sizes of objects in words and in bytes. The size in bytes is computed 73 | system-independently according to [Sys.word_size]. *) 74 | 75 | let size_w o = 76 | reset_table (); 77 | count := 0; 78 | traverse (repr o); 79 | !count 80 | 81 | let size_b o = size_w o * (Sys.word_size / 8) 82 | let size_kb o = size_w o / (8192 / Sys.word_size) 83 | -------------------------------------------------------------------------------- /src/data/CCSimple_queue.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Functional queues (fifo) *) 4 | 5 | (** Simple implementation of functional queues 6 | @since 1.3 *) 7 | 8 | type 'a iter = ('a -> unit) -> unit 9 | (** Fast internal iterator. 10 | @since 2.8 *) 11 | 12 | type 'a printer = Format.formatter -> 'a -> unit 13 | type 'a gen = unit -> 'a option 14 | 15 | type +'a t 16 | (** Queue containing elements of type 'a *) 17 | 18 | val empty : 'a t 19 | val is_empty : 'a t -> bool 20 | 21 | val push : 'a -> 'a t -> 'a t 22 | (** Push element at the end of the queue. *) 23 | 24 | val snoc : 'a t -> 'a -> 'a t 25 | (** Flip version of {!push}. *) 26 | 27 | val peek : 'a t -> 'a option 28 | (** First element of the queue. *) 29 | 30 | val peek_exn : 'a t -> 'a 31 | (** Same as {!peek} but 32 | @raise Invalid_argument if the queue is empty. *) 33 | 34 | val pop : 'a t -> ('a * 'a t) option 35 | (** Get and remove the first element. *) 36 | 37 | val pop_exn : 'a t -> 'a * 'a t 38 | (** Same as {!pop}, but fails on empty queues. 39 | @raise Invalid_argument if the queue is empty. *) 40 | 41 | val junk : 'a t -> 'a t 42 | (** Remove first element. If the queue is empty, do nothing. *) 43 | 44 | val append : 'a t -> 'a t -> 'a t 45 | (** Append two queues. Elements from the second one come 46 | after elements of the first one. 47 | Linear in the size of the second queue. *) 48 | 49 | val map : ('a -> 'b) -> 'a t -> 'b t 50 | (** Map values. *) 51 | 52 | val rev : 'a t -> 'a t 53 | (** Reverse the queue. Constant time. *) 54 | 55 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 56 | 57 | module Infix : sig 58 | val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t 59 | (** Alias to {!map}. *) 60 | 61 | val ( @ ) : 'a t -> 'a t -> 'a t 62 | (** Alias to {!append}. *) 63 | 64 | val ( <:: ) : 'a t -> 'a -> 'a t 65 | (** Alias to {!snoc}. *) 66 | end 67 | 68 | include module type of Infix 69 | 70 | val length : 'a t -> int 71 | (** Number of elements in the queue (linear in time). *) 72 | 73 | val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 74 | val iter : ('a -> unit) -> 'a t -> unit 75 | val to_list : 'a t -> 'a list 76 | val add_list : 'a t -> 'a list -> 'a t 77 | val of_list : 'a list -> 'a t 78 | val to_iter : 'a t -> 'a iter 79 | val add_iter : 'a t -> 'a iter -> 'a t 80 | val of_iter : 'a iter -> 'a t 81 | 82 | val to_seq : 'a t -> 'a Seq.t 83 | (** Renamed from [to_std_seq] since 3.0. 84 | @since 3.0 *) 85 | 86 | val add_seq : 'a t -> 'a Seq.t -> 'a t 87 | (** Renamed from [add_std_seq] since 3.0. 88 | @since 3.0 *) 89 | 90 | val of_seq : 'a Seq.t -> 'a t 91 | (** Renamed from [of_std_seq] since 3.0. 92 | @since 3.0 *) 93 | 94 | val of_gen : 'a gen -> 'a t 95 | val add_gen : 'a t -> 'a gen -> 'a t 96 | val to_gen : 'a t -> 'a gen 97 | 98 | (** {2 IO} *) 99 | 100 | val pp : ?sep:unit printer -> 'a printer -> 'a t printer 101 | -------------------------------------------------------------------------------- /tests/core/t_heap.ml: -------------------------------------------------------------------------------- 1 | open CCHeap 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T 4 | 5 | module H = CCHeap.Make (struct 6 | type t = int 7 | 8 | let leq x y = x <= y 9 | end) 10 | 11 | let rec is_sorted l = 12 | match l with 13 | | [ _ ] | [] -> true 14 | | x :: (y :: _ as l') -> x <= y && is_sorted l' 15 | 16 | let extract_list = H.to_list_sorted;; 17 | 18 | t @@ fun () -> 19 | let h = H.of_list [ 5; 3; 4; 1; 42; 0 ] in 20 | let h, x = H.take_exn h in 21 | assert_equal ~printer:string_of_int 0 x; 22 | let h, x = H.take_exn h in 23 | assert_equal ~printer:string_of_int 1 x; 24 | let h, x = H.take_exn h in 25 | assert_equal ~printer:string_of_int 3 x; 26 | let h, x = H.take_exn h in 27 | assert_equal ~printer:string_of_int 4 x; 28 | let h, x = H.take_exn h in 29 | assert_equal ~printer:string_of_int 5 x; 30 | let h, x = H.take_exn h in 31 | assert_equal ~printer:string_of_int 42 x; 32 | assert_raises 33 | (function 34 | | H.Empty -> true 35 | | _ -> false) 36 | (fun () -> H.take_exn h); 37 | true 38 | ;; 39 | 40 | q ~count:30 41 | Q.(list_of_size Gen.(return 1_000) int) 42 | (fun l -> 43 | (* put elements into a heap *) 44 | let h = H.of_iter (Iter.of_list l) in 45 | assert_equal 1_000 (H.size h); 46 | let l' = extract_list h in 47 | is_sorted l') 48 | ;; 49 | 50 | (* test filter *) 51 | q ~count:30 52 | Q.(list_of_size Gen.(return 1_000) int) 53 | (fun l -> 54 | (* put elements into a heap *) 55 | let h = H.of_iter (Iter.of_list l) in 56 | let h = H.filter (fun x -> x mod 2 = 0) h in 57 | assert (H.to_iter h |> Iter.for_all (fun x -> x mod 2 = 0)); 58 | let l' = extract_list h in 59 | is_sorted l') 60 | ;; 61 | 62 | q 63 | Q.(list_of_size Gen.(return 1_000) int) 64 | (fun l -> 65 | (* put elements into a heap *) 66 | let h = H.of_iter (Iter.of_list l) in 67 | let l' = H.to_iter_sorted h |> Iter.to_list in 68 | is_sorted l') 69 | ;; 70 | 71 | q 72 | Q.(list int) 73 | (fun l -> 74 | extract_list (H.of_list l) = extract_list (H.of_gen (CCList.to_gen l))) 75 | ;; 76 | 77 | q 78 | Q.(list int) 79 | (fun l -> 80 | let h = H.of_list l in 81 | H.to_gen h |> CCList.of_gen |> List.sort Stdlib.compare 82 | = (H.to_list h |> List.sort Stdlib.compare)) 83 | ;; 84 | 85 | q 86 | Q.(list int) 87 | (fun l -> 88 | let h = H.of_list l in 89 | H.to_string string_of_int h 90 | = (List.sort Stdlib.compare l |> List.map string_of_int |> String.concat ",")) 91 | ;; 92 | 93 | q 94 | Q.(list int) 95 | (fun l -> 96 | let h = H.of_list l in 97 | H.to_string ~sep:" " string_of_int h 98 | = (List.sort Stdlib.compare l |> List.map string_of_int |> String.concat " ")) 99 | ;; 100 | 101 | q 102 | Q.(list_of_size Gen.(return 1_000) int) 103 | (fun l -> 104 | let module H' = Make_from_compare (CCInt) in 105 | let h = H'.of_list l in 106 | let l' = H'.to_list_sorted h in 107 | is_sorted l') 108 | -------------------------------------------------------------------------------- /src/data/CCImmutArray.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Immutable Arrays 4 | 5 | Purely functional use of arrays. Update is costly, but reads are very fast. 6 | Sadly, it is not possible to make this type covariant without using black 7 | magic. 8 | 9 | @since 0.17 *) 10 | 11 | type 'a t 12 | (** Array of values of type 'a. The underlying type really is 13 | an array, but it will never be modified. 14 | 15 | It should be covariant but OCaml will not accept it. *) 16 | 17 | val empty : 'a t 18 | val length : _ t -> int 19 | val singleton : 'a -> 'a t 20 | val doubleton : 'a -> 'a -> 'a t 21 | 22 | val make : int -> 'a -> 'a t 23 | (** [make n x] makes an array of [n] times [x]. *) 24 | 25 | val init : int -> (int -> 'a) -> 'a t 26 | (** [init n f] makes the array [[| f 0; f 1; ... ; f (n-1) |]]. 27 | @raise Invalid_argument if [n < 0]. *) 28 | 29 | val get : 'a t -> int -> 'a 30 | (** Access the element. *) 31 | 32 | val set : 'a t -> int -> 'a -> 'a t 33 | (** Copy the array and modify its copy. *) 34 | 35 | val sub : 'a t -> int -> int -> 'a t 36 | (** [sub a start len] returns a fresh array of length len, containing the elements 37 | from [start] to [pstart + len - 1] of array a. 38 | 39 | Raises [Invalid_argument "Array.sub"] if [start] and [len] do not designate a 40 | valid subarray of a; that is, if start < 0, or len < 0, or start + len > Array.length a. 41 | 42 | @since 1.5 *) 43 | 44 | val map : ('a -> 'b) -> 'a t -> 'b t 45 | val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t 46 | val append : 'a t -> 'a t -> 'a t 47 | val iter : ('a -> unit) -> 'a t -> unit 48 | val iteri : (int -> 'a -> unit) -> 'a t -> unit 49 | val foldi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a 50 | val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a 51 | val for_all : ('a -> bool) -> 'a t -> bool 52 | val exists : ('a -> bool) -> 'a t -> bool 53 | 54 | (** {2 Conversions} *) 55 | 56 | type 'a iter = ('a -> unit) -> unit 57 | type 'a gen = unit -> 'a option 58 | 59 | val of_list : 'a list -> 'a t 60 | val to_list : 'a t -> 'a list 61 | 62 | val of_array_unsafe : 'a array -> 'a t 63 | (** Take ownership of the given array. Careful, the array must {b NOT} 64 | be modified afterwards! *) 65 | 66 | val to_iter : 'a t -> 'a iter 67 | val of_iter : 'a iter -> 'a t 68 | val of_gen : 'a gen -> 'a t 69 | val to_gen : 'a t -> 'a gen 70 | 71 | (** {2 IO} *) 72 | 73 | type 'a printer = Format.formatter -> 'a -> unit 74 | 75 | val pp : 76 | ?pp_start:unit printer -> 77 | ?pp_stop:unit printer -> 78 | ?pp_sep:unit printer -> 79 | 'a printer -> 80 | 'a t printer 81 | (** [pp ~pp_start ~pp_stop ~pp_sep pp_item ppf a] formats the array [a] on [ppf]. 82 | Each element is formatted with [pp_item], [pp_start] is called at the beginning, 83 | [pp_stop] is called at the end, [pp_sep] is called between each elements. 84 | By defaults [pp_start] and [pp_stop] does nothing and [pp_sep] defaults to 85 | (fun out -> Format.fprintf out ",@ "). *) 86 | -------------------------------------------------------------------------------- /src/threads/CCLock.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Utils around Mutex} 4 | 5 | A value wrapped into a Mutex, for more safety. 6 | 7 | @since 0.8 *) 8 | 9 | type 'a t 10 | (** A value surrounded with a lock *) 11 | 12 | val create : 'a -> 'a t 13 | (** Create a new protected value. *) 14 | 15 | val with_lock : 'a t -> ('a -> 'b) -> 'b 16 | (** [with_lock l f] runs [f x] where [x] is the value protected with 17 | the lock [l], in a critical section. If [f x] fails, [with_lock l f] 18 | fails too but the lock is released. *) 19 | 20 | val try_with_lock : 'a t -> ('a -> 'b) -> 'b option 21 | (** [try_with_lock l f] runs [f x] in a critical section if [l] is not 22 | locked. [x] is the value protected by the lock [l]. If [f x] 23 | fails, [try_with_lock l f] fails too but the lock is released. 24 | @since 0.22 *) 25 | 26 | (** Type allowing to manipulate the lock as a reference. 27 | @since 0.13 *) 28 | module LockRef : sig 29 | type 'a t 30 | 31 | val get : 'a t -> 'a 32 | val set : 'a t -> 'a -> unit 33 | val update : 'a t -> ('a -> 'a) -> unit 34 | end 35 | 36 | val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b 37 | (** [with_lock_as_ref l f] calls [f] with a reference-like object 38 | that allows to manipulate the value of [l] safely. 39 | The object passed to [f] must not escape the function call. 40 | @since 0.13 *) 41 | 42 | val update : 'a t -> ('a -> 'a) -> unit 43 | (** [update l f] replaces the content [x] of [l] with [f x], atomically. *) 44 | 45 | val update_map : 'a t -> ('a -> 'a * 'b) -> 'b 46 | (** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l] 47 | and returns [y]. 48 | @since 0.16 *) 49 | 50 | val mutex : _ t -> Mutex.t 51 | (** Underlying mutex. *) 52 | 53 | val get : 'a t -> 'a 54 | (** Atomically get the value in the lock. The value that is returned 55 | isn't protected! *) 56 | 57 | val set : 'a t -> 'a -> unit 58 | (** Atomically set the value. 59 | @since 0.13 *) 60 | 61 | val incr : int t -> unit 62 | (** Atomically increment the value. 63 | @since 0.13 *) 64 | 65 | val decr : int t -> unit 66 | (** Atomically decrement the value. 67 | @since 0.13 *) 68 | 69 | val incr_then_get : int t -> int 70 | (** [incr_then_get x] increments [x], and returns its new value. 71 | @since 0.16 *) 72 | 73 | val get_then_incr : int t -> int 74 | (** [get_then_incr x] increments [x], and returns its previous value. 75 | @since 0.16 *) 76 | 77 | val decr_then_get : int t -> int 78 | (** [decr_then_get x] decrements [x], and returns its new value. 79 | @since 0.16 *) 80 | 81 | val get_then_decr : int t -> int 82 | (** [get_then_decr x] decrements [x], and returns its previous value. 83 | @since 0.16 *) 84 | 85 | val get_then_set : bool t -> bool 86 | (** [get_then_set b] sets [b] to [true], and returns the old value. 87 | @since 0.16 *) 88 | 89 | val get_then_clear : bool t -> bool 90 | (** [get_then_clear b] sets [b] to [false], and returns the old value. 91 | @since 0.16 *) 92 | -------------------------------------------------------------------------------- /src/data/CCHashSet.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Mutable Set 4 | 5 | {b status: unstable} 6 | 7 | @since 0.13 *) 8 | 9 | type 'a iter = ('a -> unit) -> unit 10 | type 'a printer = Format.formatter -> 'a -> unit 11 | 12 | module type S = sig 13 | type t 14 | type elt 15 | 16 | val create : int -> t 17 | (** [create n] makes a new set with the given capacity [n]. *) 18 | 19 | val singleton : elt -> t 20 | (** [singleton x] is the singleton [{x}]. *) 21 | 22 | val clear : t -> unit 23 | (** [clear s] removes all elements from [s]. *) 24 | 25 | val copy : t -> t 26 | (** Fresh copy. *) 27 | 28 | val copy_into : into:t -> t -> unit 29 | (** [copy_into ~into s] copies all elements of [s] into [into]. *) 30 | 31 | val insert : t -> elt -> unit 32 | (** [insert s x] adds [x] into [s]. *) 33 | 34 | val remove : t -> elt -> unit 35 | (** Remove the element, if it were in there. *) 36 | 37 | val cardinal : t -> int 38 | (** [cardinal s] returns the number of elements in [s]. *) 39 | 40 | val mem : t -> elt -> bool 41 | (** [mem s x] returns [true] iff [x] is in [s]. *) 42 | 43 | val find_exn : t -> elt -> elt 44 | (** [find_exn s x] returns [y] if [x] and [y] are equal, and [mem s y]. 45 | @raise Not_found if [x] not in [s]. *) 46 | 47 | val find : t -> elt -> elt option 48 | (** Safe version of {!find_exn}. *) 49 | 50 | val inter : t -> t -> t 51 | (** [inter a b] returns [a ∩ b]. *) 52 | 53 | val inter_mut : into:t -> t -> unit 54 | (** [inter_mut ~into a] changes [into] into [a ∩ into]. *) 55 | 56 | val union : t -> t -> t 57 | (** [union a b] returns [a ∪ b]. *) 58 | 59 | val union_mut : into:t -> t -> unit 60 | (** [union_mut ~into a] changes [into] into [a ∪ into]. *) 61 | 62 | val diff : t -> t -> t 63 | (** [diff a b] returns [a - b]. *) 64 | 65 | val subset : t -> t -> bool 66 | (** [subset a b] returns [true] if all elements of [a] are in [b]. *) 67 | 68 | val equal : t -> t -> bool 69 | (** [equal a b] is extensional equality ([a] and [b] have the same elements). *) 70 | 71 | val for_all : (elt -> bool) -> t -> bool 72 | val exists : (elt -> bool) -> t -> bool 73 | 74 | val iter : (elt -> unit) -> t -> unit 75 | (** Iterate on values. *) 76 | 77 | val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a 78 | (** Fold on values. *) 79 | 80 | val elements : t -> elt list 81 | (** List of elements. *) 82 | 83 | val of_list : elt list -> t 84 | val to_iter : t -> elt iter 85 | val of_iter : elt iter -> t 86 | val add_iter : t -> elt iter -> unit 87 | 88 | val pp : ?pp_sep:unit printer -> elt printer -> t printer 89 | (** [pp pp_elt] returns a set printer, given a printer for 90 | individual elements. *) 91 | end 92 | 93 | module type ELEMENT = sig 94 | type t 95 | 96 | val equal : t -> t -> bool 97 | 98 | val hash : t -> int 99 | (** Positive value *) 100 | end 101 | 102 | module Make (E : ELEMENT) : S with type elt = E.t 103 | -------------------------------------------------------------------------------- /src/core/CCSet.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** Wrapper around Set 4 | 5 | @since 0.9 *) 6 | 7 | type 'a iter = ('a -> unit) -> unit 8 | (** Fast internal iterator. 9 | @since 2.8 *) 10 | 11 | type 'a printer = Format.formatter -> 'a -> unit 12 | 13 | module type OrderedType = Set.OrderedType 14 | (** @since 1.5 *) 15 | 16 | module type S = sig 17 | include Set.S 18 | 19 | val min_elt_opt : t -> elt option 20 | (** Safe version of {!min_elt}. 21 | @since 1.5 *) 22 | 23 | val max_elt_opt : t -> elt option 24 | (** Safe version of {!max_elt}. 25 | @since 1.5 *) 26 | 27 | val choose_opt : t -> elt option 28 | (** Safe version of {!choose}. 29 | @since 1.5 *) 30 | 31 | val find_opt : elt -> t -> elt option 32 | (** Safe version of {!find}. 33 | @since 1.5 *) 34 | 35 | val find_first : (elt -> bool) -> t -> elt 36 | (** Find minimum element satisfying predicate. 37 | @since 1.5 *) 38 | 39 | val find_first_opt : (elt -> bool) -> t -> elt option 40 | (** Safe version of {!find_first}. 41 | @since 1.5 *) 42 | 43 | val find_first_map : (elt -> 'a option) -> t -> 'a option 44 | (** [find_first_map f s] find the minimum element [x] of [s] such that [f x = Some y] 45 | and return [Some y]. Otherwise returns [None]. 46 | @since NEXT_RELEASE *) 47 | 48 | val find_last : (elt -> bool) -> t -> elt 49 | (** Find maximum element satisfying predicate. 50 | @since 1.5 *) 51 | 52 | val find_last_opt : (elt -> bool) -> t -> elt option 53 | (** Safe version of {!find_last}. 54 | @since 1.5 *) 55 | 56 | val find_last_map : (elt -> 'a option) -> t -> 'a option 57 | (** [find_last_map f s] find the maximum element [x] of [s] such that [f x = Some y] 58 | and return [Some y]. Otherwise returns [None]. 59 | @since NEXT_RELEASE *) 60 | 61 | val of_iter : elt iter -> t 62 | (** Build a set from the given [iter] of elements. 63 | @since 2.8 *) 64 | 65 | val of_seq : elt Seq.t -> t 66 | (** Build a set from the given [seq] of elements. 67 | @since 3.0 *) 68 | 69 | val add_iter : t -> elt iter -> t 70 | (** @since 2.8 *) 71 | 72 | val add_seq : elt Seq.t -> t -> t 73 | (** @since 3.0 *) 74 | 75 | val to_iter : t -> elt iter 76 | (** [to_iter t] converts the set [t] to a [iter] of the elements. 77 | @since 2.8 *) 78 | 79 | val add_list : t -> elt list -> t 80 | (** @since 0.14 *) 81 | 82 | val to_list : t -> elt list 83 | (** [to_list t] converts the set [t] to a list of the elements. *) 84 | 85 | val to_string : 86 | ?start:string -> 87 | ?stop:string -> 88 | ?sep:string -> 89 | (elt -> string) -> 90 | t -> 91 | string 92 | (** Print the set in a string 93 | @since 2.7 *) 94 | 95 | val pp : 96 | ?pp_start:unit printer -> 97 | ?pp_stop:unit printer -> 98 | ?pp_sep:unit printer -> 99 | elt printer -> 100 | t printer 101 | (** Print the set. *) 102 | end 103 | 104 | module Make (O : Set.OrderedType) : 105 | S with type t = Set.Make(O).t and type elt = O.t 106 | -------------------------------------------------------------------------------- /src/core/CCFloat.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | open CCShims_ 4 | 5 | type t = float 6 | 7 | type fpclass = Stdlib.fpclass = 8 | | FP_normal 9 | | FP_subnormal 10 | | FP_zero 11 | | FP_infinite 12 | | FP_nan 13 | 14 | module Infix = struct 15 | let ( = ) : t -> t -> bool = Stdlib.( = ) 16 | let ( <> ) : t -> t -> bool = Stdlib.( <> ) 17 | let ( < ) : t -> t -> bool = Stdlib.( < ) 18 | let ( > ) : t -> t -> bool = Stdlib.( > ) 19 | let ( <= ) : t -> t -> bool = Stdlib.( <= ) 20 | let ( >= ) : t -> t -> bool = Stdlib.( >= ) 21 | let ( ~- ) : t -> t = Stdlib.( ~-. ) 22 | let ( + ) : t -> t -> t = Stdlib.( +. ) 23 | let ( - ) : t -> t -> t = Stdlib.( -. ) 24 | let ( * ) : t -> t -> t = Stdlib.( *. ) 25 | let ( / ) : t -> t -> t = Stdlib.( /. ) 26 | end 27 | 28 | include Infix 29 | 30 | let nan = Stdlib.nan 31 | let infinity = Stdlib.infinity 32 | let neg_infinity = Stdlib.neg_infinity 33 | let max_value = infinity 34 | let min_value = neg_infinity 35 | let max_finite_value = Stdlib.max_float 36 | let epsilon = Stdlib.epsilon_float 37 | let pi = 0x1.921fb54442d18p+1 38 | let is_nan x = Stdlib.(classify_float x = Stdlib.FP_nan) 39 | let add = ( +. ) 40 | let sub = ( -. ) 41 | let mul = ( *. ) 42 | let div = ( /. ) 43 | let neg = ( ~-. ) 44 | let abs = Stdlib.abs_float 45 | let scale = ( *. ) 46 | 47 | let min (x : t) y = 48 | match Stdlib.classify_float x, Stdlib.classify_float y with 49 | | FP_nan, _ -> y 50 | | _, FP_nan -> x 51 | | _ -> 52 | if x < y then 53 | x 54 | else 55 | y 56 | 57 | let max (x : t) y = 58 | match Stdlib.classify_float x, Stdlib.classify_float y with 59 | | FP_nan, _ -> y 60 | | _, FP_nan -> x 61 | | _ -> 62 | if x > y then 63 | x 64 | else 65 | y 66 | 67 | let equal (a : float) b = a = b 68 | let hash : t -> int = Hashtbl.hash 69 | let compare (a : float) b = Stdlib.compare a b 70 | 71 | type 'a printer = Format.formatter -> 'a -> unit 72 | type 'a random_gen = Random.State.t -> 'a 73 | 74 | let pp = Format.pp_print_float 75 | 76 | let fsign a = 77 | if is_nan a then 78 | nan 79 | else if a = 0. then 80 | a 81 | else 82 | Stdlib.copysign 1. a 83 | 84 | exception TrapNaN of string 85 | 86 | let sign_exn (a : float) = 87 | if is_nan a then 88 | raise (TrapNaN "sign_exn") 89 | else 90 | compare a 0. 91 | 92 | let round x = 93 | let low = floor x in 94 | let high = ceil x in 95 | if x -. low > high -. x then 96 | high 97 | else 98 | low 99 | 100 | let to_int (a : float) = Stdlib.int_of_float a 101 | let of_int (a : int) = Stdlib.float_of_int a 102 | let to_string (a : float) = Stdlib.string_of_float a 103 | let of_string_exn (a : string) = Stdlib.float_of_string a 104 | 105 | let of_string_opt (a : string) = 106 | try Some (Stdlib.float_of_string a) with Failure _ -> None 107 | 108 | let random n st = Random.State.float st n 109 | let random_small = random 100.0 110 | let random_range i j st = i +. random (j -. i) st 111 | let equal_precision ~epsilon a b = abs_float (a -. b) < epsilon 112 | let classify = Stdlib.classify_float 113 | -------------------------------------------------------------------------------- /tests/core/t_nativeint.ml: -------------------------------------------------------------------------------- 1 | open CCNativeint 2 | module T = (val Containers_testlib.make ~__FILE__ ()) 3 | include T;; 4 | 5 | t @@ fun () -> pow 2n 10n = 1024n;; 6 | t @@ fun () -> pow 2n 15n = 32768n;; 7 | t @@ fun () -> pow 10n 5n = 100000n;; 8 | t @@ fun () -> pow 42n 0n = 1n;; 9 | t @@ fun () -> pow 0n 1n = 0n;; 10 | t @@ fun () -> floor_div 3n 5n = 0n;; 11 | t @@ fun () -> floor_div 5n 5n = 1n;; 12 | t @@ fun () -> floor_div 20n 5n = 4n;; 13 | t @@ fun () -> floor_div 12n 5n = 2n;; 14 | t @@ fun () -> floor_div 0n 5n = 0n;; 15 | t @@ fun () -> floor_div (-1n) 5n = -1n;; 16 | t @@ fun () -> floor_div (-5n) 5n = -1n;; 17 | t @@ fun () -> floor_div (-12n) 5n = -3n;; 18 | t @@ fun () -> floor_div 0n (-5n) = 0n;; 19 | t @@ fun () -> floor_div 3n (-5n) = -1n;; 20 | t @@ fun () -> floor_div 5n (-5n) = -1n;; 21 | t @@ fun () -> floor_div 9n (-5n) = -2n;; 22 | t @@ fun () -> floor_div 20n (-5n) = -4n;; 23 | t @@ fun () -> floor_div (-2n) (-5n) = 0n;; 24 | t @@ fun () -> floor_div (-8n) (-5n) = 1n;; 25 | t @@ fun () -> floor_div (-35n) (-5n) = 7n;; 26 | 27 | t @@ fun () -> 28 | try 29 | ignore (floor_div 12n 0n); 30 | false 31 | with Division_by_zero -> true 32 | ;; 33 | 34 | t @@ fun () -> 35 | try 36 | ignore (floor_div (-12n) 0n); 37 | false 38 | with Division_by_zero -> true 39 | ;; 40 | 41 | q 42 | (Q.pair (Q.map of_int Q.small_signed_int) (Q.map of_int Q.small_nat)) 43 | (fun (n, m) -> 44 | let m = m + 1n in 45 | floor_div n m = of_float @@ floor (to_float n /. to_float m)) 46 | ;; 47 | 48 | q 49 | (Q.pair (Q.map of_int Q.small_signed_int) (Q.map of_int Q.small_nat)) 50 | (fun (n, m) -> 51 | let m = m + 1n in 52 | floor_div n (-m) = of_float @@ floor (to_float n /. to_float (-m))) 53 | 54 | let eq' = eq ~printer:Q.Print.(list to_string);; 55 | 56 | eq' [ 0n; 1n; 2n; 3n; 4n; 5n ] (range 0n 5n |> Iter.to_list);; 57 | eq' [ 0n ] (range 0n 0n |> Iter.to_list);; 58 | eq' [ 5n; 4n; 3n; 2n ] (range 5n 2n |> Iter.to_list) 59 | 60 | (* note: the last test checks that no error occurs due to overflows. *) 61 | let eq' = eq ~printer:Q.Print.(list to_string);; 62 | 63 | eq' [ 0n ] (range_by ~step:1n 0n 0n |> Iter.to_list);; 64 | eq' [] (range_by ~step:1n 5n 0n |> Iter.to_list);; 65 | eq' [] (range_by ~step:2n 1n 0n |> Iter.to_list);; 66 | eq' [ 0n; 2n; 4n ] (range_by ~step:2n 0n 4n |> Iter.to_list);; 67 | eq' [ 0n; 2n; 4n ] (range_by ~step:2n 0n 5n |> Iter.to_list);; 68 | eq' [ 0n ] (range_by ~step:(neg 1n) 0n 0n |> Iter.to_list);; 69 | eq' [] (range_by ~step:(neg 1n) 0n 5n |> Iter.to_list);; 70 | eq' [] (range_by ~step:(neg 2n) 0n 1n |> Iter.to_list);; 71 | eq' [ 5n; 3n; 1n ] (range_by ~step:(neg 2n) 5n 1n |> Iter.to_list);; 72 | eq' [ 5n; 3n; 1n ] (range_by ~step:(neg 2n) 5n 0n |> Iter.to_list);; 73 | eq' [ 0n ] (range_by ~step:max_int 0n 2n |> Iter.to_list);; 74 | 75 | q 76 | Q.(pair (map of_int small_int) (map of_int small_int)) 77 | (fun (i, j) -> 78 | let i = min i j and j = max i j in 79 | CCList.equal CCNativeint.equal 80 | (CCNativeint.range_by ~step:1n i j |> Iter.to_list) 81 | (CCNativeint.range i j |> Iter.to_list)) 82 | ;; 83 | 84 | eq ~printer:CCFun.id "0b111" (to_string_binary 7n);; 85 | eq ~printer:CCFun.id "-0b111" (to_string_binary (-7n));; 86 | eq ~printer:CCFun.id "0b0" (to_string_binary 0n) 87 | -------------------------------------------------------------------------------- /benchs/run_objsize.ml: -------------------------------------------------------------------------------- 1 | (* module Deque = Core_kernel.Deque *) 2 | module Int_map = CCMap.Make (CCInt) 3 | module Int_set = CCSet.Make (CCInt) 4 | 5 | let dup = CCPair.dup 6 | let id = CCFun.id 7 | let ns n = List.init n CCFun.id 8 | let iter_range n f = List.iter f (ns n) 9 | 10 | let gen_cons x xs = 11 | let saw_x = ref false in 12 | fun () -> 13 | if !saw_x then ( 14 | saw_x := true; 15 | Some x 16 | ) else 17 | xs () 18 | 19 | let front = Sek.front 20 | let dummy = 0 21 | 22 | let types = 23 | [ 24 | ("Stdlib.List", fun n -> Obj.magic @@ ns n); 25 | ("Stdlib.Array", fun n -> Obj.magic @@ Array.init n id); 26 | ( "Stdlib.Hashtbl", 27 | fun n -> Obj.magic @@ CCHashtbl.of_iter Iter.(init dup |> take n) ); 28 | ( "Base.Hashtbl", 29 | fun n -> Obj.magic @@ Base.Hashtbl.Poly.of_alist_exn (List.init n dup) ); 30 | ( "Stdlib.Map", 31 | fun n -> Obj.magic @@ Int_map.of_iter Iter.(init dup |> take n) ); 32 | ( "Stdlib.Set", 33 | fun n -> Obj.magic @@ Int_set.of_iter Iter.(init id |> take n) ); 34 | ("CCFun_vec", fun n -> Obj.magic @@ CCFun_vec.of_list (ns n)); 35 | ("CCRAL", fun n -> Obj.magic @@ CCRAL.of_list (ns n)); 36 | ("BatVect", fun n -> Obj.magic @@ BatVect.of_list (ns n)); 37 | ( "Sek.Persistent", 38 | fun n -> 39 | Obj.magic 40 | @@ List.fold_left 41 | (Sek.Persistent.push front) 42 | (Sek.Persistent.create dummy) 43 | (ns n) ); 44 | ( "Sek.Ephemeral", 45 | fun n -> 46 | Obj.magic 47 | @@ 48 | let c = Sek.Ephemeral.create dummy in 49 | iter_range n (Sek.Ephemeral.push front c); 50 | c ); 51 | ( "CCVector", 52 | fun n -> 53 | Obj.magic 54 | @@ 55 | let c = CCVector.create () in 56 | iter_range n (CCVector.push c); 57 | c ); 58 | (* "Core_kernel.Deque", (fun n -> Obj.magic @@ let c = Deque.create () in iter_range n (Deque.enqueue_back c); c); *) 59 | ( "Base.Queue", 60 | fun n -> 61 | Obj.magic 62 | @@ 63 | let c = Base.Queue.create () in 64 | iter_range n (Base.Queue.enqueue c); 65 | c ); 66 | ( "Stdlib.Queue", 67 | fun n -> 68 | Obj.magic 69 | @@ 70 | let q = Queue.create () in 71 | iter_range n (fun x -> Queue.push x q); 72 | q ); 73 | ("CCQueue", fun n -> Obj.magic @@ CCDeque.of_list (ns n)); 74 | ("Iter", fun n -> Obj.magic @@ List.fold_right Iter.cons (ns n) Iter.empty); 75 | ("Gen", fun n -> Obj.magic @@ List.fold_right gen_cons (ns n) Gen.empty); 76 | ( "Stdlib.Seq", 77 | fun n -> Obj.magic @@ List.fold_right OSeq.cons (ns n) OSeq.empty ); 78 | ] 79 | 80 | let () = 81 | let sizes = [ 0; 1; 10; 100; 1000; 10000 ] in 82 | Printf.printf "%-20s " ""; 83 | sizes |> List.iter (fun n -> Printf.printf "%6d " n); 84 | Printf.printf "\n"; 85 | types 86 | |> List.iter (fun (name, create) -> 87 | Printf.printf "%-20s: " name; 88 | sizes 89 | |> List.iter (fun n -> 90 | let obj = create n in 91 | let size = Objsize.size_w obj in 92 | (* let size = Obj.reachable_words (Obj.repr obj) in *) 93 | Printf.printf "%6d " size); 94 | Printf.printf "\n") 95 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation. 6 | 7 | ## Our Standards 8 | 9 | Examples of behavior that contributes to creating a positive environment include: 10 | 11 | * Using welcoming and inclusive language 12 | * Being respectful of differing viewpoints and experiences 13 | * Gracefully accepting constructive criticism 14 | * Focusing on what is best for the community 15 | * Showing empathy towards other community members 16 | 17 | Examples of unacceptable behavior by participants include: 18 | 19 | * The use of sexualized language or imagery and unwelcome sexual attention or advances 20 | * Trolling, insulting/derogatory comments, and personal or political attacks 21 | * Public or private harassment 22 | * Publishing others' private information, such as a physical or electronic address, without explicit permission 23 | * Other conduct which could reasonably be considered inappropriate in a professional setting 24 | 25 | ## Our Responsibilities 26 | 27 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. 28 | 29 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. 30 | 31 | ## Scope 32 | 33 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. 34 | 35 | ## Enforcement 36 | 37 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at simon.cruanes.2007@m4x.org. The project team will review and investigate all complaints, and will respond in a way that it deems appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. 38 | 39 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. 40 | 41 | ## Attribution 42 | 43 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at [http://contributor-covenant.org/version/1/4][version] 44 | 45 | [homepage]: http://contributor-covenant.org 46 | [version]: http://contributor-covenant.org/version/1/4/ 47 | --------------------------------------------------------------------------------