merge from master

This commit is contained in:
Simon Cruanes 2014-08-06 23:05:39 +02:00
commit d3224e6b4d
38 changed files with 1865 additions and 60 deletions

View file

@ -3,11 +3,12 @@
#directory "_build/core";;
#directory "_build/misc";;
#directory "_build/string";;
#directory "_build/threads";;
#directory "_build/tests/";;
#load "containers.cma";;
#load "containers_string.cma";;
#load "containers_misc.cma";;
#require "threads";;
#thread;;
#load "containers_thread.cma";;
open Containers_misc;;
#install_printer Bencode.pretty;;

View file

@ -93,4 +93,11 @@ test-all: run-test qtest
tags:
otags *.ml *.mli
VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis)
update_next_tag:
@echo "update version to $(VERSION)..."
sed -i "s/NEXT_VERSION/$(VERSION)/g" **/*.ml **/*.mli
sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli
.PHONY: examples push_doc tags qtest push-stable clean-generated

View file

@ -20,6 +20,8 @@ ocaml-containers
Some of the modules have been moved to their own repository (e.g. `sequence`,
`gen`, `qcheck` and are on opam for great fun and profit (or not)).
[![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/)
## Use
You can either build and install the library (see `Build`), or just copy

10
_oasis
View file

@ -1,6 +1,6 @@
OASISFormat: 0.4
Name: containers
Version: 0.3.1
Version: 0.3.3
Homepage: https://github.com/c-cube/ocaml-containers
Authors: Simon Cruanes
License: BSD-2-clause
@ -45,8 +45,8 @@ Library "containers"
Path: core
Modules: CCVector, CCDeque, CCGen, CCSequence, CCFQueue, CCMultiMap,
CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError,
CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash,
CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd,
CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCCat,
CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCIO,
CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl
FindlibName: containers
@ -74,13 +74,13 @@ Library "containers_misc"
Library "containers_thread"
Path: threads/
Modules: Future
Modules: CCFuture
FindlibName: thread
FindlibParent: containers
Build$: flag(thread)
Install$: flag(thread)
BuildDepends: containers,threads
XMETARequires: containers,threads,lwt
XMETARequires: containers,threads
Library "containers_lwt"
Path: lwt

View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 003d658600739a79dc7efd8dee4190ce)
# DO NOT EDIT (digest: 3ce32ab9d93a14d03bdd4e7d7bc097f0)
core/CCVector
core/CCDeque
core/CCGen
@ -17,12 +17,14 @@ core/CCOpt
core/CCPair
core/CCFun
core/CCHash
core/CCCat
core/CCKList
core/CCInt
core/CCBool
core/CCArray
core/CCBatch
core/CCOrd
core/CCIO
core/CCRandom
core/CCLinq
core/CCKTree

145
core/CCCat.ml Normal file
View file

