diff --git a/Makefile b/Makefile index a3ded520..a6946d2c 100644 --- a/Makefile +++ b/Makefile @@ -74,8 +74,6 @@ QTESTABLE=$(filter-out $(DONTTEST), \ $(wildcard src/unix/*.mli) \ $(wildcard src/sexp/*.ml) \ $(wildcard src/sexp/*.mli) \ - $(wildcard src/advanced/*.ml) \ - $(wildcard src/advanced/*.mli) \ $(wildcard src/iter/*.ml) \ $(wildcard src/iter/*.mli) \ $(wildcard src/bigarray/*.ml) \ diff --git a/README.adoc b/README.adoc index 6935c6fa..9d855fbd 100644 --- a/README.adoc +++ b/README.adoc @@ -199,15 +199,6 @@ In the module `Containers_string`: - `KMP`: Knuth-Morris-Pratt substring algorithm - `Parse`: simple parser combinators -=== Advanced - -See http://cedeela.fr/~simon/software/containers/Containers_advanced[doc]. - -In the module `Containers_advanced`: -- `CCLinq`, high-level query language over collections -- `CCCat`, a few categorical structures -- `CCBatch`, to combine operations on collections into one traversal - === Thread In the library `containers.thread`, for preemptive system threads: diff --git a/_oasis b/_oasis index c24d5aa9..9a7426ad 100644 --- a/_oasis +++ b/_oasis @@ -36,10 +36,6 @@ Flag "bench" Description: Build and run benchmarks Default: true -Flag "advanced" - Description: Build advanced combinators (requires "sequence") - Default: true - Library "containers" Path: src/core Modules: CCVector, CCError, CCHeap, CCList, CCOpt, CCPair, @@ -89,15 +85,6 @@ Library "containers_string" FindlibName: string FindlibParent: containers -Library "containers_advanced" - Path: src/advanced - Modules: Containers_advanced, CCLinq, CCBatch, CCCat, CCMonadIO - Build$: flag(advanced) - Install$: flag(advanced) - FindlibName: advanced - FindlibParent: containers - BuildDepends: containers, sequence - Library "containers_thread" Path: src/threads/ Modules: CCPool, CCLock, CCSemaphore, CCThread, CCBlockingQueue, @@ -122,7 +109,7 @@ Document containers Title: Containers docs Type: ocamlbuild (0.3) BuildTools+: ocamldoc - Build$: flag(docs) && flag(advanced) && flag(unix) + Build$: flag(docs) && flag(unix) Install: true XOCamlbuildPath: . XOCamlbuildExtraArgs: @@ -130,7 +117,7 @@ Document containers XOCamlbuildLibraries: containers, containers.iter, containers.data, containers.string, containers.thread, - containers.advanced, containers.unix, containers.sexp + containers.unix, containers.sexp Executable run_benchs Path: benchs/ @@ -138,7 +125,7 @@ Executable run_benchs CompiledObject: best Build$: flag(bench) MainIs: run_benchs.ml - BuildDepends: containers, containers.advanced, qcheck, + BuildDepends: containers, qcheck, containers.data, containers.string, containers.iter, containers.thread, sequence, gen, benchmark, hamt @@ -157,9 +144,9 @@ Executable run_qtest Install: false CompiledObject: best MainIs: run_qtest.ml - Build$: flag(tests) && flag(bigarray) && flag(unix) && flag(advanced) + Build$: flag(tests) && flag(bigarray) && flag(unix) BuildDepends: containers, containers.string, containers.iter, - containers.advanced, containers.sexp, + containers.sexp, containers.unix, containers.thread, containers.data, sequence, gen, unix, oUnit, qcheck @@ -167,7 +154,7 @@ Executable run_qtest Test all Command: ./run_qtest.native TestTools: run_qtest - Run$: flag(tests) && flag(unix) && flag(advanced) && flag(bigarray) + Run$: flag(tests) && flag(unix) && flag(bigarray) Executable mem_measure Path: benchs/ diff --git a/doc/intro.txt b/doc/intro.txt index 3d921c84..08402120 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -131,15 +131,6 @@ CCLevenshtein CCParse } -{4 Advanced} - -{b findlib name}: containers.advanced - -This module is qualified with [Containers_advanced]. It -requires {{:https://github.com/c-cube/sequence} Sequence}. - -{!modules: CCLinq CCCat CCBatch} - {4 Misc} Moved to its own repository. diff --git a/src/advanced/CCBatch.ml b/src/advanced/CCBatch.ml deleted file mode 100644 index 4f2e7cd6..00000000 --- a/src/advanced/CCBatch.ml +++ /dev/null @@ -1,237 +0,0 @@ -(* -copyright (c) 2013-2014, Simon Cruanes, Gabriel Radanne -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Batch Operations on Collections} *) - -module type COLLECTION = sig - type 'a t - - val empty : 'a t - val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val map : ('a -> 'b) -> 'a t -> 'b t - val filter : ('a -> bool) -> 'a t -> 'a t - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - val flat_map : ('a -> 'b t) -> 'a t -> 'b t -end - -module type S = sig - type 'a t - - type ('a,'b) op - (** Operation that converts a ['a t] into a ['b t] *) - - val apply : ('a,'b) op -> 'a t -> 'b t - (** Apply the operation to the collection. *) - - val apply_fold : ('a, 'b) op -> ('c -> 'b -> 'c) -> 'c -> 'a t -> 'c - (** Apply the operation plus a fold to the collection. *) - - val apply' : 'a t -> ('a,'b) op -> 'b t - (** Flip of {!apply} *) - - (** {6 Combinators} *) - - val id : ('a, 'a) op - - val map : ('a -> 'b) -> ('a, 'b) op - - val filter : ('a -> bool) -> ('a,'a) op - - val filter_map : ('a -> 'b option) -> ('a,'b) op - - val flat_map : ('a -> 'b t) -> ('a,'b) op - - val extern : ('a t -> 'b t) -> ('a,'b) op - - val compose : ('b,'c) op -> ('a,'b) op -> ('a,'c) op - val (>>>) : ('a,'b) op -> ('b,'c) op -> ('a,'c) op -end - -module Make(C : COLLECTION) = struct - type 'a t = 'a C.t - type (_,_) op = - | Nil : ('a,'a) op - | Compose : ('a,'b) base_op * ('b, 'c) op -> ('a, 'c) op - and (_,_) base_op = - | Map : ('a -> 'b) -> ('a, 'b) base_op - | Filter : ('a -> bool) -> ('a, 'a) base_op - | FilterMap : ('a -> 'b option) -> ('a,'b) base_op - | FlatMap : ('a -> 'b t) -> ('a,'b) base_op - | Extern : ('a t -> 'b t) -> ('a,'b) base_op - - (* associativity: put parenthesis on the right *) - let rec _compose : type a b c. (a,b) op -> (b,c) op -> (a,c) op - = fun f g -> match f with - | Compose (f1, Nil) -> Compose (f1, g) - | Compose (f1, f2) -> Compose (f1, _compose f2 g) - | Nil -> g - - (* After optimization, the op is a list of flatmaps and external operations, - with maybe something else at the end *) - type (_,_) optimized_op = - | OptNil : ('a, 'a) optimized_op - | OptBase : ('a,'b) base_op * ('b, 'c) optimized_op -> ('a,'c) optimized_op - | OptFlatMap : ('a -> 'b t) * ('b, 'c) optimized_op -> ('a, 'c) optimized_op - | OptExtern : ('a t -> 'b t) * ('b, 'c) optimized_op -> ('a, 'c) optimized_op - - (* As compose, but optimize recursively on the way. *) - let rec optimize_compose - : type a b c. (a,b) base_op -> (b,c) op -> (a,c) optimized_op - = fun base_op op -> match base_op, op with - | f, Nil -> OptBase (f, OptNil) - | Map f, Compose (Map g, cont) -> - optimize_compose (Map (fun x -> g (f x))) cont - | Map f, Compose (Filter p, cont) -> - optimize_compose - (FilterMap (fun x -> let y = f x in if p y then Some y else None)) cont - | Map f, Compose (FilterMap f', cont) -> - optimize_compose - (FilterMap (fun x -> f' (f x))) cont - | Map f, Compose (FlatMap f', cont) -> - optimize_compose - (FlatMap (fun x -> f' (f x))) cont - | Filter p, Compose (Filter p', cont) -> - optimize_compose (Filter (fun x -> p x && p' x)) cont - | Filter p, Compose (Map g, cont) -> - optimize_compose - (FilterMap (fun x -> if p x then Some (g x) else None)) cont - | Filter p, Compose (FilterMap f', cont) -> - optimize_compose - (FilterMap (fun x -> if p x then f' x else None)) cont - | Filter p, Compose (FlatMap f', cont) -> - optimize_compose - (FlatMap (fun x -> if p x then f' x else C.empty)) cont - | FilterMap f, Compose (FilterMap f', cont) -> - optimize_compose - (FilterMap - (fun x -> match f x with None -> None | Some y -> f' y)) - cont - | FilterMap f, Compose (Filter p, cont) -> - optimize_compose - (FilterMap - (fun x -> match f x with - | (Some y) as res when p y -> res - | _ -> None)) - cont - | FilterMap f, Compose (Map f', cont) -> - optimize_compose - (FilterMap - (fun x -> match f x with - | None -> None - | Some y -> Some (f' y))) - cont - | FilterMap f, Compose (FlatMap f', cont) -> - optimize_compose - (FlatMap - (fun x -> match f x with - | None -> C.empty - | Some y -> f' y)) - cont - | FlatMap f, Compose (f', tail) -> - merge_flat_map f (optimize_compose f' tail) - | Extern f, Compose (f', tail) -> - OptExtern (f, optimize_compose f' tail) - | op, Compose (Extern f', cont) -> - OptBase (op, optimize_compose (Extern f') cont) - - and merge_flat_map - : type a b c. (a -> b C.t) -> (b,c) optimized_op -> (a,c) optimized_op = - fun f op -> match op with - | OptNil -> OptFlatMap (f, op) - | OptFlatMap (f', cont) -> - merge_flat_map - (fun x -> - let a = f x in - C.flat_map f' a) - cont - | OptExtern _ -> OptFlatMap (f, op) - | OptBase _ -> OptFlatMap (f, op) - - (* Optimize a batch operation by fusion *) - let optimize : type a b. (a,b) op -> (a,b) optimized_op - = fun op -> match op with - | Compose (a, b) -> optimize_compose a b - | Nil -> OptNil - - let rec apply_optimized : type a b. (a,b) optimized_op -> a t -> b t - = fun op a -> match op with - | OptNil -> a - | OptBase (f,c) -> apply_optimized c (apply_base f a) - | OptFlatMap (f,c) -> apply_optimized c (C.flat_map f a) - | OptExtern (f,c) -> apply_optimized c (f a) - and apply_base : type a b. (a,b) base_op -> a t -> b t - = fun op a -> match op with - | Map f -> C.map f a - | Filter p -> C.filter p a - | FlatMap f -> C.flat_map f a - | FilterMap f -> C.filter_map f a - | Extern f -> f a - - let fusion_fold : type a b c. (a,b) base_op -> (c -> b -> c) -> c -> a -> c - = fun op f' -> match op with - | Map f -> (fun z x -> f' z (f x)) - | Filter p -> (fun z x -> if p x then f' z x else z) - | FlatMap f -> (fun z x -> C.fold f' z (f x)) - | FilterMap f -> (fun z x -> match f x with Some x' -> f' z x' | None -> z) - | Extern _ -> assert false - - let rec apply_optimized_with_fold - : type a b c. (a,b) optimized_op -> (c -> b -> c) -> c -> a t -> c - = fun op fold z a -> match op with - | OptNil -> C.fold fold z a - | OptBase (Extern f, OptNil) -> - C.fold fold z (f a) - | OptBase (f,OptNil) -> - (* terminal fold *) - C.fold (fusion_fold f fold) z a - | OptBase (f,c) -> - (* make intermediate collection and continue *) - apply_optimized_with_fold c fold z (apply_base f a) - | OptExtern (f,c) -> apply_optimized_with_fold c fold z (f a) - | OptFlatMap (f,c) -> apply_optimized_with_fold c fold z (C.flat_map f a) - - (* Optimize and run *) - let apply op a = - let op' = optimize op in - apply_optimized op' a - - let apply_fold op fold z a = - let op' = optimize op in - apply_optimized_with_fold op' fold z a - - let apply' a op = apply op a - - (** {6 Combinators} *) - - let id = Nil - let map f = Compose (Map f, Nil) - let filter p = Compose (Filter p, Nil) - let filter_map f = Compose (FilterMap f, Nil) - let flat_map f = Compose (FlatMap f, Nil) - let extern f = Compose (Extern f, Nil) - - let compose f g = _compose g f - let (>>>) f g = _compose f g -end diff --git a/src/advanced/CCBatch.mli b/src/advanced/CCBatch.mli deleted file mode 100644 index 6f68fa07..00000000 --- a/src/advanced/CCBatch.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Batch Operations on Collections} -Define and combine operations on a collection of elements, then -run the composition of those operations on some collection. The -composition is optimized to minimize the number of intermediate -collections *) - -(** {2 Definition of a Collection} *) -module type COLLECTION = sig - type 'a t - - val empty : 'a t - val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val map : ('a -> 'b) -> 'a t -> 'b t - val filter : ('a -> bool) -> 'a t -> 'a t - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - val flat_map : ('a -> 'b t) -> 'a t -> 'b t -end - -(** {2 Definition of a Batch operations} *) -module type S = sig - type 'a t - - type ('a,'b) op - (** Operation that converts a ['a t] into a ['b t] *) - - val apply : ('a,'b) op -> 'a t -> 'b t - (** Apply the operation to the collection. *) - - val apply_fold : ('a, 'b) op -> ('c -> 'b -> 'c) -> 'c -> 'a t -> 'c - (** Apply the operation plus a fold to the collection. *) - - val apply' : 'a t -> ('a,'b) op -> 'b t - (** Flip of {!apply} *) - - (** {6 Combinators} *) - - val id : ('a, 'a) op - - val map : ('a -> 'b) -> ('a, 'b) op - - val filter : ('a -> bool) -> ('a,'a) op - - val filter_map : ('a -> 'b option) -> ('a,'b) op - - val flat_map : ('a -> 'b t) -> ('a,'b) op - - val extern : ('a t -> 'b t) -> ('a,'b) op - (** Use a specific function that won't be optimized *) - - val compose : ('b,'c) op -> ('a,'b) op -> ('a,'c) op - val (>>>) : ('a,'b) op -> ('b,'c) op -> ('a,'c) op -end - -(** {2 Functor} *) -module Make(C : COLLECTION) : S with type 'a t = 'a C.t diff --git a/src/advanced/CCCat.ml b/src/advanced/CCCat.ml deleted file mode 100644 index 0bbc6b50..00000000 --- a/src/advanced/CCCat.ml +++ /dev/null @@ -1,144 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Categorical Constructs} *) - -(** {2 Signatures} *) - -module type MONOID = sig - type t - val empty : t - val append : t -> t -> t -end - -module type FUNCTOR = sig - type +'a t - val map : ('a -> 'b) -> 'a t -> 'b t -end - -module type APPLICATIVE = sig - type +'a t - include FUNCTOR with type 'a t := 'a t - val pure : 'a -> 'a t - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t -end - -module type MONAD_BARE = sig - type +'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module type MONAD = sig - include MONAD_BARE - include APPLICATIVE with type 'a t := 'a t -end - -module type MONAD_TRANSFORMER = sig - include MONAD - module M : MONAD - val lift : 'a M.t -> 'a t -end - -type 'a sequence = ('a -> unit) -> unit - -module type FOLDABLE = sig - type 'a t - val to_seq : 'a t -> 'a sequence -end - -module type TRAVERSE = functor(M : MONAD) -> sig - type +'a t - - val sequence_m : 'a M.t t -> 'a t M.t - - val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t - - val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t -end - -module type FREE_MONAD = sig - module F : FUNCTOR - - type +'a t = - | Return of 'a - | Roll of 'a t F.t - - include MONAD with type 'a t := 'a t - val inj : 'a F.t -> 'a t -end - -(** {2 Some Implementations} *) - -module WrapMonad(M : MONAD_BARE) = struct - include M - - let map f x = x >>= (fun x -> return (f x)) - - let pure = return - - let (<*>) f x = f >>= fun f -> x >>= fun x -> return (f x) -end - - -module MakeFree(F : FUNCTOR) = struct - module F = F - - type 'a t = Return of 'a | Roll of ('a t F.t) - - let return x = Return x - let pure = return - - let rec map : type a b. (a -> b) -> a t -> b t - = fun f x -> match x with - | Return x -> Return (f x) - | Roll xs -> Roll (F.map (map f) xs) - - let rec _bind : type a b. (a -> b t) -> a t -> b t - = fun f x -> match x with - | Return x -> f x - | Roll y -> Roll (F.map (_bind f) y) - - let (>>=) x f = _bind f x - - let rec _app : type a b. (a -> b) t -> a t -> b t - = fun f x -> match f, x with - | Return f, Return x -> Return (f x) - | Return f, Roll xs -> Roll (F.map (map f) xs) - | Roll fs, _ -> Roll (F.map (fun f -> _app f x) fs) - - let (<*>) = _app - - let inj x = Roll (F.map return x) -end - -module MakeFreeFold(FM : FREE_MONAD)(Fold : FOLDABLE with type 'a t = 'a FM.F.t) = struct - type 'a t = 'a FM.t - - let rec to_seq : type a. a FM.t -> a sequence - = fun x k -> match x with - | FM.Return x -> k x - | FM.Roll xs -> Fold.to_seq xs (fun x -> to_seq x k) -end diff --git a/src/advanced/CCCat.mli b/src/advanced/CCCat.mli deleted file mode 100644 index bcb86c32..00000000 --- a/src/advanced/CCCat.mli +++ /dev/null @@ -1,113 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Categorical Constructs} - -Attempt to copy some structures from Haskell and the likes. Disclaimer: -I don't know much about category theory, only about type signatures ;). *) - -(** {2 Signatures} *) - -module type MONOID = sig - type t - val empty : t - val append : t -> t -> t -end - -module type FUNCTOR = sig - type +'a t - val map : ('a -> 'b) -> 'a t -> 'b t -end - -module type APPLICATIVE = sig - type +'a t - include FUNCTOR with type 'a t := 'a t - val pure : 'a -> 'a t - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t -end - -module type MONAD_BARE = sig - type +'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module type MONAD = sig - include MONAD_BARE - include APPLICATIVE with type 'a t := 'a t -end - -module type MONAD_TRANSFORMER = sig - include MONAD - module M : MONAD - val lift : 'a M.t -> 'a t -end - -(** Cheating: use an equivalent of "to List" with a sequence *) -type 'a sequence = ('a -> unit) -> unit - -module type FOLDABLE = sig - type 'a t - val to_seq : 'a t -> 'a sequence -end - -module type TRAVERSE = functor(M : MONAD) -> sig - type +'a t - - val sequence_m : 'a M.t t -> 'a t M.t - - val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t - - val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t -end - -(** The free monad is built by nesting applications of a functor [F]. - -For instance, Lisp-like nested lists can be built and dealt with like this: -{[ - module Lisp = CCCat.FreeMonad(CCList);; - - let l = Lisp.(inj [1;2;3] >>= fun x -> inj [x; x*2; x+100]);; -]} *) -module type FREE_MONAD = sig - module F : FUNCTOR - - type +'a t = - | Return of 'a - | Roll of 'a t F.t - - include MONAD with type 'a t := 'a t - val inj : 'a F.t -> 'a t -end - -(** {2 Some Implementations} *) - -(** Implement the applicative and functor modules from only return and bind *) -module WrapMonad(M : MONAD_BARE) : MONAD with type 'a t = 'a M.t - -module MakeFree(F : FUNCTOR) : FREE_MONAD with module F = F - -module MakeFreeFold(FM : FREE_MONAD)(Fold : FOLDABLE with type 'a t = 'a FM.F.t) - : FOLDABLE with type 'a t = 'a FM.t diff --git a/src/advanced/CCLinq.ml b/src/advanced/CCLinq.ml deleted file mode 100644 index 06d2fe0e..00000000 --- a/src/advanced/CCLinq.ml +++ /dev/null @@ -1,888 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 LINQ-like operations on collections} *) - -type 'a sequence = ('a -> unit) -> unit -type 'a equal = 'a -> 'a -> bool -type 'a ord = 'a -> 'a -> int -type 'a hash = 'a -> int -type 'a with_err = [`Ok of 'a | `Error of string ] - -let _id x = x - -exception ExitWithError of string -let _exit_with_error s = raise (ExitWithError s) -let _error_of_exn f = try `Ok (f ()) with ExitWithError s -> `Error s - -module PMap = struct - type ('a, 'b) t = { - is_empty : unit -> bool; - size : unit -> int; (* Number of keys *) - get : 'a -> 'b option; - fold : 'c. ('c -> 'a -> 'b -> 'c) -> 'c -> 'c; - to_seq : ('a * 'b) sequence; - } - - let get m x = m.get x - let mem m x = match m.get x with - | None -> false - | Some _ -> true - let to_seq m = m.to_seq - let fold f acc m = m.fold f acc - let size m = m.size () - - type ('a, 'b) build = { - mutable cur : ('a, 'b) t; - add : 'a -> 'b -> unit; - update : 'a -> ('b option -> 'b option) -> unit; - } - - let build_get b = b.cur - let add b x y = b.add x y - let update b f = b.update f - - (* careful to use this map linearly *) - let make_hash (type key) ?(eq=(=)) ?(hash=Hashtbl.hash) () = - let module H = Hashtbl.Make(struct - type t = key - let equal = eq - let hash = hash - end) in - (* build table *) - let tbl = H.create 32 in - let cur = { - is_empty = (fun () -> H.length tbl = 0); - size = (fun () -> H.length tbl); - get = (fun k -> - try Some (H.find tbl k) - with Not_found -> None); - fold = (fun f acc -> H.fold (fun k v acc -> f acc k v) tbl acc); - to_seq = (fun k -> H.iter (fun key v -> k (key,v)) tbl); - } in - { cur; - add = (fun k v -> H.replace tbl k v); - update = (fun k f -> - match (try f (Some (H.find tbl k)) with Not_found -> f None) with - | None -> H.remove tbl k - | Some v' -> H.replace tbl k v'); - } - - let make_cmp (type key) ?(cmp=Pervasives.compare) () = - let module M = Sequence.Map.Make(struct - type t = key - let compare = cmp - end) in - let map = ref M.empty in - let cur = { - is_empty = (fun () -> M.is_empty !map); - size = (fun () -> M.cardinal !map); - get = (fun k -> - try Some (M.find k !map) - with Not_found -> None); - fold = (fun f acc -> - M.fold - (fun key set acc -> f acc key set) !map acc - ); - to_seq = (fun k -> M.to_seq !map k); - } in - { - cur; - add = (fun k v -> map := M.add k v !map); - update = (fun k f -> - match (try f (Some (M.find k !map)) with Not_found -> f None) with - | None -> map := M.remove k !map - | Some v' -> map := M.add k v' !map); - } - - type 'a build_method = - | FromCmp of 'a ord - | FromHash of 'a equal * 'a hash - | Default - - let make ?(build=Default) () = match build with - | Default -> make_hash () - | FromCmp cmp -> make_cmp ~cmp () - | FromHash (eq,hash) -> make_hash ~eq ~hash () - - (* choose a build method from the optional arguments *) - let _make_build ?cmp ?eq ?hash () = - let _maybe default o = match o with - | Some x -> x - | None -> default - in - match eq, hash with - | Some _, _ - | _, Some _ -> - FromHash ( _maybe (=) eq, _maybe Hashtbl.hash hash) - | _ -> - match cmp with - | Some f -> FromCmp f - | _ -> Default - - let multimap_of_seq ?(build=make ()) seq = - seq (fun (k,v) -> - build.update k (function - | None -> Some [v] - | Some l -> Some (v::l))); - build.cur - - let count_of_seq ?(build=make ()) seq = - seq (fun x -> - build.update x - (function - | None -> Some 1 - | Some n -> Some (n+1))); - build.cur - - (* map values *) - let map f m = { - is_empty = m.is_empty; - size = m.size; - get = (fun k -> match m.get k with - | None -> None - | Some v -> Some (f v) - ); - to_seq = Sequence.map (fun (x,y) -> x, f y) m.to_seq; - fold = (fun f' acc -> - m.fold (fun acc x y -> f' acc x (f y)) acc - ); - } - - let to_list m = Sequence.to_rev_list m.to_seq - - let reverse_ ~build m = - let build = make ~build () in - let seq = Sequence.map (fun (x,y) -> y,x) (to_seq m) in - multimap_of_seq ~build seq - - let reverse_multimap_ ~build m = - let build = make ~build () in - let seq = to_seq m in - let seq = Sequence.flat_map - (fun (x,l) -> Sequence.map (fun y -> y,x) (Sequence.of_list l) - ) seq - in - multimap_of_seq ~build seq - - let reverse ?cmp ?eq ?hash () m = - let build = _make_build ?cmp ?eq ?hash () in - reverse_ ~build m - - let reverse_multimap ?cmp ?eq ?hash () m = - let build = _make_build ?cmp ?eq ?hash () in - reverse_multimap_ ~build m - - let fold_multimap f acc m = - m.fold (fun acc x l -> List.fold_left (fun acc y -> f acc x y) acc l) acc - - let get_seq key m = match get m key with - | None -> Sequence.empty - | Some x -> Sequence.return x - - let iter m = m.to_seq - - let flatten m = - let seq = Sequence.flat_map - (fun (k,v) -> Sequence.map (fun v' -> k,v') v) - m.to_seq - in - seq - - let flatten_l m = - let seq = Sequence.flatMap - (fun (k,v) -> Sequence.map (fun v' -> k,v') (Sequence.of_list v)) - m.to_seq - in - seq -end - -type 'a search_result = - | SearchContinue - | SearchStop of 'a - -type ('a,'b,'key,'c) join_descr = { - join_key1 : 'a -> 'key; - join_key2 : 'b -> 'key; - join_merge : 'key -> 'a -> 'b -> 'c option; - join_build : 'key PMap.build_method; -} - -type ('a,'b) group_join_descr = { - gjoin_proj : 'b -> 'a; - gjoin_build : 'a PMap.build_method; -} - -module ImplemSetOps = struct - let choose s = Sequence.take 1 s - - let distinct ~cmp s = Sequence.sort_uniq ~cmp s - - let search obj s = - match - Sequence.find - (fun x -> match obj#check x with - | SearchContinue -> None - | SearchStop y -> Some y - ) s - with None -> obj#failure - | Some x -> x - - let do_join ~join c1 c2 = - let build1 = - let seq = Sequence.map (fun x -> join.join_key1 x, x) c1 in - PMap.multimap_of_seq ~build:(PMap.make ~build:join.join_build ()) seq - in - let l = Sequence.fold - (fun acc y -> - let key = join.join_key2 y in - match PMap.get build1 key with - | None -> acc - | Some l1 -> - List.fold_left - (fun acc x -> match join.join_merge key x y with - | None -> acc - | Some res -> res::acc - ) acc l1 - ) [] c2 - in - Sequence.of_list l - - let do_group_join ~gjoin c1 c2 = - let build = PMap.make ~build:gjoin.gjoin_build () in - c1 (fun x -> PMap.add build x []); - c2 - (fun y -> - (* project [y] into some element of [c1] *) - let x = gjoin.gjoin_proj y in - PMap.update build x - (function - | None -> None (* [x] not present, ignore! *) - | Some l -> Some (y::l) - ) - ); - PMap.build_get build - - let do_union ~build c1 c2 = - let build = PMap.make ~build () in - c1 (fun x -> PMap.add build x ()); - c2 (fun x -> PMap.add build x ()); - let seq = PMap.to_seq (PMap.build_get build) in - Sequence.map fst seq - - type inter_status = - | InterLeft - | InterDone (* already output *) - - let do_inter ~build c1 c2 = - let build = PMap.make ~build () in - let l = ref [] in - c1 (fun x -> PMap.add build x InterLeft); - c2 (fun x -> - PMap.update build x - (function - | None -> Some InterDone - | Some InterDone as foo -> foo - | Some InterLeft -> - l := x :: !l; - Some InterDone - ) - ); - Sequence.of_list !l - - let do_diff ~build c1 c2 = - let build = PMap.make ~build () in - c2 (fun x -> PMap.add build x ()); - let map = PMap.build_get build in - (* output elements of [c1] not in [map] *) - Sequence.filter (fun x -> not (PMap.mem map x)) c1 -end - -(** {2 Query operators} *) - -type (_, _) unary = - | Map : ('a -> 'b) -> ('a, 'b ) unary - | Filter : ('a -> bool) -> ('a, 'a ) unary - | Fold : ('b -> 'a -> 'b) * 'b -> ('a, 'b) unary - | Reduce : ('a -> 'b) * ('a -> 'b -> 'b) * ('b -> 'c) - -> ('a, 'c) unary - | Size : ('a, int) unary - | Choose : ('a, 'a) unary - | FilterMap : ('a -> 'b option) -> ('a, 'b) unary - | FlatMap : ('a -> 'b sequence) -> ('a, 'b) unary - | Take : int -> ('a, 'a) unary - | TakeWhile : ('a -> bool) -> ('a, 'a) unary - | Sort : 'a ord -> ('a, 'a) unary - | Distinct : 'a ord -> ('a, 'a) unary - | Search : - < check: ('a -> 'b search_result); - failure : 'b; - > -> ('a, 'b) unary - | Contains : 'a equal * 'a -> ('a, bool) unary - | GroupBy : 'b PMap.build_method * ('a -> 'b) - -> ('a, ('b,'a list) PMap.t) unary - | Count : 'a PMap.build_method -> ('a, ('a, int) PMap.t) unary - | Lazy : ('a lazy_t, 'a) unary - -type set_op = - | Union - | Inter - | Diff - -type (_, _, _) binary = - | App : ('a -> 'b, 'a, 'b) binary - | Join : ('a, 'b, 'key, 'c) join_descr - -> ('a, 'b, 'c) binary - | GroupJoin : ('a, 'b) group_join_descr - -> ('a, 'b, ('a, 'b list) PMap.t) binary - | Product : ('a, 'b, ('a*'b)) binary - | Append : ('a, 'a, 'a) binary - | SetOp : set_op * 'a PMap.build_method - -> ('a, 'a, 'a) binary - -(* type of queries that return a 'a *) -and 'a t = - | Return : 'a -> 'a t - | OfSeq : 'a sequence -> 'a t - | Unary : ('a, 'b) unary * 'a t -> 'b t - | Binary : ('a, 'b, 'c) binary * 'a t * 'b t -> 'c t - | Bind : ('a -> 'b t) * 'a t -> 'b t - | Reflect : 'a t -> 'a sequence t - -let start x = Return x - -let of_list l = - OfSeq (Sequence.of_list l) - -let of_array a = - OfSeq (Sequence.of_array a) - -let of_array_i a = - OfSeq (Sequence.of_array_i a) - -let of_hashtbl h = - OfSeq (Sequence.of_hashtbl h) - -let range i j = OfSeq (Sequence.int_range ~start:i ~stop:j) - -let (--) = range - -let of_seq seq = - OfSeq seq - -let of_queue q = - OfSeq (Sequence.of_queue q) - -let of_stack s = - OfSeq (Sequence.of_stack s) - -let of_string s = - OfSeq (Sequence.of_str s) - -(** {6 Execution} *) - -let rec _optimize : type a. a t -> a t - = fun q -> match q with - | Return _ -> q - | Unary (u, q) -> - _optimize_unary u (_optimize q) - | Binary (b, q1, q2) -> - _optimize_binary b (_optimize q1) (_optimize q2) - | Reflect q -> Reflect (_optimize q) - | OfSeq _ -> q - | Bind (f,q) -> Bind(f, _optimize q) (* cannot optimize [f] before execution *) -and _optimize_unary : type a b. (a,b) unary -> a t -> b t - = fun u q -> match u, q with - | Size, Unary (Choose, _) -> Return 1 - | Map f, Unary (Map g, q') -> - _optimize_unary (Map (fun x -> f (g x))) q' - | Filter p, Unary (Map f, cont) -> - _optimize_unary - (FilterMap (fun x -> let y = f x in if p y then Some y else None)) - cont - | Filter p, Unary (Filter p', q) -> - _optimize_unary (Filter (fun x -> p x && p' x)) q - | FilterMap f, Unary (Map g, q') -> - _optimize_unary (FilterMap (fun x -> f (g x))) q' - | Map f, Unary (Filter p, cont) -> - _optimize_unary - (FilterMap (fun x -> if p x then Some (f x) else None)) - cont - | Map _, Binary (Append, q1, q2) -> - _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) - | Filter _, Binary (Append, q1, q2) -> - _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) - | Fold (f,acc), Unary (Map f', cont) -> - _optimize_unary - (Fold ((fun acc x -> f acc (f' x)), acc)) - cont - | Reduce (start, mix, stop), Unary (Map f, cont) -> - _optimize_unary - (Reduce ( - (fun x -> start (f x)), - (fun x acc -> mix (f x) acc), - stop)) - cont - | Size, Unary (Map _, cont) -> - _optimize_unary Size cont (* ignore the map! *) - | Size, Unary (Sort _, cont) -> - _optimize_unary Size cont - | _ -> Unary (u, _optimize q) - (* TODO: other cases *) -and _optimize_binary : type a b c. (a,b,c) binary -> a t -> b t -> c t - = fun b q1 q2 -> match b, q1, q2 with - | App, Return f, Return x -> Return (f x) - | App, Return f, x -> _optimize_unary (Map f) x - | App, f, Return x -> _optimize_unary (Map (fun f -> f x)) f - | App, _, _ -> Binary (b, _optimize q1, _optimize q2) - | Join _, _, _ -> Binary (b, _optimize q1, _optimize q2) - | GroupJoin _, _, _ -> Binary (b, _optimize q1, _optimize q2) - | Product, _, _ -> Binary (b, _optimize q1, _optimize q2) - | Append, _, _ -> Binary (b, _optimize q1, _optimize q2) - | SetOp _, _, _ -> Binary (b, _optimize q1, _optimize q2) - -(* apply a unary operator on a collection *) -let _do_unary : type a b. (a,b) unary -> a sequence -> b sequence -= fun u c -> match u with - | Map f -> Sequence.map f c - | Filter p -> Sequence.filter p c - | Fold (f, acc) -> Sequence.return (Sequence.fold f acc c) - | Reduce (start, mix, stop) -> - let acc = Sequence.fold - (fun acc x -> match acc with - | None -> Some (start x) - | Some acc -> Some (mix x acc) - ) None c - in - begin match acc with - | None -> Sequence.empty - | Some x -> Sequence.return (stop x) - end - | Size -> Sequence.return (Sequence.length c) - | Choose -> ImplemSetOps.choose c - | FilterMap f -> Sequence.filter_map f c - | FlatMap f -> Sequence.flat_map f c - | Take n -> Sequence.take n c - | TakeWhile p -> Sequence.take_while p c - | Sort cmp -> Sequence.sort ~cmp c - | Distinct cmp -> ImplemSetOps.distinct ~cmp c - | Search obj -> Sequence.return (ImplemSetOps.search obj c) - | GroupBy (build,f) -> - let seq = Sequence.map (fun x -> f x, x) c in - Sequence.return (PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq) - | Contains (eq, x) -> Sequence.return (Sequence.mem ~eq x c) - | Count build -> - Sequence.return (PMap.count_of_seq ~build:(PMap.make ~build ()) c) - | Lazy -> Sequence.map Lazy.force c - -let _do_binary : type a b c. (a, b, c) binary -> a sequence -> b sequence -> c sequence -= fun b c1 c2 -> match b with - | Join join -> ImplemSetOps.do_join ~join c1 c2 - | GroupJoin gjoin -> Sequence.return (ImplemSetOps.do_group_join ~gjoin c1 c2) - | Product -> Sequence.product c1 c2 - | Append -> Sequence.append c1 c2 - | App -> Sequence.(c1 <*> c2) - | SetOp (Inter,build) -> ImplemSetOps.do_inter ~build c1 c2 - | SetOp (Union,build) -> ImplemSetOps.do_union ~build c1 c2 - | SetOp (Diff,build) -> ImplemSetOps.do_diff ~build c1 c2 - -let rec _run : type a. opt:bool -> a t -> a sequence -= fun ~opt q -> match q with - | Return c -> Sequence.return c - | Unary (u, q') -> _do_unary u (_run ~opt q') - | Binary (b, q1, q2) -> _do_binary b (_run ~opt q1) (_run ~opt q2) - | OfSeq s -> s - | Bind (f, q') -> - let seq = _run ~opt q' in - Sequence.flat_map - (fun x -> - let q'' = f x in - let q'' = if opt then _optimize q'' else q'' in - _run ~opt q'' - ) seq - | Reflect q -> - let seq = Sequence.persistent_lazy (_run ~opt q) in - Sequence.return seq - -let _apply_limit ?limit seq = match limit with - | None -> seq - | Some l -> Sequence.take l seq - -(* safe execution *) -let run ?limit q = - let seq = _run ~opt:true (_optimize q) in - _apply_limit ?limit seq - -let run_no_optim ?limit q = - let seq = _run ~opt:false q in - _apply_limit ?limit seq - -let run1 q = - let seq = _run ~opt:true (_optimize q) in - match Sequence.head seq with - | Some x -> x - | None -> raise Not_found - -(** {6 Basics} *) - -let empty = OfSeq Sequence.empty - -let map f q = Unary (Map f, q) - -let (>|=) q f = Unary (Map f, q) - -let filter p q = Unary (Filter p, q) - -let choose q = Unary (Choose, q) - -let filter_map f q = Unary (FilterMap f, q) - -let flat_map f q = Unary (FlatMap f, q) - -let flat_map_l f q = - let f' x = Sequence.of_list (f x) in - Unary (FlatMap f', q) - -let flatten_seq q = Unary (FlatMap (fun x->x), q) - -let flatten q = Unary (FlatMap Sequence.of_list, q) - -let take n q = Unary (Take n, q) - -let take_while p q = Unary (TakeWhile p, q) - -let sort ?(cmp=Pervasives.compare) () q = Unary (Sort cmp, q) - -let distinct ?(cmp=Pervasives.compare) () q = - Unary (Distinct cmp, q) - -let group_by ?cmp ?eq ?hash f q = - Unary (GroupBy (PMap._make_build ?cmp ?eq ?hash (),f), q) - -let group_by' ?cmp ?eq ?hash f q = - flat_map PMap.iter (group_by ?cmp ?eq ?hash f q) - -let count ?cmp ?eq ?hash () q = - Unary (Count (PMap._make_build ?cmp ?eq ?hash ()), q) - -let count' ?cmp () q = - flat_map PMap.iter (count ?cmp () q) - -let fold f acc q = - Unary (Fold (f, acc), q) - -let size q = Unary (Size, q) - -let sum q = Unary (Fold ((+), 0), q) - -let reduce start mix stop q = - Unary (Reduce (start,mix,stop), q) - -let _avg_start x = (x,1) -let _avg_mix x (y,n) = (x+y,n+1) -let _avg_stop (x,n) = x/n - -let _lift_some f x y = match y with - | None -> Some x - | Some y -> Some (f x y) - -let max q = Unary (Reduce (_id, Pervasives.max, _id), q) -let min q = Unary (Reduce (_id, Pervasives.min, _id), q) -let average q = Unary (Reduce (_avg_start, _avg_mix, _avg_stop), q) - -let is_empty q = - Unary (Search (object - method check _ = SearchStop false (* stop in case there is an element *) - method failure = true - end), q) - -let contains ?(eq=(=)) x q = - Unary (Contains (eq, x), q) - -let for_all p q = - Unary (Search (object - method check x = if p x then SearchContinue else SearchStop false - method failure = true - end), q) - -let exists p q = - Unary (Search (object - method check x = if p x then SearchStop true else SearchContinue - method failure = false - end), q) - -let find p q = - Unary (Search (object - method check x = if p x then SearchStop (Some x) else SearchContinue - method failure = None - end), q) - -let find_map f q = - Unary (Search (object - method check x = match f x with - | Some y -> SearchStop (Some y) - | None -> SearchContinue - method failure = None - end), q) - -(** {6 Binary Operators} *) - -let join ?cmp ?eq ?hash join_key1 join_key2 ~merge q1 q2 = - let join_build = PMap._make_build ?eq ?hash ?cmp () in - let j = { - join_key1; - join_key2; - join_merge=merge; - join_build; - } in - Binary (Join j, q1, q2) - -let group_join ?cmp ?eq ?hash gjoin_proj q1 q2 = - let gjoin_build = PMap._make_build ?eq ?hash ?cmp () in - let j = { - gjoin_proj; - gjoin_build; - } in - Binary (GroupJoin j, q1, q2) - -let product q1 q2 = Binary (Product, q1, q2) - -let append q1 q2 = Binary (Append, q1, q2) - -let inter ?cmp ?eq ?hash () q1 q2 = - let build = PMap._make_build ?cmp ?eq ?hash () in - Binary (SetOp (Inter, build), q1, q2) - -let union ?cmp ?eq ?hash () q1 q2 = - let build = PMap._make_build ?cmp ?eq ?hash () in - Binary (SetOp (Union, build), q1, q2) - -let diff ?cmp ?eq ?hash () q1 q2 = - let build = PMap._make_build ?cmp ?eq ?hash () in - Binary (SetOp (Diff, build), q1, q2) - -let fst q = map fst q -let snd q = map snd q - -let map1 f q = map (fun (x,y) -> f x, y) q -let map2 f q = map (fun (x,y) -> x, f y) q - -let flatten_opt q = filter_map _id q - -let opt_unwrap q = - Unary - (Map - (function - | Some x -> x - | None -> _exit_with_error "opt_unwrap"), - q - ) - -(** {6 Applicative} *) - -let pure x = Return x - -let app f x = Binary (App, f, x) - -let (<*>) = app - -(** {6 Monadic stuff} *) - -let return x = Return x - -let bind f q = Bind (f,q) - -let (>>=) x f = Bind (f, x) - -(** {6 Misc} *) - -let lazy_ q = Unary (Lazy, q) - -let reflect q = Reflect q - -(** {6 Infix} *) - -module Infix = struct - let (>>=) = (>>=) - let (>|=) = (>|=) - let (<*>) = (<*>) - let (--) = (--) -end - -(** {6 Adapters} *) - -let to_seq q = reflect q - -let to_hashtbl q = - Unary (Map (fun c -> Sequence.to_hashtbl c), Reflect q) - -let to_queue q = - Unary (Map (fun c -> let q = Queue.create() in Sequence.to_queue q c; q), Reflect q) - -let to_stack q = - Unary (Map (fun c -> let s = Stack.create () in Sequence.to_stack s c; s), Reflect q) - -module List = struct - let of_list l = OfSeq (Sequence.of_list l) - let to_list q = map Sequence.to_list (Reflect q) - let run q = run1 (to_list q) -end - -module Array = struct - let of_array a = OfSeq (Sequence.of_array a) - let to_array q = - map (fun s -> Array.of_list (Sequence.to_list s)) (Reflect q) - let run q = run1 (to_array q) -end - -module AdaptSet(S : Set.S) = struct - let of_set set = OfSeq (fun k -> S.iter k set) - - let to_set q = - let f c = Sequence.fold (fun set x -> S.add x set) S.empty c in - map f (reflect q) - - let run q = run1 (to_set q) -end - -module AdaptMap(M : Map.S) = struct - let _to_seq m k = M.iter (fun x y -> k (x,y)) m - - let of_map map = OfSeq (_to_seq map) - - let to_pmap m = { - PMap.get = (fun x -> try Some (M.find x m) with Not_found -> None); - PMap.size = (fun () -> M.cardinal m); - PMap.is_empty = (fun () -> M.is_empty m); - PMap.fold = (fun f acc -> M.fold (fun x y acc -> f acc x y) m acc); - PMap.to_seq = _to_seq m; - } - - let to_map q = - let f c = - Sequence.fold (fun m (x,y) -> M.add x y m) M.empty c - in - map f (reflect q) - - let run q = run1 (to_map q) -end - -module IO = struct - let _slurp with_input = - let l = lazy (with_input (fun ic -> CCIO.read_all ic)) in - lazy_ (return l) - - let slurp ic = _slurp (fun f -> f ic) - - let _with_file_in filename f = - try - let ic = open_in filename in - try - let x = f ic in - close_in ic; - x - with e -> - close_in ic; - _exit_with_error (Printexc.to_string e) - with e -> - _exit_with_error (Printexc.to_string e) - - let _with_file_out filename f = - try - let oc = open_out filename in - try - let x = f oc in - close_out oc; - x - with e -> - close_out oc; - _exit_with_error (Printexc.to_string e) - with e -> - _exit_with_error (Printexc.to_string e) - - let slurp_file filename = _slurp (_with_file_in filename) - - (* find [c] in [s], starting at offset [i] *) - let rec _find s c i = - if i >= String.length s then None - else if s.[i] = c then Some i - else _find s c (i+1) - - let rec _lines s i k = match _find s '\n' i with - | None -> - if i - let s' = String.sub s i (j-i) in - k s'; - _lines s (j+1) k - - let lines q = - (* sequence of lines *) - let f s = _lines s 0 in - flat_map f q - - let lines' q = - let f s = lazy (Sequence.to_list (_lines s 0)) in - lazy_ (map f q) - - let _join ~sep ?(stop="") seq = - let buf = Buffer.create 128 in - Sequence.iteri - (fun i x -> - if i>0 then Buffer.add_string buf sep; - Buffer.add_string buf x) - seq; - Buffer.add_string buf stop; - Buffer.contents buf - - let unlines q = - let f l = lazy (_join ~sep:"\n" ~stop:"\n" l) in - lazy_ (map f (reflect q)) - - let join sep q = - let f l = lazy (_join ~sep l) in - lazy_ (map f (reflect q)) - - let out oc q = - output_string oc (run1 q) - - let out_lines oc q = - let x = run q in - Sequence.iter (fun l -> output_string oc l; output_char oc '\n') x - - let to_file_exn filename q = - _with_file_out filename (fun oc -> out oc q) - - let to_file filename q = - try `Ok (_with_file_out filename (fun oc -> out oc q)) - with Failure s -> `Error s - - let to_file_lines_exn filename q = - _with_file_out filename (fun oc -> out_lines oc q) - - let to_file_lines filename q = - try `Ok (_with_file_out filename (fun oc -> out_lines oc q)) - with Failure s -> `Error s -end diff --git a/src/advanced/CCLinq.mli b/src/advanced/CCLinq.mli deleted file mode 100644 index 02136979..00000000 --- a/src/advanced/CCLinq.mli +++ /dev/null @@ -1,424 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 LINQ-like operations on collections} - -The purpose is to provide powerful combinators to express iteration, -transformation and combination of collections of items. This module depends -on several other modules, including {!CCList} and {!CCSequence}. - -Functions and operations are assumed to be referentially transparent, i.e. -they should not rely on external side effects, they should not rely on -the order of execution. - -@deprecated use {{: https://github.com/c-cube/olinq} OLinq} - -{[ - -CCLinq.( - of_list [1;2;3] - |> flat_map (fun x -> Sequence.(x -- (x+10))) - |> sort () - |> count () - |> flat_map PMap.to_seq - |> List.run -);; -- : (int * int) list = [(13, 1); (12, 2); (11, 3); (10, 3); (9, 3); - (8, 3); (7, 3); (6, 3); (5, 3); (4, 3); (3, 3); (2, 2); (1, 1)] - - -CCLinq.( - IO.slurp_file "/tmp/foo" - |> IO.lines - |> sort () - |> IO.to_file_lines "/tmp/bar" -);; -- : `Ok () -]} - -{b DEPRECATED, use "OLinq" (standalone library) instead} - -{b status: deprecated} - -*) - -type 'a sequence = ('a -> unit) -> unit -type 'a equal = 'a -> 'a -> bool -type 'a ord = 'a -> 'a -> int -type 'a hash = 'a -> int -type 'a with_err = [`Ok of 'a | `Error of string ] - -(** {2 Polymorphic Maps} *) -module PMap : sig - type ('a, 'b) t - - val get : ('a,'b) t -> 'a -> 'b option - - val size : (_,_) t -> int - - val to_seq : ('a, 'b) t -> ('a * 'b) sequence - - val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t - (** Transform values *) - - val to_list : ('a,'b) t -> ('a*'b) list - - val reverse : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> - ('a,'b) t -> ('b,'a list) t - (** Reverse relation of the map, as a multimap *) - - val reverse_multimap : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> unit -> - ('a,'b list) t -> ('b,'a list) t - (** Reverse relation of the multimap *) - - val fold : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> ('a,'b) t -> 'acc - (** Fold on the items of the map *) - - val fold_multimap : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> - ('a,'b list) t -> 'acc - (** Fold on the items of the multimap *) - - val get_seq : 'a -> ('a, 'b) t -> 'b sequence - (** Select a key from a map and wrap into sequence *) - - val iter : ('a,'b) t -> ('a*'b) sequence - (** View a multimap as a proper collection *) - - val flatten : ('a,'b sequence) t -> ('a*'b) sequence - (** View a multimap as a collection of individual key/value pairs *) - - val flatten_l : ('a,'b list) t -> ('a*'b) sequence - (** View a multimap as a list of individual key/value pairs *) -end - -(** {2 Query operators} *) - -type 'a t -(** Type of a query that returns zero, one or more values of type 'a *) - -(** {6 Initial values} *) - -val empty : 'a t -(** Empty collection *) - -val start : 'a -> 'a t -(** Start with a single value - @deprecated since 0.13, use {!return} instead *) - -val return : 'a -> 'a t -(** Return one value *) - -val of_list : 'a list -> 'a t -(** Query that just returns the elements of the list *) - -val of_array : 'a array -> 'a t -val of_array_i : 'a array -> (int * 'a) t - -val range : int -> int -> int t -(** [range i j] goes from [i] up to [j] included *) - -val (--) : int -> int -> int t -(** Synonym to {!range} *) - -val of_hashtbl : ('a,'b) Hashtbl.t -> ('a * 'b) t - -val of_seq : 'a sequence -> 'a t -(** Query that returns the elements of the given sequence. *) - -val of_queue : 'a Queue.t -> 'a t - -val of_stack : 'a Stack.t -> 'a t - -val of_string : string -> char t -(** Traverse the characters of the string *) - -(** {6 Execution} *) - -val run : ?limit:int -> 'a t -> 'a sequence -(** Execute the query, possibly returning an error if things go wrong - @param limit max number of values to return *) - -val run1 : 'a t -> 'a -(** Run the query and return the first value - @raise Not_found if the query succeeds with 0 element *) - -val run_no_optim : ?limit:int -> 'a t -> 'a sequence -(** Run without any optimization *) - -(** {6 Basics} *) - -val map : ('a -> 'b) -> 'a t -> 'b t -(** Map each value *) - -val (>|=) : 'a t -> ('a -> 'b) -> 'b t -(** Infix synonym of {!map} *) - -val filter : ('a -> bool) -> 'a t -> 'a t -(** Filter out values that do not satisfy predicate *) - -val size : _ t -> int t -(** [size t] returns one value, the number of items returned by [t] *) - -val choose : 'a t -> 'a t -(** Choose one element (if any, otherwise empty) in the collection. - This is like a "cut" in prolog. *) - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t -(** Filter and map elements at once *) - -val flat_map : ('a -> 'b sequence) -> 'a t -> 'b t -(** Same as {!flat_map} but using sequences *) - -val flat_map_l : ('a -> 'b list) -> 'a t -> 'b t -(** map each element to a collection and flatten the result *) - -val flatten : 'a list t -> 'a t - -val flatten_seq : 'a sequence t -> 'a t - -val take : int -> 'a t -> 'a t -(** Take at most [n] elements *) - -val take_while : ('a -> bool) -> 'a t -> 'a t -(** Take elements while they satisfy a predicate *) - -val sort : ?cmp:'a ord -> unit -> 'a t -> 'a t -(** Sort items by the given comparison function *) - -val distinct : ?cmp:'a ord -> unit -> 'a t -> 'a t -(** Remove duplicate elements from the input collection. - All elements in the result are distinct. *) - -(** {6 Aggregation} *) - -val group_by : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> - ('a -> 'b) -> 'a t -> ('b,'a list) PMap.t t -(** [group_by f] takes a collection [c] as input, and returns - a multimap [m] such that for each [x] in [c], - [x] occurs in [m] under the key [f x]. In other words, [f] is used - to obtain a key from [x], and [x] is added to the multimap using this key. *) - -val group_by' : ?cmp:'b ord -> ?eq:'b equal -> ?hash:'b hash -> - ('a -> 'b) -> 'a t -> ('b * 'a list) t - -val count : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> - unit -> 'a t -> ('a, int) PMap.t t -(** [count c] returns a map from elements of [c] to the number - of time those elements occur. *) - -val count' : ?cmp:'a ord -> unit -> 'a t -> ('a * int) t - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t -(** Fold over the collection *) - -val reduce : ('a -> 'b) -> ('a -> 'b -> 'b) -> ('b -> 'c) -> - 'a t -> 'c t -(** [reduce start mix stop q] uses [start] on the first element of [q], - and combine the result with following elements using [mix]. The final - value is transformed using [stop]. *) - -val is_empty : 'a t -> bool t - -val sum : int t -> int t - -val contains : ?eq:'a equal -> 'a -> 'a t -> bool t - -val average : int t -> int t -val max : int t -> int t -val min : int t -> int t - -val for_all : ('a -> bool) -> 'a t -> bool t -val exists : ('a -> bool) -> 'a t -> bool t -val find : ('a -> bool) -> 'a t -> 'a option t -val find_map : ('a -> 'b option) -> 'a t -> 'b option t - -(** {6 Binary Operators} *) - -val join : ?cmp:'key ord -> ?eq:'key equal -> ?hash:'key hash -> - ('a -> 'key) -> ('b -> 'key) -> - merge:('key -> 'a -> 'b -> 'c option) -> - 'a t -> 'b t -> 'c t -(** [join key1 key2 ~merge] is a binary operation - that takes two collections [a] and [b], projects their - elements resp. with [key1] and [key2], and combine - values [(x,y)] from [(a,b)] with the same [key] - using [merge]. If [merge] returns [None], the combination - of values is discarded. *) - -val group_join : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> - ('b -> 'a) -> 'a t -> 'b t -> - ('a, 'b list) PMap.t t -(** [group_join key2] associates to every element [x] of - the first collection, all the elements [y] of the second - collection such that [eq x (key y)] *) - -val product : 'a t -> 'b t -> ('a * 'b) t -(** Cartesian product *) - -val append : 'a t -> 'a t -> 'a t -(** Append two collections together *) - -val inter : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a t -> 'a t -> 'a t -(** Intersection of two collections. Each element will occur at most once - in the result *) - -val union : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a t -> 'a t -> 'a t -(** Union of two collections. Each element will occur at most once - in the result *) - -val diff : ?cmp:'a ord -> ?eq:'a equal -> ?hash:'a hash -> unit -> - 'a t -> 'a t -> 'a t -(** Set difference *) - -(** {6 Tuple and Options} *) - -(** Specialized projection operators *) - -val fst : ('a * 'b) t -> 'a t - -val snd : ('a * 'b) t -> 'b t - -val map1 : ('a -> 'b) -> ('a * 'c) t -> ('b * 'c) t - -val map2 : ('a -> 'b) -> ('c * 'a) t -> ('c * 'b) t - -val flatten_opt : 'a option t -> 'a t -(** Flatten the collection by removing options *) - -(** {6 Applicative} *) - -val pure : 'a -> 'a t -(** Synonym to {!return} *) - -val app : ('a -> 'b) t -> 'a t -> 'b t -(** Apply each function to each value *) - -val (<*>) : ('a -> 'b) t -> 'a t -> 'b t -(** Infix synonym to {!app} *) - -(** {6 Monad} - -Careful, those operators do not allow any optimization before running the -query, they might therefore be pretty slow. *) - -val bind : ('a -> 'b t) -> 'a t -> 'b t -(** Use the result of a query to build another query and immediately run it. *) - -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -(** Infix version of {!bind} *) - -(** {6 Misc} *) - -val lazy_ : 'a lazy_t t -> 'a t - -val opt_unwrap : 'a option t -> 'a t - -val reflect : 'a t -> 'a sequence t -(** [reflect q] evaluates all values in [q] and returns a sequence - of all those values. Also blocks optimizations *) - -(** {6 Infix} *) - -module Infix : sig - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - val (--) : int -> int -> int t -end - -(** {6 Adapters} *) - -val to_seq : 'a t -> 'a sequence t -(** Build a (re-usable) sequence of elements, which can then be - converted into other structures *) - -val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t t -(** Build a hashtable from the collection *) - -val to_queue : 'a t -> 'a Queue.t t - -val to_stack : 'a t -> 'a Stack.t t - -module List : sig - val of_list : 'a list -> 'a t - val to_list : 'a t -> 'a list t - val run : 'a t -> 'a list -end - -module Array : sig - val of_array : 'a array -> 'a t - val to_array : 'a t -> 'a array t - val run : 'a t -> 'a array -end - -module AdaptSet(S : Set.S) : sig - val of_set : S.t -> S.elt t - val to_set : S.elt t -> S.t t - val run : S.elt t -> S.t -end - -module AdaptMap(M : Map.S) : sig - val of_map : 'a M.t -> (M.key * 'a) t - val to_pmap : 'a M.t -> (M.key, 'a) PMap.t - val to_map : (M.key * 'a) t -> 'a M.t t - val run : (M.key * 'a) t -> 'a M.t -end - -module IO : sig - val slurp : in_channel -> string t - (** Slurp the whole channel in (blocking), returning the - corresponding string. The channel will be read at most once - during execution, and its content cached; however the channel - might never get read because evaluation is lazy. *) - - val slurp_file : string -> string t - (** Read a whole file (given by name) and return its content as - a string *) - - val lines : string t -> string t - (** Convert a string into a collection of lines *) - - val lines' : string t -> string list t - (** Convert a string into a list of lines *) - - val join : string -> string t -> string t - - val unlines : string t -> string t - (** Join lines together *) - - val out : out_channel -> string t -> unit - val out_lines : out_channel -> string t -> unit - (** Evaluate the query and print it line by line on the output *) - - (** {8 Run methods} *) - - val to_file : string -> string t -> unit with_err - val to_file_exn : string -> string t -> unit - - val to_file_lines : string -> string t -> unit with_err - val to_file_lines_exn : string -> string t -> unit -end diff --git a/src/advanced/CCMonadIO.cppo.ml b/src/advanced/CCMonadIO.cppo.ml deleted file mode 100644 index 109cf716..00000000 --- a/src/advanced/CCMonadIO.cppo.ml +++ /dev/null @@ -1,519 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 IO Monad} *) - -type _ t = - | Return : 'a -> 'a t - | Fail : string -> 'a t - | Map : ('a -> 'b) * 'a t -> 'b t - | Bind : ('a -> 'b t) * 'a t -> 'b t - | WithGuard: unit t * 'a t -> 'a t (* run guard in any case *) - | Star : ('a -> 'b) t * 'a t -> 'b t - | Repeat : int * 'a t -> 'a list t - | RepeatIgnore : int * 'a t -> unit t - | Wrap : (unit -> 'a) -> 'a t - | SequenceMap : ('a -> 'b t) * 'a list -> 'b list t - -type 'a io = 'a t -type 'a with_finalizer = ('a t * unit t) t -type 'a or_error = [ `Ok of 'a | `Error of string ] - -let (>>=) x f = Bind(f,x) - -let bind ?finalize f a = match finalize with - | None -> Bind(f,a) - | Some b -> WithGuard (b, Bind (f,a)) - -let map f x = Map(f, x) - -let (>|=) x f = Map(f, x) - -let return x = Return x -let pure = return - -let fail msg = Fail msg - -let (<*>) f a = Star (f, a) - -let lift = map - -let lift2 f a b = - a >>= fun x -> map (f x) b - -let lift3 f a b c = - a >>= fun x -> - b >>= fun y -> map (f x y) c - -let sequence_map f l = - SequenceMap (f,l) - -let sequence l = - let _id x = x in - SequenceMap(_id, l) - -let repeat i a = - if i <= 0 then Return [] else Repeat (i,a) - -let repeat' i a = - if i <= 0 then Return () else RepeatIgnore (i,a) - -(** {2 Finalizers} *) - -let (>>>=) a f = - a >>= function - | x, finalizer -> WithGuard (finalizer, x >>= f) - -(** {2 Running} *) - -exception IOFailure of string - -let rec _run : type a. a t -> a = function - | Return x -> x - | Fail msg -> raise (IOFailure msg) - | Map (f, a) -> f (_run a) - | Bind (f, a) -> _run (f (_run a)) - | WithGuard (g, a) -> - begin try - let res = _run a in - _run g; - res - with e -> - _run g; - raise e - end - | Star (f, a) -> _run f (_run a) - | Repeat (i,a) -> _repeat [] i a - | RepeatIgnore (i,a) -> _repeat_ignore i a - | Wrap f -> f() - | SequenceMap (f, l) -> _sequence_map f l [] -and _repeat : type a. a list -> int -> a t -> a list - = fun acc i a -> match i with - | 0 -> List.rev acc - | _ -> - let x = _run a in - _repeat (x::acc) (i-1) a -and _repeat_ignore : type a. int -> a t -> unit - = fun i a -> match i with - | 0 -> () - | _ -> - let _ = _run a in - _repeat_ignore (i-1) a -and _sequence_map : type a b. (a -> b t) -> a list -> b list -> b list - = fun f l acc -> match l with - | [] -> List.rev acc - | a::tail -> - let x = _run (f a) in - _sequence_map f tail (x::acc) - -let _printers = - ref [ - (* default printer *) - ( function IOFailure msg - | Sys_error msg -> Some msg - | Exit -> Some "exit" - | _ -> None - ) - ] - -exception PrinterResult of string - -let _print_exn e = - try - List.iter - (fun p -> match p e with - | None -> () - | Some msg -> raise (PrinterResult msg) - ) !_printers; - Printexc.to_string e - with PrinterResult s -> s - -let run x = - try `Ok (_run x) - with e -> `Error (_print_exn e) - -exception IO_error of string - -let run_exn x = - try _run x - with e -> raise (IO_error (_print_exn e)) - -let register_printer p = _printers := p :: !_printers - -(** {2 Standard Wrappers} *) - -let _open_in mode flags filename () = - open_in_gen flags mode filename -let _close_in ic () = close_in ic - -let with_in ?(mode=0o644) ?(flags=[]) filename = - Wrap (_open_in mode flags filename) - >>= fun ic -> - Return (Return ic, Wrap (_close_in ic)) - -let _read ic s i len () = input ic s i len -let read ic s i len = Wrap (_read ic s i len) - -let _read_line ic () = - try Some (Pervasives.input_line ic) - with End_of_file -> None -let read_line ic = Wrap(_read_line ic) - -let rec _read_lines ic acc = - read_line ic - >>= function - | None -> return (List.rev acc) - | Some l -> _read_lines ic (l::acc) - -let read_lines ic = _read_lines ic [] - -let read_all ic = Wrap(fun () -> CCIO.read_all ic) - -let _open_out mode flags filename () = - open_out_gen flags mode filename -let _close_out oc () = close_out oc - -let with_out ?(mode=0o644) ?(flags=[]) filename = - Wrap(_open_out mode (Open_wronly::flags) filename) - >>= fun oc -> - Return(Return oc, Wrap(_close_out oc)) - -let with_out_a ?mode ?(flags=[]) filename = - with_out ?mode ~flags:(Open_creat::Open_append::flags) filename - -#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2 - -let output_str_ = Pervasives.output_substring - -#else - -let output_str_ = Pervasives.output - -#endif - -let _write oc s i len () = output_str_ oc s i len -let write oc s i len = Wrap (_write oc s i len) - -let _write_str oc s () = output_str_ oc s 0 (String.length s) -let write_str oc s = Wrap (_write_str oc s) - -let _write_line oc l () = - output_string oc l; - output_char oc '\n' -let write_line oc l = Wrap (_write_line oc l) - -let _write_buf oc buf () = Buffer.output_buffer oc buf -let write_buf oc buf = Wrap (_write_buf oc buf) - -let flush oc = Wrap (fun () -> Pervasives.flush oc) - -(** {2 Seq} *) - -module Seq = struct - type 'a step_result = - | Yield of 'a - | Stop - - type 'a gen = unit -> 'a step_result io - - type 'a t = 'a gen - - let _stop () = return Stop - let _yield x = return (Yield x) - - let map_pure f gen () = - gen() >>= function - | Stop -> _stop () - | Yield x -> _yield (f x) - - let map f g () = - g() >>= function - | Stop -> _stop () - | Yield x -> f x >>= _yield - - let rec filter_map f g () = - g() >>= function - | Stop -> _stop() - | Yield x -> - match f x with - | None -> filter_map f g() - | Some y -> _yield y - - let rec filter f g () = - g() >>= function - | Stop -> _stop() - | Yield x -> - if f x then _yield x else filter f g() - - let rec flat_map f g () = - g() >>= function - | Stop -> _stop () - | Yield x -> - f x >>= fun g' -> _flat_map_aux f g g' () - and _flat_map_aux f g g' () = - g'() >>= function - | Stop -> flat_map f g () - | Yield x -> _yield x - - let general_iter f acc g = - let acc = ref acc in - let rec _next () = - g() >>= function - | Stop -> _stop() - | Yield x -> - f !acc x >>= function - | `Stop -> _stop() - | `Continue (acc', ret) -> - acc := acc'; - match ret with - | None -> _next() - | Some y -> _yield y - in - _next - - let take n seq = - general_iter - (fun n x -> if n<=0 - then return `Stop - else return (`Continue (n-1, Some x)) - ) n seq - - let drop n seq = - general_iter - (fun n x -> if n<=0 - then return (`Continue (n, Some x)) - else return (`Continue (n-1, None)) - ) n seq - - let take_while p seq = - general_iter - (fun () x -> - p x >|= function - | true -> `Continue ((), Some x) - | false -> `Stop - ) () seq - - let drop_while p seq = - general_iter - (fun dropping x -> - if dropping - then p x >|= function - | true -> `Continue (true, None) - | false -> `Continue (false, Some x) - else return (`Continue (false, Some x)) - ) true seq - - (* apply all actions from [l] to [x] *) - let rec _apply_all_to x l = match l with - | [] -> return () - | f::tail -> f x >>= fun () -> _apply_all_to x tail - - let _tee funs g () = - g() >>= function - | Stop -> _stop() - | Yield x -> - _apply_all_to x funs >>= fun () -> - _yield x - - let tee funs g = match funs with - | [] -> g - | _::_ -> _tee funs g - - (** {6 Consume} *) - - let rec fold_pure f acc g = - g() >>= function - | Stop -> return acc - | Yield x -> fold_pure f (f acc x) g - - let length g = fold_pure (fun acc _ -> acc+1) 0 g - - let rec fold f acc g = - g() >>= function - | Stop -> return acc - | Yield x -> - f acc x >>= fun acc' -> fold f acc' g - - let rec iter f g = - g() >>= function - | Stop -> return () - | Yield x -> f x >>= fun _ -> iter f g - - let of_fun g = g - - let empty () = _stop() - - let singleton x = - let first = ref true in - fun () -> - if !first then (first := false; _yield x) else _stop() - - let cons x g = - let first = ref true in - fun () -> - if !first then (first := false; _yield x) else g() - - let of_list l = - let l = ref l in - fun () -> match !l with - | [] -> _stop() - | x::tail -> l:= tail; _yield x - - let of_array a = - let i = ref 0 in - fun () -> - if !i = Array.length a - then _stop() - else ( - let x = a.(!i) in - incr i; - _yield x - ) - - (* TODO: wrapper around with_in? using bind ~finalize:... ? *) - - let chunks ~size ic = - let buf = Buffer.create size in - let eof = ref false in - let next() = - if !eof then _stop() - else try - Buffer.add_channel buf ic size; - let s = Buffer.contents buf in - Buffer.clear buf; - _yield s - with End_of_file -> - let s = Buffer.contents buf in - eof := true; - if s="" then _stop() else _yield s - in - next - - let lines ic () = - try _yield (input_line ic) - with End_of_file -> _stop() - - let words _g = - failwith "words: not implemented yet" - (* TODO: state machine that goes: - - 0: read input chunk - - switch to "search for ' '", and yield word - - goto 0 if no ' ' found - - yield leftover when g returns Stop - let buf = Buffer.create 32 in - let next() = - g() >>= function - | Stop -> _stop - | Yield s -> - Buffer.add_string buf s; - search_ - in - next - *) - - let output ?sep oc seq = - let first = ref true in - iter - (fun s -> - (* print separator *) - ( if !first - then (first:=false; return ()) - else match sep with - | None -> return () - | Some sep -> write_str oc sep - ) >>= fun () -> - write_str oc s - ) seq - >>= fun () -> flush oc -end - -(** {6 File and file names} *) - -module File = struct - type t = string - - let to_string f = f - - let make f = - if Filename.is_relative f - then Filename.concat (Sys.getcwd()) f - else f - - let exists f = Wrap (fun () -> Sys.file_exists f) - - let is_directory f = Wrap (fun () -> Sys.is_directory f) - - let remove f = Wrap (fun () -> Sys.remove f) - - let _read_dir d () = - if Sys.is_directory d - then - let arr = Sys.readdir d in - Seq.map_pure make (Seq.of_array arr) - else Seq.empty - - let rec _walk d () = - if Sys.is_directory d - then - let arr = Sys.readdir d in - let tail = Seq.of_array arr in - let tail = Seq.flat_map - (fun s -> return (_walk (Filename.concat d s) ())) - tail - in Seq.cons (`Dir,d) tail - else Seq.singleton (`File, d) - - let walk t = Wrap (_walk t) - - let read_dir ?(recurse=false) d = - if recurse - then walk d - >|= Seq.filter_map - (function - | `File, f -> Some f - | `Dir, _ -> None - ) - else Wrap (_read_dir d) - - let rec _read_dir_rec d () = - if Sys.is_directory d - then - let arr = Sys.readdir d in - let arr = Seq.of_array arr in - let arr = Seq.map_pure (fun s -> Filename.concat d s) arr in - Seq.flat_map - (fun s -> - if Sys.is_directory s - then return (_read_dir_rec s ()) - else return (Seq.singleton s) - ) arr - else Seq.empty -end - -(** {2 Raw} *) - -module Raw = struct - let wrap f = Wrap f -end diff --git a/src/advanced/CCMonadIO.mli b/src/advanced/CCMonadIO.mli deleted file mode 100644 index aac8cb4a..00000000 --- a/src/advanced/CCMonadIO.mli +++ /dev/null @@ -1,322 +0,0 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 IO Monad} - -A simple abstraction over blocking IO, with strict evaluation. This is in -no way an alternative to Lwt/Async if you need concurrency. - -@since 0.3.3 -*) - -(** -Examples: - -- obtain the list of lines of a file: - -{[ -let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);; -]} - -- transfer one file into another: - -{[ -# let a = CCIO.( - with_in "input" >>>= fun ic -> - with_out ~flags:[Open_creat] "output" >>>= fun oc -> - Seq.chunks 512 ic - |> Seq.output oc -) ;; - -# run a;; -]} -*) - -type 'a t -type 'a io = 'a t - -type 'a with_finalizer -(** A value of type ['a with_finalizer] is similar to a value ['a t] but - also contains a finalizer that must be run to cleanup. - See {!(>>>=)} to get rid of it. *) - -type 'a or_error = [ `Ok of 'a | `Error of string ] - -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -(** Wait for the result of an action, then use a function to build a - new action and execute it *) - -val return : 'a -> 'a t -(** Just return a value *) - -val repeat : int -> 'a t -> 'a list t -(** Repeat an IO action as many times as required *) - -val repeat' : int -> 'a t -> unit t -(** Same as {!repeat}, but ignores the result *) - -val map : ('a -> 'b) -> 'a t -> 'b t -(** Map values *) - -val (>|=) : 'a t -> ('a -> 'b) -> 'b t - -val bind : ?finalize:(unit t) -> ('a -> 'b t) -> 'a t -> 'b t -(** [bind f a] runs the action [a] and applies [f] to its result - to obtain a new action. It then behaves exactly like this new - action. - @param finalize an optional action that is always run after evaluating - the whole action *) - -val pure : 'a -> 'a t -val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - -val lift : ('a -> 'b) -> 'a t -> 'b t -(** Synonym to {!map} *) - -val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t -val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t - -val sequence : 'a t list -> 'a list t -(** Runs operations one by one and gather their results *) - -val sequence_map : ('a -> 'b t) -> 'a list -> 'b list t -(** Generalization of {!sequence} *) - -val fail : string -> 'a t -(** [fail msg] fails with the given message. Running the IO value will - return an [`Error] variant *) - -(** {2 Finalizers} *) - -val (>>>=) : 'a with_finalizer -> ('a -> 'b t) -> 'b t -(** Same as {!(>>=)}, but taking the finalizer into account. Once this - IO value is done executing, the finalizer is executed and the resource, - fred. *) - -(** {2 Running} *) - -val run : 'a t -> 'a or_error -(** Run an IO action. - @return either [`Ok x] when [x] is the successful result of the - computation, or some [`Error "message"] *) - -exception IO_error of string - -val run_exn : 'a t -> 'a -(** Unsafe version of {!run}. It assumes non-failure. - @raise IO_error if the execution didn't go well *) - -val register_printer : (exn -> string option) -> unit -(** [register_printer p] register [p] as a possible failure printer. - If [run a] raises an exception [e], [p e] is evaluated. If [p e = Some msg] - then the error message will be [msg], otherwise other printers will - be tried *) - -(** {2 Standard Wrappers} *) - -(** {6 Input} *) - -val with_in : ?mode:int -> ?flags:open_flag list -> - string -> in_channel with_finalizer -(** Open an input file with the given optional flag list. - It yields a [in_channel] with a finalizer attached. See {!(>>>=)} to - use it. *) - -val read : in_channel -> Bytes.t -> int -> int -> int t -(** Read a chunk into the given string *) - -val read_line : in_channel -> string option t -(** Read a line from the channel. Returns [None] if the input is terminated. *) - -val read_lines : in_channel -> string list t -(** Read all lines eagerly *) - -val read_all : in_channel -> string t -(** Read the whole channel into a buffer, then converted into a string *) - -(** {6 Output} *) - -val with_out : ?mode:int -> ?flags:open_flag list -> - string -> out_channel with_finalizer -(** Same as {!with_in} but for an output channel *) - -val with_out_a : ?mode:int -> ?flags:open_flag list -> - string -> out_channel with_finalizer -(** Similar to {!with_out} but with the [Open_append] and [Open_creat] - flags activated *) - -val write : out_channel -> string -> int -> int -> unit t - -val write_str : out_channel -> string -> unit t - -val write_buf : out_channel -> Buffer.t -> unit t - -val write_line : out_channel -> string -> unit t - -val flush : out_channel -> unit t - -(* TODO: printf/fprintf wrappers *) - -(** {2 Streams} - -Iterators on chunks of bytes, or lines, or any other value using combinators. -Those iterators are usable only once, because their source might -be usable only once (think of a socket) *) - -module Seq : sig - type 'a t - (** An IO stream of values of type 'a, consumable (iterable only once) *) - - val map : ('a -> 'b io) -> 'a t -> 'b t - (** Map values with actions *) - - val map_pure : ('a -> 'b) -> 'a t -> 'b t - (** Map values with a pure function *) - - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - - val filter : ('a -> bool) -> 'a t -> 'a t - - val flat_map : ('a -> 'b t io) -> 'a t -> 'b t - (** Map each value to a sub sequence of values *) - - val take : int -> 'a t -> 'a t - - val drop : int -> 'a t -> 'a t - - val take_while : ('a -> bool io) -> 'a t -> 'a t - - val drop_while : ('a -> bool io) -> 'a t -> 'a t - - val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)] io) -> - 'b -> 'a t -> 'c t - (** [general_iter f acc seq] performs a [filter_map] over [seq], - using [f]. [f] is given a state and the current value, and - can either return [`Stop] to indicate it stops traversing, - or [`Continue (st, c)] where [st] is the new state and - [c] an optional output value. - The result is the stream of values output by [f] *) - - val tee : ('a -> unit io) list -> 'a t -> 'a t - (** [tee funs seq] behaves like [seq], but each element is given to - every function [f] in [funs]. This function [f] returns an action that - is eagerly executed. *) - - (** {6 Consume} *) - - val iter : ('a -> _ io) -> 'a t -> unit io - (** Iterate on the stream, with an action for each element *) - - val length : _ t -> int io - (** Length of the stream *) - - val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io - (** [fold f acc seq] folds over [seq], consuming it. Every call to [f] - has the right to return an IO value. *) - - val fold_pure : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b io - (** [fold f acc seq] folds over [seq], consuming it. [f] is pure. *) - - (** {6 Standard Wrappers} *) - - type 'a step_result = - | Yield of 'a - | Stop - - type 'a gen = unit -> 'a step_result io - - val of_fun : 'a gen -> 'a t - (** Create a stream from a function that yields an element or stops *) - - val empty : 'a t - val singleton : 'a -> 'a t - val cons : 'a -> 'a t -> 'a t - val of_list : 'a list -> 'a t - val of_array : 'a array -> 'a t - - val chunks : size:int -> in_channel -> string t - (** Read the channel's content into chunks of size [size] *) - - val lines : in_channel -> string t - (** Lines of an input channel *) - - val words : string t -> string t - (** Split strings into words at " " boundaries. - {b NOT IMPLEMENTED} *) - - val output : ?sep:string -> out_channel -> string t -> unit io - (** [output oc seq] outputs every value of [seq] into [oc], separated - with the optional argument [sep] (default: None). - It blocks until all values of [seq] are produced and written to [oc]. *) -end - -(** {6 File and file names} - -How to list recursively files in a directory: -{[ - CCIO.( - File.read_dir ~recurse:true (File.make "/tmp") - >>= Seq.output ~sep:"\n" stdout - ) |> CCIO.run_exn ;; - - ]} - -See {!File.walk} if you also need to list directories. -*) - -module File : sig - type t = string - (** A file is always represented by its absolute path *) - - val to_string : t -> string - - val make : string -> t - (** Build a file representation from a path (absolute or relative) *) - - val exists : t -> bool io - - val is_directory : t -> bool io - - val remove : t -> unit io - - val read_dir : ?recurse:bool -> t -> t Seq.t io - (** [read_dir d] returns a sequence of files and directory contained - in the directory [d] (or an empty stream if [d] is not a directory) - @param recurse if true (default [false]), sub-directories are also - explored *) - - val walk : t -> ([`File | `Dir] * t) Seq.t io - (** Similar to {!read_dir} (with [recurse=true]), this function walks - a directory recursively and yields either files or directories. - Is a file anything that doesn't satisfy {!is_directory} (including - symlinks, etc.) *) -end - -(** {2 Low level access} *) -module Raw : sig - val wrap : (unit -> 'a) -> 'a t - (** [wrap f] is the IO action that, when executed, returns [f ()]. - [f] should be callable as many times as required *) -end diff --git a/src/advanced/containers_advanced.ml b/src/advanced/containers_advanced.ml deleted file mode 100644 index 555b92e5..00000000 --- a/src/advanced/containers_advanced.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* -copyright (c) 2013-2015, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -module Batch = CCBatch -module Cat = CCCat -module Linq = CCLinq -module MonadIO = CCMonadIO