simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 03:05:28 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

remove containers.advanced

Browse source
This commit is contained in:
Simon Cruanes 2016-11-03 18:28:58 +01:00
parent 13b283a91d
commit 7628e654f7
13 changed files with 6 additions and 2795 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -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) \

9
README.adoc
View file

@ -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:

25
_oasis
View file

@ -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/

9
doc/intro.txt
View file

@ -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.

237
src/advanced/CCBatch.ml
View file

@ -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

80
src/advanced/CCBatch.mli
View file

@ -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

144
src/advanced/CCCat.ml
View file

@ -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

113
src/advanced/CCCat.mli
View file

@ -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

888
src/advanced/CCLinq.ml
View file

@ -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<String.length s then k (String.sub s i (String.length s-i))
| Some j ->
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

424
src/advanced/CCLinq.mli
View file

@ -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

519
src/advanced/CCMonadIO.cppo.ml
View file

@ -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

322
src/advanced/CCMonadIO.mli
View file

@ -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

29
src/advanced/containers_advanced.ml
View file

@ -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