@ -0,0 +1,145 @@
(*
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

114
core/CCCat.mli Normal file
View file

@ -0,0 +1,114 @@
(*
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

View file

@ -43,6 +43,12 @@ let return x = `Ok x
let fail s = `Error s
let fail_printf format =
let buf = Buffer.create 16 in
Printf.kbprintf
(fun buf -> fail (Buffer.contents buf))
buf format
let _printers = ref []
let register_printer p = _printers := p :: !_printers

View file

@ -45,6 +45,11 @@ val fail : string -> 'a t
val of_exn : exn -> 'a t
val fail_printf : ('a, Buffer.t, unit, 'a t) format4 -> 'a
(** [fail_printf format] uses [format] to obtain an error message
and then returns [`Error msg]
@since 0.3.3 *)
val map : ('a -> 'b) -> 'a t -> 'b t
val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t

View file

@ -107,7 +107,8 @@ module Make(X : HASHABLE) = struct
h mod Array.length tbl.arr
let _succ tbl i =
if i = Array.length tbl.arr-1 then 0 else i+1
let i' = i+1 in
if i' = Array.length tbl.arr then 0 else i'
let _pred tbl i =
if i = 0 then Array.length tbl.arr - 1 else i-1
@ -198,7 +199,7 @@ module Make(X : HASHABLE) = struct
| Empty -> raise Not_found
| Key (k', v', _) when X.equal k k' -> v'
| Key (_, _, h_k') ->
if (dib > 3 && _dib tbl h_k' i < dib)
if _dib tbl h_k' i < dib
then raise Not_found (* [k] would be here otherwise *)
else _get_exn tbl k h_k (_succ tbl i) (dib+1)
@ -206,9 +207,21 @@ module Make(X : HASHABLE) = struct
let h_k = X.hash k in
let i0 = _initial_idx tbl h_k in
match tbl.arr.(i0) with
| Empty -> raise Not_found
| Key (k', v, _) when X.equal k k' -> v
| Key _ -> _get_exn tbl k h_k (_succ tbl i0) 1
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else let i1 = _succ tbl i0 in
match tbl.arr.(i1) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else
let i2 = _succ tbl i1 in
match tbl.arr.(i2) with
| Empty -> raise Not_found
| Key (k', v, _) ->
if X.equal k k' then v
else _get_exn tbl k h_k (_succ tbl i2) 3
let get k tbl =
try Some (get_exn k tbl)

519
core/CCIO.ml Normal file
View file

@ -0,0 +1,519 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 IO Monad} *)
type _ t =
| Return : 'a -> 'a t
| Fail : string -> 'a t
| Map : ('a -> 'b) * 'a t -> 'b t
| Bind : ('a -> 'b t) * 'a t -> 'b t
| WithGuard: unit t * 'a t -> 'a t (* run guard in any case *)
| Star : ('a -> 'b) t * 'a t -> 'b t
| Repeat : int * 'a t -> 'a list t
| RepeatIgnore : int * 'a t -> unit t
| Wrap : (unit -> 'a) -> 'a t
| SequenceMap : ('a -> 'b t) * 'a list -> 'b list t
type 'a io = 'a t
type 'a with_finalizer = ('a t * unit t) t
type 'a or_error = [ `Ok of 'a | `Error of string ]
let (>>=) x f = Bind(f,x)
let bind ?finalize f a = match finalize with
| None -> Bind(f,a)
| Some b -> WithGuard (b, Bind (f,a))
let map f x = Map(f, x)
let (>|=) x f = Map(f, x)
let return x = Return x
let pure = return
let fail msg = Fail msg
let (<*>) f a = Star (f, a)
let lift = map
let lift2 f a b =
a >>= fun x -> map (f x) b
let lift3 f a b c =
a >>= fun x ->
b >>= fun y -> map (f x y) c
let sequence_map f l =
SequenceMap (f,l)
let sequence l =
let _id x = x in
SequenceMap(_id, l)
let repeat i a =
if i <= 0 then Return [] else Repeat (i,a)
let repeat' i a =
if i <= 0 then Return () else RepeatIgnore (i,a)
(** {2 Finalizers} *)
let (>>>=) a f =
a >>= function
| x, finalizer -> WithGuard (finalizer, x >>= f)
(** {2 Running} *)
exception IOFailure of string
let rec _run : type a. a t -> a = function
| Return x -> x
| Fail msg -> raise (IOFailure msg)
| Map (f, a) -> f (_run a)
| Bind (f, a) -> _run (f (_run a))
| WithGuard (g, a) ->
begin try
let res = _run a in
_run g;
res
with e ->
_run g;
raise e
end
| Star (f, a) -> _run f (_run a)
| Repeat (i,a) -> _repeat [] i a
| RepeatIgnore (i,a) -> _repeat_ignore i a
| Wrap f -> f()
| SequenceMap (f, l) -> _sequence_map f l []
and _repeat : type a. a list -> int -> a t -> a list
= fun acc i a -> match i with
| 0 -> List.rev acc
| _ ->
let x = _run a in
_repeat (x::acc) (i-1) a
and _repeat_ignore : type a. int -> a t -> unit
= fun i a -> match i with
| 0 -> ()
| _ ->
let _ = _run a in
_repeat_ignore (i-1) a
and _sequence_map : type a b. (a -> b t) -> a list -> b list -> b list
= fun f l acc -> match l with
| [] -> List.rev acc
| a::tail ->
let x = _run (f a) in
_sequence_map f tail (x::acc)
let _printers =
ref [
(* default printer *)
( function IOFailure msg
| Sys_error msg -> Some msg
| Exit -> Some "exit"
| _ -> None
)
]
exception PrinterResult of string
let _print_exn e =
try
List.iter
(fun p -> match p e with
| None -> ()
| Some msg -> raise (PrinterResult msg)
) !_printers;
Printexc.to_string e
with PrinterResult s -> s
let run x =
try `Ok (_run x)
with e -> `Error (_print_exn e)
exception IO_error of string
let run_exn x =
try _run x
with e -> raise (IO_error (_print_exn e))
let register_printer p = _printers := p :: !_printers
(** {2 Standard Wrappers} *)
let _open_in mode flags filename () =
open_in_gen flags mode filename
let _close_in ic () = close_in ic
let with_in ?(mode=0o644) ?(flags=[]) filename =
Wrap (_open_in mode flags filename)
>>= fun ic ->
Return (Return ic, Wrap (_close_in ic))
let _read ic s i len () = input ic s i len
let read ic s i len = Wrap (_read ic s i len)
let _read_line ic () =
try Some (Pervasives.input_line ic)
with End_of_file -> None
let read_line ic = Wrap(_read_line ic)
let rec _read_lines ic acc =
read_line ic
>>= function
| None -> return (List.rev acc)
| Some l -> _read_lines ic (l::acc)
let read_lines ic = _read_lines ic []
let _read_all ic () =
let buf = Buffer.create 128 in
try
while true do
Buffer.add_channel buf ic 1024
done;
"" (* never returned *)
with End_of_file -> Buffer.contents buf
let read_all ic = Wrap(_read_all ic)
let _open_out mode flags filename () =
open_out_gen flags mode filename
let _close_out oc () = close_out oc
let with_out ?(mode=0o644) ?(flags=[]) filename =
Wrap(_open_out mode (Open_wronly::flags) filename)
>>= fun oc ->
Return(Return oc, Wrap(_close_out oc))
let with_out_a ?mode ?(flags=[]) filename =
with_out ?mode ~flags:(Open_creat::Open_append::flags) filename
let _write oc s i len () = output oc s i len
let write oc s i len = Wrap (_write oc s i len)
let _write_str oc s () = output oc s 0 (String.length s)
let write_str oc s = Wrap (_write_str oc s)
let _write_line oc l () =
output_string oc l;
output_char oc '\n'
let write_line oc l = Wrap (_write_line oc l)
let _write_buf oc buf () = Buffer.output_buffer oc buf
let write_buf oc buf = Wrap (_write_buf oc buf)
let flush oc = Wrap (fun () -> Pervasives.flush oc)
(** {2 Seq} *)
module Seq = struct
type 'a step_result =
| Yield of 'a
| Stop
type 'a gen = unit -> 'a step_result io
type 'a t = 'a gen
let _stop () = return Stop
let _yield x = return (Yield x)
let map_pure f gen () =
gen() >>= function
| Stop -> _stop ()
| Yield x -> _yield (f x)
let map f g () =
g() >>= function
| Stop -> _stop ()
| Yield x -> f x >>= _yield
let rec filter_map f g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
match f x with
| None -> filter_map f g()
| Some y -> _yield y
let rec filter f g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
if f x then _yield x else filter f g()
let rec flat_map f g () =
g() >>= function
| Stop -> _stop ()
| Yield x ->
f x >>= fun g' -> _flat_map_aux f g g' ()
and _flat_map_aux f g g' () =
g'() >>= function
| Stop -> flat_map f g ()
| Yield x -> _yield x
let general_iter f acc g =
let acc = ref acc in
let rec _next () =
g() >>= function
| Stop -> _stop()
| Yield x ->
f !acc x >>= function
| `Stop -> _stop()
| `Continue (acc', ret) ->
acc := acc';
match ret with
| None -> _next()
| Some y -> _yield y
in
_next
let take n seq =
general_iter
(fun n x -> if n<=0
then return `Stop
else return (`Continue (n-1, Some x))
) n seq
let drop n seq =
general_iter
(fun n x -> if n<=0
then return (`Continue (n, Some x))
else return (`Continue (n-1, None))
) n seq
let take_while p seq =
general_iter
(fun () x ->
p x >|= function
| true -> `Continue ((), Some x)
| false -> `Stop
) () seq
let drop_while p seq =
general_iter
(fun dropping x ->
if dropping
then p x >|= function
| true -> `Continue (true, None)
| false -> `Continue (false, Some x)
else return (`Continue (false, Some x))
) true seq
(* apply all actions from [l] to [x] *)
let rec _apply_all_to x l = match l with
| [] -> return ()
| f::tail -> f x >>= fun () -> _apply_all_to x tail
let _tee funs g () =
g() >>= function
| Stop -> _stop()
| Yield x ->
_apply_all_to x funs >>= fun () ->
_yield x
let tee funs g = match funs with
| [] -> g
| _::_ -> _tee funs g
(** {6 Consume} *)
let rec fold_pure f acc g =
g() >>= function
| Stop -> return acc
| Yield x -> fold_pure f (f acc x) g
let length g = fold_pure (fun acc _ -> acc+1) 0 g
let rec fold f acc g =
g() >>= function
| Stop -> return acc
| Yield x ->
f acc x >>= fun acc' -> fold f acc' g
let rec iter f g =
g() >>= function
| Stop -> return ()
| Yield x -> f x >>= fun _ -> iter f g
let of_fun g = g
let empty () = _stop()
let singleton x =
let first = ref true in
fun () ->
if !first then (first := false; _yield x) else _stop()
let cons x g =
let first = ref true in
fun () ->
if !first then (first := false; _yield x) else g()
let of_list l =
let l = ref l in
fun () -> match !l with
| [] -> _stop()
| x::tail -> l:= tail; _yield x
let of_array a =
let i = ref 0 in
fun () ->
if !i = Array.length a
then _stop()
else (
let x = a.(!i) in
incr i;
_yield x
)
(* TODO: wrapper around with_in? using bind ~finalize:... ? *)
let chunks ~size ic =
let buf = Buffer.create size in
let eof = ref false in
let next() =
if !eof then _stop()
else try
Buffer.add_channel buf ic size;
let s = Buffer.contents buf in
Buffer.clear buf;
_yield s
with End_of_file ->
let s = Buffer.contents buf in
eof := true;
if s="" then _stop() else _yield s
in
next
let lines ic () =
try _yield (input_line ic)
with End_of_file -> _stop()
let words g =
failwith "words: not implemented yet"
(* TODO: state machine that goes:
- 0: read input chunk
- switch to "search for ' '", and yield word
- goto 0 if no ' ' found
- yield leftover when g returns Stop
let buf = Buffer.create 32 in
let next() =
g() >>= function
| Stop -> _stop
| Yield s ->
Buffer.add_string buf s;
search_
in
next
*)
let output ?sep oc seq =
let first = ref true in
iter
(fun s ->
(* print separator *)
( if !first
then (first:=false; return ())
else match sep with
| None -> return ()
| Some sep -> write_str oc sep
) >>= fun () ->
write_str oc s
) seq
>>= fun () -> flush oc
end
(** {6 File and file names} *)
module File = struct
type t = string
let to_string f = f
let make f =
if Filename.is_relative f
then Filename.concat (Sys.getcwd()) f
else f
let exists f = Wrap (fun () -> Sys.file_exists f)
let is_directory f = Wrap (fun () -> Sys.is_directory f)
let remove f = Wrap (fun () -> Sys.remove f)
let _read_dir d () =
if Sys.is_directory d
then
let arr = Sys.readdir d in
Seq.of_array arr
|> Seq.map_pure make
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
|> Seq.flat_map
(fun s -> return (_walk (Filename.concat d s) ()))
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
Seq.of_array arr
|> Seq.map_pure (fun s -> Filename.concat d s)
|> Seq.flat_map
(fun s ->
if Sys.is_directory s
then return (_read_dir_rec s ())
else return (Seq.singleton s)
)
else Seq.empty
end
(** {2 Raw} *)
module Raw = struct
let wrap f = Wrap f
end

323
core/CCIO.mli Normal file
View file

@ -0,0 +1,323 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 IO Monad}
A simple abstraction over blocking IO, with strict evaluation. This is in
no way an alternative to Lwt/Async if you need concurrency.
@since 0.3.3
*)
(**
Examples:
- obtain the list of lines of a file:
{[
let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);;
]}
- transfer one file into another:
{[
# let a = CCIO.(
with_in "input" >>>= fun ic ->
with_out ~flags:[Open_creat] "output" >>>= fun oc ->
Seq.chunks 512 ic
|> Seq.output oc
) ;;
# run a;;
]}
*)
type 'a t
type 'a io = 'a t
type 'a with_finalizer
(** A value of type ['a with_finalizer] is similar to a value ['a t] but
also contains a finalizer that must be run to cleanup.
See {!(>>>=)} to get rid of it. *)
type 'a or_error = [ `Ok of 'a | `Error of string ]
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** wait for the result of an action, then use a function to build a
new action and execute it *)
val return : 'a -> 'a t
(** Just return a value *)
val repeat : int -> 'a t -> 'a list t
(** Repeat an IO action as many times as required *)
val repeat' : int -> 'a t -> unit t
(** Same as {!repeat}, but ignores the result *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Map values *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val bind : ?finalize:(unit t) -> ('a -> 'b t) -> 'a t -> 'b t
(** [bind f a] runs the action [a] and applies [f] to its result
to obtain a new action. It then behaves exactly like this new
action.
@param finalize an optional action that is always run after evaluating
the whole action *)
val pure : 'a -> 'a t
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
val lift : ('a -> 'b) -> 'a t -> 'b t
(** Synonym to {!map} *)
val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
val sequence : 'a t list -> 'a list t
(** Runs operations one by one and gather their results *)
val sequence_map : ('a -> 'b t) -> 'a list -> 'b list t
(** Generalization of {!sequence} *)
val fail : string -> 'a t
(** [fail msg] fails with the given message. Running the IO value will
return an [`Error] variant *)
(** {2 Finalizers} *)
val (>>>=) : 'a with_finalizer -> ('a -> 'b t) -> 'b t
(** Alternative to {!(>>=)} that also takes a [unit t] value, that is a
finalizer. This action will run in any case (even failure).
Other than the finalizer, this behaves like {!(>>=)} *)
(** {2 Running} *)
val run : 'a t -> 'a or_error
(** Run an IO action.
@return either [`Ok x] when [x] is the successful result of the
computation, or some [`Error "message"] *)
exception IO_error of string
val run_exn : 'a t -> 'a
(** Unsafe version of {!run}. It assumes non-failure.
@raise IO_error if the execution didn't go well *)
val register_printer : (exn -> string option) -> unit
(** [register_printer p] register [p] as a possible failure printer.
If [run a] raises an exception [e], [p e] is evaluated. If [p e = Some msg]
then the error message will be [msg], otherwise other printers will
be tried *)
(** {2 Standard Wrappers} *)
(** {6 Input} *)
val with_in : ?mode:int -> ?flags:open_flag list ->
string -> in_channel with_finalizer
(** Open an input file with the given optional flag list.
It yields a [in_channel] with a finalizer attached. See {!(>>>=)} to
use it. *)
val read : in_channel -> string -> int -> int -> int t
(** Read a chunk into the given string *)
val read_line : in_channel -> string option t
(** Read a line from the channel. Returns [None] if the input is terminated. *)
val read_lines : in_channel -> string list t
(** Read all lines eagerly *)
val read_all : in_channel -> string t
(** Read the whole channel into a buffer, then converted into a string *)
(** {6 Output} *)
val with_out : ?mode:int -> ?flags:open_flag list ->
string -> out_channel with_finalizer
(** Same as {!with_in} but for an output channel *)
val with_out_a : ?mode:int -> ?flags:open_flag list ->
string -> out_channel with_finalizer
(** Similar to {!with_out} but with the [Open_append] and [Open_creat]
flags activated *)
val write : out_channel -> string -> int -> int -> unit t
val write_str : out_channel -> string -> unit t
val write_buf : out_channel -> Buffer.t -> unit t
val write_line : out_channel -> string -> unit t
val flush : out_channel -> unit t
(* TODO: printf/fprintf wrappers *)
(** {2 Streams}
Iterators on chunks of bytes, or lines, or any other value using combinators.
Those iterators are usable only once, because their source might
be usable only once (think of a socket) *)
module Seq : sig
type 'a t
(** An IO stream of values of type 'a, consumable (iterable only once) *)
val map : ('a -> 'b io) -> 'a t -> 'b t
(** Map values with actions *)
val map_pure : ('a -> 'b) -> 'a t -> 'b t
(** Map values with a pure function *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter : ('a -> bool) -> 'a t -> 'a t
val flat_map : ('a -> 'b t io) -> 'a t -> 'b t
(** Map each value to a sub sequence of values *)
val take : int -> 'a t -> 'a t
val drop : int -> 'a t -> 'a t
val take_while : ('a -> bool io) -> 'a t -> 'a t
val drop_while : ('a -> bool io) -> 'a t -> 'a t
val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)] io) ->
'b -> 'a t -> 'c t
(** [general_iter f acc seq] performs a [filter_map] over [seq],
using [f]. [f] is given a state and the current value, and
can either return [`Stop] to indicate it stops traversing,
or [`Continue (st, c)] where [st] is the new state and
[c] an optional output value.
The result is the stream of values output by [f] *)
val tee : ('a -> unit io) list -> 'a t -> 'a t
(** [tee funs seq] behaves like [seq], but each element is given to
every function [f] in [funs]. This function [f] returns an action that
is eagerly executed. *)
(** {6 Consume} *)
val iter : ('a -> _ io) -> 'a t -> unit io
(** Iterate on the stream, with an action for each element *)
val length : _ t -> int io
(** Length of the stream *)
val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io
(** [fold f acc seq] folds over [seq], consuming it. Every call to [f]
has the right to return an IO value. *)
val fold_pure : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b io
(** [fold f acc seq] folds over [seq], consuming it. [f] is pure. *)
(** {6 Standard Wrappers} *)
type 'a step_result =
| Yield of 'a
| Stop
type 'a gen = unit -> 'a step_result io
val of_fun : 'a gen -> 'a t
(** Create a stream from a function that yields an element or stops *)
val empty : 'a t
val singleton : 'a -> 'a t
val cons : 'a -> 'a t -> 'a t
val of_list : 'a list -> 'a t
val of_array : 'a array -> 'a t
val chunks : size:int -> in_channel -> string t
(** Read the channel's content into chunks of size [size] *)
val lines : in_channel -> string t
(** Lines of an input channel *)
val words : string t -> string t
(** Split strings into words at " " boundaries.
{b NOT IMPLEMENTED} *)
val output : ?sep:string -> out_channel -> string t -> unit io
(** [output oc seq] outputs every value of [seq] into [oc], separated
with the optional argument [sep] (default: None).
It blocks until all values of [seq] are produced and written to [oc]. *)
end
(** {6 File and file names}
How to list recursively files in a directory:
{[
CCIO.(
File.read_dir ~recurse:true (File.make "/tmp")
>>= Seq.output ~sep:"\n" stdout
) |> CCIO.run_exn ;;
]}
See {!File.walk} if you also need to list directories.
*)
module File : sig
type t = string
(** A file is always represented by its absolute path *)
val to_string : t -> string
val make : string -> t
(** Build a file representation from a path (absolute or relative) *)
val exists : t -> bool io
val is_directory : t -> bool io
val remove : t -> unit io
val read_dir : ?recurse:bool -> t -> t Seq.t io
(** [read_dir d] returns a sequence of files and directory contained
in the directory [d] (or an empty stream if [d] is not a directory)
@param recurse if true (default [false]), sub-directories are also
explored *)
val walk : t -> ([`File | `Dir] * t) Seq.t io
(** similar to {!read_dir} (with [recurse=true]), this function walks
a directory recursively and yields either files or directories.
Is a file anything that doesn't satisfy {!is_directory} (including
symlinks, etc.) *)
end
(** {2 Low level access} *)
module Raw : sig
val wrap : (unit -> 'a) -> 'a t
(** [wrap f] is the IO action that, when executed, returns [f ()].
[f] should be callable as many times as required *)
end

View file

@ -43,6 +43,21 @@ let empty = nil
let singleton x () = `Cons (x, nil)
let rec _forever x () = `Cons (x, _forever x)
let rec _repeat n x () =
if n<=0 then `Nil else `Cons (x, _repeat (n-1) x)
let repeat ?n x = match n with
| None -> _forever x
| Some n -> _repeat n x
(*$T
repeat ~n:4 0 |> to_list = [0;0;0;0]
repeat ~n:0 1 |> to_list = []
repeat 1 |> take 20 |> to_list = (repeat ~n:20 1 |> to_list)
*)
let is_empty l = match l () with
| `Nil -> true
| `Cons _ -> false
@ -130,6 +145,12 @@ let rec append l1 l2 () = match l1 () with
| `Nil -> l2 ()
| `Cons (x, l1') -> `Cons (x, append l1' l2)
let rec cycle l () = append l (cycle l) ()
(*$T
cycle (of_list [1;2]) |> take 5 |> to_list = [1;2;1;2;1]
*)
let rec flat_map f l () = match l () with
| `Nil -> `Nil
| `Cons (x, l') ->
@ -139,6 +160,50 @@ and _flat_map_app f l l' () = match l () with
| `Cons (x, tl) ->
`Cons (x, _flat_map_app f tl l')
let product_with f l1 l2 =
let rec _next_left h1 tl1 h2 tl2 () =
match tl1() with
| `Nil -> _next_right ~die:true h1 tl1 h2 tl2 ()
| `Cons (x, tl1') ->
_map_list_left x h2
(_next_right ~die:false (x::h1) tl1' h2 tl2)
()
and _next_right ~die h1 tl1 h2 tl2 () =
match tl2() with
| `Nil when die -> `Nil
| `Nil -> _next_left h1 tl1 h2 tl2 ()
| `Cons (y, tl2') ->
_map_list_right h1 y
(_next_left h1 tl1 (y::h2) tl2')
()
and _map_list_left x l kont () = match l with
| [] -> kont()
| y::l' -> `Cons (f x y, _map_list_left x l' kont)
and _map_list_right l y kont () = match l with
| [] -> kont()
| x::l' -> `Cons (f x y, _map_list_right l' y kont)
in
_next_left [] l1 [] l2
let product l1 l2 =
product_with (fun x y -> x,y) l1 l2
let rec group eq l () = match l() with
| `Nil -> `Nil
| `Cons (x, l') ->
`Cons (cons x (take_while (eq x) l'), group eq (drop_while (eq x) l'))
let rec _uniq eq prev l () = match prev, l() with
| _, `Nil -> `Nil
| None, `Cons (x, l') ->
`Cons (x, _uniq eq (Some x) l')
| Some y, `Cons (x, l') ->
if eq x y
then _uniq eq prev l' ()
else `Cons (x, _uniq eq (Some x) l')
let uniq eq l = _uniq eq None l
let rec filter_map f l () = match l() with
| `Nil -> `Nil
| `Cons (x, l') ->
@ -202,6 +267,15 @@ let rec merge cmp l1 l2 () = match l1(), l2() with
then `Cons (x1, merge cmp l1' l2)
else `Cons (x2, merge cmp l1 l2')
(** {2 Implementations} *)
let return x () = `Cons (x, nil)
let pure = return
let (>>=) xs f = flat_map f xs
let (>|=) xs f = map f xs
let (<*>) fs xs = product_with (fun f x -> f x) fs xs
(** {2 Conversions} *)
let rec _to_rev_list acc l = match l() with
@ -237,6 +311,15 @@ let to_gen l =
l := l';
Some x
let sort ?(cmp=Pervasives.compare) l =
let l = to_list l in
of_list (List.sort cmp l)
let sort_uniq ?(cmp=Pervasives.compare) l =
let l = to_list l in
uniq (fun x y -> cmp x y = 0) (of_list (List.sort cmp l))
(** {2 Monadic Operations} *)
module type MONAD = sig
type 'a t

View file

@ -47,6 +47,16 @@ val cons : 'a -> 'a t -> 'a t
val singleton : 'a -> 'a t
val repeat : ?n:int -> 'a -> 'a t
(** [repeat ~n x] repeats [x] [n] times then stops. If [n] is omitted,
then [x] is repeated forever.
@since 0.3.3 *)
val cycle : 'a t -> 'a t
(** Cycle through the iterator infinitely. The iterator shouldn't be empty.
@since 0.3.3 *)
val is_empty : 'a t -> bool
val equal : 'a equal -> 'a t equal
@ -78,6 +88,27 @@ val filter : ('a -> bool) -> 'a t -> 'a t
val append : 'a t -> 'a t -> 'a t
val product_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
(** Fair product of two (possibly infinite) lists into a new list. Lazy.
The first parameter is used to combine each pair of elements
@since 0.3.3 *)
val product : 'a t -> 'b t -> ('a * 'b) t
(** Specialization of {!product_with} producing tuples
@since 0.3.3 *)
val group : 'a equal -> 'a t -> 'a t t
(** [group eq l] groups together consecutive elements that satisfy [eq]. Lazy.
For instance [group (=) [1;1;1;2;2;3;3;1]] yields
[[1;1;1]; [2;2]; [3;3]; [1]]
@since 0.3.3 *)
val uniq : 'a equal -> 'a t -> 'a t
(** [uniq eq l] returns [l] but removes consecutive duplicates. Lazy.
In other words, if several values that are equal follow one another,
only the first of them is kept.
@since 0.3.3 *)
val flat_map : ('a -> 'b t) -> 'a t -> 'b t
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
@ -106,6 +137,25 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
val merge : 'a ord -> 'a t -> 'a t -> 'a t
(** Merge two sorted iterators into a sorted iterator *)
val sort : ?cmp:'a ord -> 'a t -> 'a t
(** Eager sort. Requires the iterator to be finite. O(n ln(n)) time
and space.
@since 0.3.3 *)
val sort_uniq : ?cmp:'a ord -> 'a t -> 'a t
(** Eager sort that removes duplicate values. Requires the iterator to be
finite. O(n ln(n)) time and space.
@since 0.3.3 *)
(** {2 Implementations}
@since 0.3.3 *)
val return : 'a -> 'a t
val pure : 'a -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
(** {2 Monadic Operations} *)
module type MONAD = sig
type 'a t

View file

@ -160,6 +160,8 @@ let (>>=) l f = flat_map f l
let (<$>) = map
let pure f = [f]
let (<*>) funs l = product (fun f x -> f x) funs l
let sorted_merge ?(cmp=Pervasives.compare) l1 l2 =
@ -508,6 +510,39 @@ module Zipper = struct
| _, [] -> raise Not_found
end
(** {2 References on Lists} *)
module Ref = struct
type 'a t = 'a list ref
let push l x = l := x :: !l
let pop l = match !l with
| [] -> None
| x::tail ->
l := tail;
Some x
let pop_exn l = match !l with
| [] -> failwith "CCList.Ref.pop_exn"
| x::tail ->
l := tail;
x
let create() = ref []
let clear l = l := []
let lift f l = f !l
let push_list r l =
r := List.rev_append l !r
(*$T
let l = Ref.create() in Ref.push l 1; Ref.push_list l [2;3]; !l = [3;2;1]
*)
end
(** {2 Monadic Operations} *)
module type MONAD = sig
type 'a t

View file

@ -64,6 +64,8 @@ val diagonal : 'a t -> ('a * 'a) t
(** All pairs of distinct positions of the list. [list_diagonal l] will
return the list of [List.nth i l, List.nth j l] if [i < j]. *)
val pure : 'a -> 'a t
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
val (<$>) : ('a -> 'b) -> 'a t -> 'b t
@ -223,6 +225,34 @@ module Zipper : sig
@raise Not_found if the zipper is at an end *)
end
(** {2 References on Lists}
@since 0.3.3 *)
module Ref : sig
type 'a t = 'a list ref
val push : 'a t -> 'a -> unit
val pop : 'a t -> 'a option
val pop_exn : 'a t -> 'a
(** Unsafe version of {!pop}.
@raise Failure if the list is empty *)
val create : unit -> 'a t
(** Create a new list reference *)
val clear : _ t -> unit
(** Remove all elements *)
val lift : ('a list -> 'b) -> 'a t -> 'b
(** Apply a list function to the content *)
val push_list : 'a t -> 'a list -> unit
(** Add elements of the list at the beginning of the list ref. Elements
at the end of the list will be at the beginning of the list ref *)
end
(** {2 Monadic Operations} *)
module type MONAD = sig
type 'a t

View file

@ -225,3 +225,136 @@ module Make(K : OrderedType)(V : OrderedType) = struct
let values m k = iter m (fun _ v -> k v)
end
module type BIDIR = sig
type t
type left
type right
val empty : t
val is_empty : t -> bool
val add : t -> left -> right -> t
(** Add a binding (left,right) *)
val remove : t -> left -> right -> t
(** Remove a specific binding *)
val cardinal_left : t -> int
(** number of distinct left keys *)
val cardinal_right : t -> int
(** number of distinct right keys *)
val remove_left : t -> left -> t
(** Remove all bindings for the left key *)
val remove_right : t -> right -> t
(** Remove all bindings for the right key *)
val mem_left : t -> left -> bool
(** Is the left key present in at least one pair? *)
val mem_right : t -> right -> bool
(** Is the right key present in at least one pair? *)
val find_left : t -> left -> right sequence
(** Find all bindings for this given left-key *)
val find_right : t -> right -> left sequence
(** Find all bindings for this given right-key *)
val find1_left : t -> left -> right option
(** like {!find_left} but returns at most one value *)
val find1_right : t -> right -> left option
(** like {!find_right} but returns at most one value *)
val fold : ('a -> left -> right -> 'a) -> 'a -> t -> 'a
(** Fold on pairs *)
val pairs : t -> (left * right) sequence
(** Iterate on pairs *)
val add_pairs : t -> (left * right) sequence -> t
(** Add pairs *)
val seq_left : t -> left sequence
val seq_right : t -> right sequence
end
let _fold_seq f acc seq =
let acc = ref acc in
seq (fun x -> acc := f !acc x);
!acc
let _head_seq seq =
let r = ref None in
begin try seq (fun x -> r := Some x; raise Exit)
with Exit -> ();
end;
!r
module MakeBidir(L : OrderedType)(R : OrderedType) = struct
type left = L.t
type right = R.t
module MapL = Make(L)(R)
module MapR = Make(R)(L)
type t = {
left : MapL.t;
right : MapR.t;
}
let empty = {
left = MapL.empty;
right = MapR.empty;
}
let is_empty m = MapL.is_empty m.left
let add m a b = {
left = MapL.add m.left a b;
right = MapR.add m.right b a;
}
let remove m a b = {
left = MapL.remove m.left a b;
right = MapR.remove m.right b a;
}
let cardinal_left m = MapL.size m.left
let cardinal_right m = MapR.size m.right
let find_left m a = MapL.find_iter m.left a
let find_right m b = MapR.find_iter m.right b
let remove_left m a =
_fold_seq
(fun m b -> remove m a b)
m (find_left m a)
let remove_right m b =
_fold_seq
(fun m a -> remove m a b)
m (find_right m b)
let mem_left m a = MapL.mem m.left a
let mem_right m b = MapR.mem m.right b
let find1_left m a = _head_seq (find_left m a)
let find1_right m b = _head_seq (find_right m b)
let fold f acc m =
MapL.fold m.left acc f
let pairs m = MapL.to_seq m.left
let add_pairs m seq = _fold_seq (fun m (a,b) -> add m a b) m seq
let seq_left m = MapL.keys m.left
let seq_right m = MapR.keys m.right
end

View file

@ -104,3 +104,70 @@ module type OrderedType = sig
end
module Make(K : OrderedType)(V : OrderedType) : S with type key = K.t and type value = V.t
(** {2 Two-Way Multimap}
Represents n-to-n mappings between two types. Each element from the "left"
is mapped to several right values, and conversely.
@since 0.3.3 *)
module type BIDIR = sig
type t
type left
type right
val empty : t
val is_empty : t -> bool
val add : t -> left -> right -> t
(** Add a binding (left,right) *)
val remove : t -> left -> right -> t
(** Remove a specific binding *)
val cardinal_left : t -> int
(** number of distinct left keys *)
val cardinal_right : t -> int
(** number of distinct right keys *)
val remove_left : t -> left -> t
(** Remove all bindings for the left key *)
val remove_right : t -> right -> t
(** Remove all bindings for the right key *)
val mem_left : t -> left -> bool
(** Is the left key present in at least one pair? *)
val mem_right : t -> right -> bool
(** Is the right key present in at least one pair? *)
val find_left : t -> left -> right sequence
(** Find all bindings for this given left-key *)
val find_right : t -> right -> left sequence
(** Find all bindings for this given right-key *)
val find1_left : t -> left -> right option
(** like {!find_left} but returns at most one value *)
val find1_right : t -> right -> left option
(** like {!find_right} but returns at most one value *)
val fold : ('a -> left -> right -> 'a) -> 'a -> t -> 'a
(** Fold on pairs *)
val pairs : t -> (left * right) sequence
(** Iterate on pairs *)
val add_pairs : t -> (left * right) sequence -> t
(** Add pairs *)
val seq_left : t -> left sequence
val seq_right : t -> right sequence
end
module MakeBidir(L : OrderedType)(R : OrderedType) : BIDIR
with type left = L.t and type right = R.t

View file

@ -25,6 +25,8 @@ for any direct, indirect, incidental, special, exemplary, or consequential
(** {1 Multiset} *)
type 'a sequence = ('a -> unit) -> unit
module type S = sig
type elt
type t
@ -69,6 +71,10 @@ module type S = sig
val of_list : elt list -> t
val to_list : t -> elt list
val to_seq : t -> elt sequence
val of_seq : elt sequence -> t
end
module Make(O : Set.OrderedType) = struct
@ -172,4 +178,12 @@ module Make(O : Set.OrderedType) = struct
| _ -> n_cons (n-1) x (x::l)
in
fold m [] (fun acc n x -> n_cons n x acc)
let to_seq m k =
M.iter (fun x n -> for _i = 1 to n do k x done) m
let of_seq seq =
let m = ref empty in
seq (fun x -> m := add !m x);
!m
end

View file

@ -25,6 +25,8 @@ for any direct, indirect, incidental, special, exemplary, or consequential
(** {1 Multiset} *)
type 'a sequence = ('a -> unit) -> unit
module type S = sig
type elt
type t
@ -69,6 +71,10 @@ module type S = sig
val of_list : elt list -> t
val to_list : t -> elt list
val to_seq : t -> elt sequence
val of_seq : elt sequence -> t
end
module Make(O : Set.OrderedType) : S with type elt = O.t

View file

@ -36,6 +36,11 @@ let map f g (x,y) = f x, g y
let map_same f (x,y) = f x, f y
let map_fst f (x,_) = f x
let map_snd f (_,x) = f x
let iter f (x,y) = f x y
let swap (x,y) = y, x
let (<<<) = map1
@ -47,6 +52,10 @@ let ( *** ) = map
let ( &&& ) f g x = f x, g x
let merge f (x,y) = f x y
let fold = merge
let dup x = x,x
let dup_map f x = x, f x
let equal f g (x1,y1) (x2,y2) = f x1 x2 && g y1 y2

View file

@ -36,6 +36,16 @@ val map : ('a -> 'c) -> ('b -> 'd) -> ('a * 'b) -> ('c * 'd)
val map_same : ('a -> 'b) -> ('a*'a) -> ('b*'b)
val map_fst : ('a -> 'b) -> ('a * _) -> 'b
(** Compose the given function with [fst].
@since 0.3.3 *)
val map_snd : ('a -> 'b) -> (_ * 'a) -> 'b
(** Compose the given function with [snd].
@since 0.3.3 *)
val iter : ('a -> 'b -> unit) -> ('a * 'b) -> unit
val swap : ('a * 'b) -> ('b * 'a)
(** Swap the components of the tuple *)
@ -55,6 +65,19 @@ val ( &&& ) : ('a -> 'b) -> ('a -> 'c) -> 'a -> ('b * 'c)
val merge : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c
(** Uncurrying (merges the two components of a tuple) *)
val fold : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c
(** Synonym to {!merge}
@since 0.3.3 *)
val dup : 'a -> ('a * 'a)
(** [dup x = (x,x)] (duplicate the value)
@since 0.3.3 *)
val dup_map : ('a -> 'b) -> 'a -> ('a * 'b)
(** [dup_map f x = (x, f x)]. Duplicates the value and applies the function
to the second copy.
@since 0.3.3 *)
val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -> bool
val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b) -> ('a * 'b) -> int

View file

@ -56,6 +56,11 @@ let compare = String.compare
let hash s = Hashtbl.hash s
let init n f =
let s = String.make n ' ' in
for i = 0 to n-1 do s.[i] <- f i done;
s
let length = String.length
let rec _to_list s acc i len =

View file

@ -62,6 +62,10 @@ val compare : t -> t -> int
val hash : t -> int
val init : int -> (int -> char) -> t
(** Analog to [Array.init].
@since 0.3.3 *)
val of_gen : char gen -> t
val of_seq : char sequence -> t
val of_klist : char klist -> t

View file

@ -104,6 +104,14 @@ module type S = sig
val to_seq_values : 'a t -> 'a sequence
val to_tree : 'a t -> [`Char of char_ | `Val of 'a | `Switch] ktree
(** {6 Ranges} *)
val above : key -> 'a t -> (key * 'a) sequence
(** All bindings whose key is bigger than (or equal to) the given key *)
val below : key -> 'a t -> (key * 'a) sequence
(** All bindings whose key is smaller or equal to the given key *)
end
module Make(W : WORD) = struct
@ -143,6 +151,19 @@ module Make(W : WORD) = struct
seq (fun x -> acc := f !acc x);
finish !acc
let _filter_map_seq f seq k =
seq (fun x -> match f x with
| None -> ()
| Some y -> k y)
let _seq_append_list l seq =
let l = ref l in
seq (fun x -> l := x :: !l);
!l
let _seq_map map k =
M.iter (fun key v -> k (key,v)) map
let _is_path = function
| Path _ -> true
| _ -> false
@ -293,24 +314,39 @@ module Make(W : WORD) = struct
let _difflist_append f l = fun l' -> f (l @ l')
let _difflist_add f x = fun l' -> f (x :: l')
let fold f acc t =
(* also keep the path from the root, so as to provide the list
of chars that lead to a value. The path is a difference list, ie
a function that prepends a list to some suffix *)
let rec aux path t acc = match t with
| Empty -> acc
| Path (l, t') -> aux (_difflist_append path l) t' acc
| Node (v, map) ->
let acc = match v with
| None -> acc
| Some v -> f acc (W.of_list (path [])) v
in
M.fold
(fun c t' acc -> aux (_difflist_add path c) t' acc)
map acc
in aux _id t acc
(* fold that also keeps the path from the root, so as to provide the list
of chars that lead to a value. The path is a difference list, ie
a function that prepends a list to some suffix *)
let rec _fold f path t acc = match t with
| Empty -> acc
| Path (l, t') -> _fold f (_difflist_append path l) t' acc
| Node (v, map) ->
let acc = match v with
| None -> acc
| Some v -> f acc path v
in
M.fold
(fun c t' acc -> _fold f (_difflist_add path c) t' acc)
map acc
let iter f t = fold (fun _ x y -> f x y) () t
let fold f acc t =
_fold
(fun acc path v ->
let key = W.of_list (path []) in
f acc key v
) _id t acc
let iter f t =
_fold
(fun () path y -> f (W.of_list (path [])) y)
_id t ()
let _iter_prefix ~prefix f t =
_fold
(fun () path y ->
let key = W.of_list (prefix (path [])) in
f key y)
_id t ()
let rec fold_values f acc t = match t with
| Empty -> acc
@ -415,8 +451,83 @@ module Make(W : WORD) = struct
in
let l = M.bindings map in
`Node(x, List.map (fun (c,t') -> _tree_node (`Char c) [to_tree t']) l)
(** {6 Ranges} *)
(* range above or below a threshold.
[p c c'] must return [true] if [c'], in the tree, meets some criterion
w.r.t [c] which is a part of the key. *)
let _half_range ~p key t k =
(* at subtree [cur = Some (t,trail)] or [None], alternatives above
[alternatives], and char [c] in [key]. *)
let on_char (cur, alternatives) c =
match cur with
| None -> (None, alternatives)
| Some (Empty,_) -> (None, alternatives)
| Some (Path ([], _),_) -> assert false
| Some (Path (c'::l, t'), trail) ->
if W.compare c c' = 0
then Some (_mk_path l t', _difflist_add trail c), alternatives
else None, alternatives
| Some (Node (_, map), trail) ->
let alternatives =
_seq_map map
|> _filter_map_seq
(fun (c', t') -> if p c c'
then Some (t', _difflist_add trail c')
else None
)
|> _seq_append_list alternatives
in
begin try
let t' = M.find c map in
Some (t', _difflist_add trail c), alternatives
with Not_found ->
None, alternatives
end
(* run through the current path (if any) and alternatives *)
and finish (cur,alternatives) =
begin match cur with
| Some (t, prefix) ->
_iter_prefix ~prefix (fun key' v -> k (key', v)) t
| None -> ()
end;
List.iter
(fun (t,prefix) -> _iter_prefix ~prefix (fun key' v -> k (key', v)) t)
alternatives
in
let word = W.to_seq key in
_fold_seq on_char ~finish (Some(t,_id), []) word
let above key t =
_half_range ~p:(fun c c' -> W.compare c c' < 0) key t
let below key t =
_half_range ~p:(fun c c' -> W.compare c c' > 0) key t
end
module type ORDERED = sig
type t
val compare : t -> t -> int
end
module MakeArray(X : ORDERED) = Make(struct
type t = X.t array
type char_ = X.t
let compare = X.compare
let to_seq a k = Array.iter k a
let of_list = Array.of_list
end)
module MakeList(X : ORDERED) = Make(struct
type t = X.t list
type char_ = X.t
let compare = X.compare
let to_seq a k = List.iter k a
let of_list l = l
end)
module String = Make(struct
type t = string
type char_ = char

View file

@ -104,10 +104,27 @@ module type S = sig
val to_seq_values : 'a t -> 'a sequence
val to_tree : 'a t -> [`Char of char_ | `Val of 'a | `Switch] ktree
(** {6 Ranges} *)
val above : key -> 'a t -> (key * 'a) sequence
(** All bindings whose key is bigger than (or equal to) the given key *)
val below : key -> 'a t -> (key * 'a) sequence
(** All bindings whose key is smaller or equal to the given key *)
end
(** {2 Implementation} *)
module Make(W : WORD) : S with type key = W.t and type char_ = W.char_
module type ORDERED = sig
type t
val compare : t -> t -> int
end
module MakeArray(X : ORDERED) : S with type key = X.t array and type char_ = X.t
module MakeList(X : ORDERED) : S with type key = X.t list and type char_ = X.t
module String : S with type key = string and type char_ = char

View file

@ -1,6 +1,6 @@
# OASIS_START
# DO NOT EDIT (digest: c45a958aaa0c31769f4e67935c863279)
version = "0.3.1"
# DO NOT EDIT (digest: eb8b3792deb258b784b1c656f2fcb136)
version = "0.3.3"
description = "A modular standard library focused on data structures."
archive(byte) = "containers.cma"
archive(byte, plugin) = "containers.cma"
@ -8,9 +8,9 @@ archive(native) = "containers.cmxa"
archive(native, plugin) = "containers.cmxs"
exists_if = "containers.cma"
package "thread" (
version = "0.3.1"
version = "0.3.3"
description = "A modular standard library focused on data structures."
requires = "containers threads lwt"
requires = "containers threads"
archive(byte) = "containers_thread.cma"
archive(byte, plugin) = "containers_thread.cma"
archive(native) = "containers_thread.cmxa"
@ -19,7 +19,7 @@ package "thread" (
)
package "string" (
version = "0.3.1"
version = "0.3.3"
description = "A modular standard library focused on data structures."
archive(byte) = "containers_string.cma"
archive(byte, plugin) = "containers_string.cma"
@ -29,7 +29,7 @@ package "string" (
)
package "misc" (
version = "0.3.1"
version = "0.3.3"
description = "A modular standard library focused on data structures."
requires = "unix containers"
archive(byte) = "containers_misc.cma"
@ -40,7 +40,7 @@ package "misc" (
)
package "lwt" (
version = "0.3.1"
version = "0.3.3"
description = "A modular standard library focused on data structures."
requires = "containers lwt lwt.unix containers.misc"
archive(byte) = "containers_lwt.cma"
@ -51,7 +51,7 @@ package "lwt" (
)
package "cgi" (
version = "0.3.1"
version = "0.3.3"
description = "A modular standard library focused on data structures."
requires = "containers CamlGI"
archive(byte) = "containers_cgi.cma"

View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 97cab0e7fe53378041eec3783d519d27)
# DO NOT EDIT (digest: 5702460a7b213be45526616207085458)
CCVector
CCDeque
CCGen
@ -17,12 +17,14 @@ CCOpt
CCPair
CCFun
CCHash
CCCat
CCKList
CCInt
CCBool
CCArray
CCBatch
CCOrd
CCIO
CCRandom
CCLinq
CCKTree

View file

@ -1,5 +1,5 @@
# OASIS_START
# DO NOT EDIT (digest: 97cab0e7fe53378041eec3783d519d27)
# DO NOT EDIT (digest: 5702460a7b213be45526616207085458)
CCVector
CCDeque
CCGen
@ -17,12 +17,14 @@ CCOpt
CCPair
CCFun
CCHash
CCCat
CCKList
CCInt
CCBool
CCArray
CCBatch
CCOrd
CCIO
CCRandom
CCLinq
CCKTree

View file

@ -33,6 +33,9 @@ type +'a tree =
and +'a t = (int * 'a tree) list
(** Functional array of complete trees *)
(* TODO: inline list's nodes
TODO: encode "complete binary tree" into types *)
(** {2 Functions on trees} *)
@ -62,6 +65,8 @@ let rec tree_update size t i v =match t, i with
let empty = []
let return x = [1, Leaf x]
let is_empty = function
| [] -> true
| _ -> false
@ -95,24 +100,52 @@ let tl l = match l with
let size' = size / 2 in
(size', t1) :: (size', t2) :: l'
let front l = match l with
| [] -> None
| (_, Leaf x) :: tl -> Some (x, tl)
| (size, Node (x, t1, t2)) :: l' ->
let size' = size / 2 in
Some (x, (size', t1) :: (size', t2) :: l')
let front_exn l = match l with
| [] -> raise (Invalid_argument "RAL.front")
| (_, Leaf x) :: tl -> x, tl
| (size, Node (x, t1, t2)) :: l' ->
let size' = size / 2 in
x, (size', t1) :: (size', t2) :: l'
let rec _remove prefix l i =
let x, l' = front_exn l in
if i=0
then List.fold_left (fun l x -> cons x l) l prefix
else _remove (x::prefix) l' (i-1)
let remove l i = _remove [] l i
let rec _map_tree f t = match t with
| Leaf x -> Leaf (f x)
| Node (x, l, r) -> Node (f x, _map_tree f l, _map_tree f r)
let map f l = List.map (fun (i,t) -> i, _map_tree f t) l
let rec length l = match l with
| [] -> 0
| (size,_) :: l' -> size + length l'
let rec iter l f = match l with
let rec iter f l = match l with
| [] -> ()
| (_, Leaf x) :: l' -> f x; iter l' f
| (_, t) :: l' -> iter_tree t f; iter l' f
| (_, Leaf x) :: l' -> f x; iter f l'
| (_, t) :: l' -> iter_tree t f; iter f l'
and iter_tree t f = match t with
| Leaf x -> f x
| Node (x, t1, t2) -> f x; iter_tree t1 f; iter_tree t2 f
let rec fold l acc f = match l with
let rec fold f acc l = match l with
| [] -> acc
| (_, Leaf x) :: l' -> fold l' (f acc x) f
| (_, Leaf x) :: l' -> fold f (f acc x) l'
| (_, t) :: l' ->
let acc' = fold_tree t acc f in
fold l' acc' f
fold f acc' l'
and fold_tree t acc f = match t with
| Leaf x -> f acc x
| Node (x, t1, t2) ->
@ -120,6 +153,27 @@ and fold_tree t acc f = match t with
let acc = fold_tree t1 acc f in
fold_tree t2 acc f
let rec fold_rev f acc l = match l with
| [] -> acc
| (_, Leaf x) :: l' -> f (fold f acc l') x
| (_, t) :: l' ->
let acc = fold_rev f acc l' in
fold_tree_rev t acc f
and fold_tree_rev t acc f = match t with
| Leaf x -> f acc x
| Node (x, t1, t2) ->
let acc = fold_tree_rev t2 acc f in
let acc = fold_tree_rev t1 acc f in
f acc x
let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1
let of_list l = List.fold_right cons l empty
let to_list l = List.rev (fold l [] (fun l x -> x :: l))
let rec of_list_map f l = match l with
| [] -> empty
| x::l' ->
let y = f x in
cons y (of_list_map f l')
let to_list l = List.rev (fold (fun l x -> x :: l) [] l)

View file

@ -43,13 +43,26 @@ val is_empty : _ t -> bool
val cons : 'a -> 'a t -> 'a t
(** Add an element at the front of the list *)
val return : 'a -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
(** Map on elements *)
val hd : 'a t -> 'a
(** First element of the list, or @raise Invalid_argument if the list is empty *)
(** First element of the list, or
@raise Invalid_argument if the list is empty *)
val tl : 'a t -> 'a t
(** Remove the first element from the list,
or @raise Invalid_argument if the list is empty *)
val front : 'a t -> ('a * 'a t) option
(** Remove and return the first element of the list *)
val front_exn : 'a t -> 'a * 'a t
(** Unsafe version of {!front}.
@raise Invalid_argument if the list is empty *)
val length : 'a t -> int
(** Number of elements *)
@ -61,13 +74,22 @@ val set : 'a t -> int -> 'a -> 'a t
(** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)).
@raise Invalid_argument if the list has less than [i+1] elements. *)
val iter : 'a t -> ('a -> unit) -> unit
val remove : 'a t -> int -> 'a t
(** [remove l i] removes the [i]-th element of [v].
@raise Invalid_argument if the list has less than [i+1] elements. *)
val append : 'a t -> 'a t -> 'a t
val iter : ('a -> unit) -> 'a t -> unit
(** Iterate on the list's elements *)
val fold : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
(** Fold on the list's elements *)
val of_list : 'a list -> 'a t
(** Convert a list to a RAL. {b Caution}: non tail-rec *)
val of_list_map : ('a -> 'b) -> 'a list -> 'b t
(** Combination of {!of_list} and {!map} *)
val to_list : 'a t -> 'a list

View file

@ -1,7 +1,7 @@
(* setup.ml generated for the first time by OASIS v0.4.4 *)
(* OASIS_START *)
(* DO NOT EDIT (digest: 467cad461ef31a16415d6790bdfffaea) *)
(* DO NOT EDIT (digest: baa9973b38a97689412be8397df50548) *)
(*
Regenerated by OASIS v0.4.4
Visit http://oasis.forge.ocamlcore.org for more information and
@ -6856,7 +6856,7 @@ let setup_t =
alpha_features = [];
beta_features = [];
name = "containers";
version = "0.3.1";
version = "0.3.3";
license =
OASISLicense.DEP5License
(OASISLicense.DEP5Unit
@ -7012,12 +7012,14 @@ let setup_t =
"CCPair";
"CCFun";
"CCHash";
"CCCat";
"CCKList";
"CCInt";
"CCBool";
"CCArray";
"CCBatch";
"CCOrd";
"CCIO";
"CCRandom";
"CCLinq";
"CCKTree";
@ -7170,7 +7172,7 @@ let setup_t =
bs_nativeopt = [(OASISExpr.EBool true, [])]
},
{
lib_modules = ["Future"];
lib_modules = ["CCFuture"];
lib_pack = false;
lib_internal_modules = [];
lib_findlib_parent = Some "containers";
@ -7739,7 +7741,7 @@ let setup_t =
};
oasis_fn = Some "_oasis";
oasis_version = "0.4.4";
oasis_digest = Some "r\029\246\250i\231\180\245`&\163\247h!\251b";
oasis_digest = Some ">\"\nZ{\234\192R\1690\0047v\140\218\145";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false
@ -7747,6 +7749,6 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
# 7751 "setup.ml"
# 7753 "setup.ml"
(* OASIS_STOP *)
let () = setup ();;

View file

@ -281,7 +281,7 @@ let imap_find m =
let icchashtbl_find m =
fun n ->
for i = 0 to n-1 do
ignore (ICCHashtbl.find_exn m i);
ignore (ICCHashtbl.get_exn i m);
done
let bench_maps3 () =

View file

@ -65,7 +65,6 @@ let test_bfs () =
()
let rec pp_path p =
let buf = Buffer.create 10 in
CCPrint.to_string (CCList.pp ~sep:"; " pp_edge) p
and pp_edge b (v1,e,v2) =
Printf.bprintf b "%d -> %d" v1 v2

View file

@ -1,4 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: adff855173c9b92b5478129af7d39e03)
Future
# DO NOT EDIT (digest: ede75f11c3857d71e591f7b889f4d09d)
CCFuture
# OASIS_STOP

View file

@ -1,4 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: adff855173c9b92b5478129af7d39e03)
Future
# DO NOT EDIT (digest: ede75f11c3857d71e591f7b889f4d09d)
CCFuture
# OASIS_STOP