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

Squashed 'sequence/' content from commit e5625c6

Browse source 
git-subtree-dir: sequence
git-subtree-split: e5625c69301e344abb971ad47ba618387346dc22
This commit is contained in:
Simon Cruanes 2014-08-08 20:16:15 +02:00
commit c8d834b722
32 changed files with 10804 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
.gitignore vendored Normal file
View file

@ -0,0 +1,9 @@
.*.swp
_build
*.native
*.docdir
*.html
man/
sequence.install
setup.log
setup.data

8
.merlin Normal file
View file

@ -0,0 +1,8 @@
S .
S bench/
S tests/
B _build
B _build/tests/
B _build/bench/
PKG oUnit
PKG benchmark

5
.ocamlinit Normal file
View file

@ -0,0 +1,5 @@
#directory "_build";;
#load "sequence.cma";;
open Sequence.Infix;;
(* vim:syntax=ocaml
*)

70
CHANGELOG.md Normal file
View file

@ -0,0 +1,70 @@
# Changelog
## 0.5.1
- `Sequence.IO` module, a very very simple way to read/write files
- options: `to_opt/of_opt/head/head_exn`
## 0.5
- conversion with `klist`
- add monadic, choice and applicative infix operators and `>|=`
- add several functions:
* `product2`
* `find`, `mem`
* `doubleton`, `cons`, `snoc`
* `drop_while`, `take_while`...
* `concat_str`
- aliases to existing functions
- use `delimcc` in a new module, `SequenceInvert`, in order to reverse the
control flow (here with conversion to Gen)
- fix examples, tests and doc (about `product`)
- reading benchmark for persistent sequences.
- replace `Bench` with `Benchmark`
## 0.4.1
- `persistent_lazy`
- use bin_annot
## 0.4
- API change for `persistent`
- more efficient implementation for `persistent`
- remove `TypeClass`
- API change for `min`/`max` (in case the sequence is empty)
- conversion with `Gen`
- use Oasis
## 0.3.7
- decreasing int range
- printing functions
## 0.3.6.1
- documentation
- bugfixes
## 0.3.6
- `fmap`
- functors to adapt `Set` and `Map`
## 0.3.5
- tests and benchmarks
- `join` combinator
- optimization for `Sequence.persistent`
## 0.3.4
- `sort`, `uniq`, `group` and `sort_uniq` combinators implemented
- some conversion functions that use `Sequence.t2`
- infix operators in `Sequence.Infix`
- `Sequence.t2` type for efficient iteration on pairs of elements
- some combinators are adapted to `Sequence.t2`
- `zip`, `unzip` and `zip_i` to convert between `t` and `t2`
- added `scan` combinator
note: git log --no-merges previous_version..HEAD --pretty=%s

22
LICENSE Normal file
View file

@ -0,0 +1,22 @@
Copyright (c) 2012, 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.

21
META Normal file
View file

@ -0,0 +1,21 @@
# OASIS_START
# DO NOT EDIT (digest: 3b9ebef180f5e4bdb720d2103ba95667)
version = "0.5.1"
description = "Simple sequence (iterator) datatype and combinators"
archive(byte) = "sequence.cma"
archive(byte, plugin) = "sequence.cma"
archive(native) = "sequence.cmxa"
archive(native, plugin) = "sequence.cmxs"
exists_if = "sequence.cma"
package "invert" (
version = "0.5.1"
description = "Simple sequence (iterator) datatype and combinators"
requires = "sequence delimcc"
archive(byte) = "invert.cma"
archive(byte, plugin) = "invert.cma"
archive(native) = "invert.cmxa"
archive(native, plugin) = "invert.cmxs"
exists_if = "invert.cma"
)
# OASIS_STOP

67
Makefile Normal file
View file

@ -0,0 +1,67 @@
# OASIS_START
# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954)
SETUP = ocaml setup.ml
build: setup.data
$(SETUP) -build $(BUILDFLAGS)
doc: setup.data build
$(SETUP) -doc $(DOCFLAGS)
test: setup.data build
$(SETUP) -test $(TESTFLAGS)
all:
$(SETUP) -all $(ALLFLAGS)
install: setup.data
$(SETUP) -install $(INSTALLFLAGS)
uninstall: setup.data
$(SETUP) -uninstall $(UNINSTALLFLAGS)
reinstall: setup.data
$(SETUP) -reinstall $(REINSTALLFLAGS)
clean:
$(SETUP) -clean $(CLEANFLAGS)
distclean:
$(SETUP) -distclean $(DISTCLEANFLAGS)
setup.data:
$(SETUP) -configure $(CONFIGUREFLAGS)
configure:
$(SETUP) -configure $(CONFIGUREFLAGS)
.PHONY: build doc test all install uninstall reinstall clean distclean configure
# OASIS_STOP
run-tests:
./run_tests.native
examples:
ocamlbuild examples/test_sexpr.native
push_doc: all doc
scp -r sequence.docdir/* cedeela.fr:~/simon/root/software/sequence/
push_stable: all
git checkout stable
git merge master -m 'merge from master'
oasis setup
git commit -a -m 'oasis files'
git push origin
git checkout master
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: benchs tests examples update_next_tag push_doc push_stable

50
README.md Normal file
View file

@ -0,0 +1,50 @@
Sequence
========
Simple sequence abstract datatype, intended to transfer a finite number of
elements from one data structure to another. Some transformations on sequences,
like `filter`, `map`, `take`, `drop` and `append` can be performed before the
sequence is iterated/folded on.
Sequence is not designed to be as general-purpose or flexible as, say,
Batteries' `Enum.t`. Rather, it aims at providing a very simple and efficient
way of iterating on a finite number of values, only allocating (most of the time)
one intermediate closure to do so. For instance, iterating on keys, or values,
of a `Hashtbl.t`, without creating a list.
Documentation
=============
See [the online API](http://cedeela.fr/~simon/software/sequence/Sequence.html).
Build
=====
1. via opam `opam install sequence`
2. manually (need OCaml >= 3.12): `make all install`
If you have `OUnit` installed, you can build and run tests with
$ make tests
$ ./run_tests.native
If you have `Bench` installed, you can build and run benchmarks with
$ make benchs
$ ./benchs.native
To see how to use the library, check the `examples` directory.
`tests.ml` has a few examples of how to convert basic data structures into
sequences, and conversely.
Examples
========
The module `examples/sexpr.mli` exposes the interface of the S-expression
example library. It requires OCaml>=4.0 to compile, because of the GADT
structure used in the monadic parser combinators part of `examples/sexpr.ml`.
License
=======
Sequence is available under the BSD license.

88
_oasis Normal file
View file

@ -0,0 +1,88 @@
OASISFormat: 0.4
Name: sequence
Version: 0.5.1
Homepage: https://github.com/c-cube/sequence
Authors: Simon Cruanes
License: BSD-2-clause
LicenseFile: LICENSE
Plugins: META (0.3), DevFiles (0.3)
BuildTools: ocamlbuild
Synopsis: Simple sequence (iterator) datatype and combinators
Description:
Simple sequence datatype, intended to transfer a finite number of
elements from one data structure to another. Some transformations on sequences,
like `filter`, `map`, `take`, `drop` and `append` can be performed before the
sequence is iterated/folded on.
Flag bench
Description: enable benchmarks (require library Benchmark)
Default: false
Flag invert
Description: build sequence.invert (requires Delimcc)
Default: false
Library "sequence"
Path: .
Modules: Sequence
Library "invert"
Path: invert
Build$: flag(invert)
Install$: flag(invert)
Modules: SequenceInvert
FindlibName: invert
FindlibParent: sequence
BuildDepends: sequence,delimcc
Document sequence
Title: Sequence docs
Type: ocamlbuild (0.3)
BuildTools+: ocamldoc
Install: true
XOCamlbuildPath: .
XOCamlbuildLibraries: sequence
Test all
Type: custom
Command: make run-tests
TestTools: run_tests
Run$: flag(tests)
Executable run_tests
Path: tests/
Install: false
CompiledObject: native
MainIs: run_tests.ml
Build$: flag(tests)
BuildDepends: sequence,oUnit
Executable benchs
Path: bench
Install: false
CompiledObject: native
Build$: flag(bench)
BuildDepends: sequence,benchmark
MainIs: benchs.ml
Executable bench_persistent
Path: bench
Install: false
CompiledObject: native
Build$: flag(bench)
BuildDepends: sequence,benchmark
MainIs: bench_persistent.ml
Executable bench_persistent_read
Path: bench
Install: false
CompiledObject: native
Build$: flag(bench)
BuildDepends: sequence,benchmark
MainIs: bench_persistent_read.ml
SourceRepository head
Type: git
Location: https://github.com/c-cube/sequence
Browser: https://github.com/c-cube/sequence/tree/master/src

39
_tags Normal file
View file

@ -0,0 +1,39 @@
# OASIS_START
# DO NOT EDIT (digest: e8d5fe31ff471d3c0ec54943fe50d011)
# Ignore VCS directories, you can use the same kind of rule outside
# OASIS_START/STOP if you want to exclude directories that contains
# useless stuff for the build process
<**/.svn>: -traverse
<**/.svn>: not_hygienic
".bzr": -traverse
".bzr": not_hygienic
".hg": -traverse
".hg": not_hygienic
".git": -traverse
".git": not_hygienic
"_darcs": -traverse
"_darcs": not_hygienic
# Library sequence
"sequence.cmxs": use_sequence
# Library invert
"invert/invert.cmxs": use_invert
<invert/*.ml{,i}>: pkg_delimcc
<invert/*.ml{,i}>: use_sequence
# Executable run_tests
"tests/run_tests.native": pkg_oUnit
"tests/run_tests.native": use_sequence
<tests/*.ml{,i}>: pkg_oUnit
<tests/*.ml{,i}>: use_sequence
# Executable benchs
"bench/benchs.native": pkg_benchmark
"bench/benchs.native": use_sequence
# Executable bench_persistent
"bench/bench_persistent.native": pkg_benchmark
"bench/bench_persistent.native": use_sequence
# Executable bench_persistent_read
"bench/bench_persistent_read.native": pkg_benchmark
"bench/bench_persistent_read.native": use_sequence
<bench/*.ml{,i}>: pkg_benchmark
<bench/*.ml{,i}>: use_sequence
# OASIS_STOP
true: bin_annot

128
bench/bench_persistent.ml Normal file
View file

@ -0,0 +1,128 @@
module MList = struct
type 'a t = {
content : 'a array; (* elements of the node *)
mutable len : int; (* number of elements in content *)
mutable tl : 'a t; (* tail *)
} (** A list that contains some elements, and may point to another list *)
let _empty () : 'a t = Obj.magic 0
(** Empty list, for the tl field *)
let make n =
assert (n > 0);
{ content = Array.make n (Obj.magic 0);
len = 0;
tl = _empty ();
}
let rec is_empty l =
l.len = 0 && (l.tl == _empty () || is_empty l.tl)
let rec iter f l =
for i = 0 to l.len - 1 do f l.content.(i); done;
if l.tl != _empty () then iter f l.tl
let iteri f l =
let rec iteri i f l =
for j = 0 to l.len - 1 do f (i+j) l.content.(j); done;
if l.tl != _empty () then iteri (i+l.len) f l.tl
in iteri 0 f l
let rec iter_rev f l =
(if l.tl != _empty () then iter_rev f l.tl);
for i = l.len - 1 downto 0 do f l.content.(i); done
let length l =
let rec len acc l =
if l.tl == _empty () then acc+l.len else len (acc+l.len) l.tl
in len 0 l
(** Get element by index *)
let rec get l i =
if i < l.len then l.content.(i)
else if i >= l.len && l.tl == _empty () then raise (Invalid_argument "MList.get")
else get l.tl (i - l.len)
(** Push [x] at the end of the list. It returns the block in which the
element is inserted. *)
let rec push x l =
if l.len = Array.length l.content
then begin (* insert in the next block *)
(if l.tl == _empty () then
let n = Array.length l.content in
l.tl <- make (n + n lsr 1));
push x l.tl
end else begin (* insert in l *)
l.content.(l.len) <- x;
l.len <- l.len + 1;
l
end
(** Reverse list (in place), and returns the new head *)
let rev l =
let rec rev prev l =
(* reverse array *)
for i = 0 to (l.len-1) / 2 do
let x = l.content.(i) in
l.content.(i) <- l.content.(l.len - i - 1);
l.content.(l.len - i - 1) <- x;
done;
(* reverse next block *)
let l' = l.tl in
l.tl <- prev;
if l' == _empty () then l else rev l l'
in
rev (_empty ()) l
(** Build a MList of elements of the Seq. The optional argument indicates
the size of the blocks *)
let of_seq ?(size=8) seq =
(* read sequence into a MList.t *)
let start = make size in
let l = ref start in
seq (fun x -> l := push x !l);
start
let to_seq l =
fun k -> iter k l
end
(** Store content of the seqerator in an enum *)
let persistent_mlist seq =
let l = MList.of_seq seq in
MList.to_seq l
let bench_mlist n =
for i = 0 to 100 do
let _ = persistent_mlist Sequence.(1 -- n) in
()
done
let bench_naive n =
for i = 0 to 100 do
let l = Sequence.to_rev_list Sequence.(1 -- n) in
let _ = Sequence.of_list (List.rev l) in
()
done
let bench_current n =
for i = 0 to 100 do
let _ = Sequence.persistent Sequence.(1 -- n) in
()
done
let () =
let bench_n n =
Printf.printf "BENCH for %d\n" n;
let res = Benchmark.throughputN 5
[ "mlist", bench_mlist, n
; "naive", bench_naive, n
; "current", bench_current, n
]
in Benchmark.tabulate res
in
bench_n 100;
bench_n 100_000;
()
(* vim:Use benchmark: *)

139
bench/bench_persistent_read.ml Normal file
View file

@ -0,0 +1,139 @@
module MList = struct
type 'a t = {
content : 'a array; (* elements of the node *)
mutable len : int; (* number of elements in content *)
mutable tl : 'a t; (* tail *)
} (** A list that contains some elements, and may point to another list *)
let _empty () : 'a t = Obj.magic 0
(** Empty list, for the tl field *)
let make n =
assert (n > 0);
{ content = Array.make n (Obj.magic 0);
len = 0;
tl = _empty ();
}
let rec is_empty l =
l.len = 0 && (l.tl == _empty () || is_empty l.tl)
let rec iter f l =
for i = 0 to l.len - 1 do f l.content.(i); done;
if l.tl != _empty () then iter f l.tl
let iteri f l =
let rec iteri i f l =
for j = 0 to l.len - 1 do f (i+j) l.content.(j); done;
if l.tl != _empty () then iteri (i+l.len) f l.tl
in iteri 0 f l
let rec iter_rev f l =
(if l.tl != _empty () then iter_rev f l.tl);
for i = l.len - 1 downto 0 do f l.content.(i); done
let length l =
let rec len acc l =
if l.tl == _empty () then acc+l.len else len (acc+l.len) l.tl
in len 0 l
(** Get element by index *)
let rec get l i =
if i < l.len then l.content.(i)
else if i >= l.len && l.tl == _empty () then raise (Invalid_argument "MList.get")
else get l.tl (i - l.len)
(** Push [x] at the end of the list. It returns the block in which the
element is inserted. *)
let rec push x l =
if l.len = Array.length l.content
then begin (* insert in the next block *)
(if l.tl == _empty () then
let n = Array.length l.content in
l.tl <- make (n + n lsr 1));
push x l.tl
end else begin (* insert in l *)
l.content.(l.len) <- x;
l.len <- l.len + 1;
l
end
(** Reverse list (in place), and returns the new head *)
let rev l =
let rec rev prev l =
(* reverse array *)
for i = 0 to (l.len-1) / 2 do
let x = l.content.(i) in
l.content.(i) <- l.content.(l.len - i - 1);
l.content.(l.len - i - 1) <- x;
done;
(* reverse next block *)
let l' = l.tl in
l.tl <- prev;
if l' == _empty () then l else rev l l'
in
rev (_empty ()) l
(** Build a MList of elements of the Seq. The optional argument indicates
the size of the blocks *)
let of_seq ?(size=8) seq =
(* read sequence into a MList.t *)
let start = make size in
let l = ref start in
seq (fun x -> l := push x !l);
start
let to_seq l =
fun k -> iter k l
end
(** Store content of the seqerator in an enum *)
let persistent_mlist seq =
let l = MList.of_seq seq in
MList.to_seq l
let bench_mlist n =
persistent_mlist Sequence.(1 -- n)
let bench_list n =
let l = Sequence.to_rev_list Sequence.(1 -- n) in
Sequence.of_list (List.rev l)
let bench_naive n =
let s = Sequence.(1 -- n) in
Sequence.iter ignore s ;
s
let bench_current n =
Sequence.persistent Sequence.(1 -- n)
let bench_array n =
let a = Sequence.to_array Sequence.(1 -- n) in
Sequence.of_array a
let read s =
Sequence.map (fun x -> x + 1) s
let () =
let bench_n n =
Printf.printf "BENCH for %d\n" n;
let res =
let mlist = bench_mlist n in
let list = bench_list n in
let current = bench_current n in
let array = bench_current n in
let naive = bench_naive n in
Benchmark.throughputN 5
[ "mlist", read, mlist
; "list", read, list
; "current", read, current
; "array", read, array
; "naive", read, naive
]
in Benchmark.tabulate res
in
bench_n 100;
bench_n 100_000;
()
(* vim:Use benchmark: *)

34
bench/benchs.ml Normal file
View file

@ -0,0 +1,34 @@
module S = Sequence
open Sequence.Infix
let small = [10;20;50;100;500]
let medium = small @ [1000;10_000;100_000]
let big = medium @ [500_000; 1_000_000; 2_000_000]
let bench_fold n =
0 -- n |> S.fold (+) 0 |> ignore
let bench_flatmap n =
0 -- n |> S.flatMap (fun i -> i -- (i+5)) |> (fun _ -> ())
let bench_product n =
S.product (0 -- n) (0 -- n) (fun (i,j) -> ())
let _ =
List.iter
(fun (name,bench,sizes) ->
Format.printf "-------------------------------------------------------@.";
Format.printf "bench %s@." name;
List.iter
(fun n ->
let name = name ^ " on " ^ string_of_int n in
let res = Benchmark.throughput1 2 ~name bench n in
Benchmark.tabulate res;
) sizes
)
[ "fold", bench_fold, big
; "flatmap", bench_flatmap, medium
; "product", bench_product, small
];
()

11
bench/simple_bench.ml Normal file
View file

@ -0,0 +1,11 @@
open Sequence.Infix
let _ =
let n = int_of_string Sys.argv.(1) in
let seq = 0 -- n in
let start = Unix.gettimeofday () in
seq |> Sequence.persistent |> Sequence.fold (+) 0 |> ignore;
let stop = Unix.gettimeofday () in
Format.printf "iter on %d: %.4f@." n (stop -. start);
()

27
configure vendored Executable file
View file

@ -0,0 +1,27 @@
#!/bin/sh
# OASIS_START
# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499)
set -e
FST=true
for i in "$@"; do
if $FST; then
set --
FST=false
fi
case $i in
--*=*)
ARG=${i%%=*}
VAL=${i##*=}
set -- "$@" "$ARG" "$VAL"
;;
*)
set -- "$@" "$i"
;;
esac
done
ocaml setup.ml -configure "$@"
# OASIS_STOP

305
examples/sexpr.ml Normal file
View file

@ -0,0 +1,305 @@
(*
Zipperposition: a functional superposition prover for prototyping
Copyright (C) 2012 Simon Cruanes
This is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301 USA.
*)
(* {1 Basic S-expressions, with printing and parsing} *)
(** S-expression *)
type t =
| Atom of string (** An atom *)
| List of t list (** A list of S-expressions *)
(** Token that compose a Sexpr once serialized *)
type token = [`Open | `Close | `Atom of string]
(** {2 Traverse a sequence of tokens} *)
(** Iterate on the S-expression, calling the callback with tokens *)
let rec iter f s = match s with
| Atom a -> f (`Atom a)
| List l -> f `Open; iter_list f l; f `Close
and iter_list f l = match l with
| [] -> ()
| x::l' -> iter f x; iter_list f l'
(** Traverse. This yields a sequence of tokens *)
let traverse s = Sequence.from_iter (fun k -> iter k s)
(** Returns the same sequence of tokens, but during iteration, if
the structure of the Sexpr corresponding to the sequence
is wrong (bad parenthesing), Invalid_argument is raised
and iteration is stoped *)
let validate seq =
let depth = ref 0 in
Sequence.map
(fun tok -> match tok with
| `Open -> incr depth; tok
| `Close -> if !depth = 0
then raise (Invalid_argument "wrong parenthesing")
else decr depth; tok
| _ -> tok)
seq
(** {2 Text <-> tokens} *)
(** Lex: create a sequence of tokens from the given in_channel. *)
let lex input =
let seq_fun k =
let in_word = ref false in
let buf = Buffer.create 128 in
(* loop. TODO handle escaping of (), and "" *)
let rec next c =
match c with
| '(' -> k `Open
| ')' -> flush_word(); k `Close
| ' ' | '\t' | '\n' -> flush_word ()
| c -> in_word := true; Buffer.add_char buf c
(* finish the previous word token *)
and flush_word () =
if !in_word then begin
(* this whitespace follows a word *)
let word = Buffer.contents buf in
Buffer.clear buf;
in_word := false;
k (`Atom word)
end
in
Sequence.iter next input
in
Sequence.from_iter seq_fun
(** Build a Sexpr from a sequence of tokens *)
let of_seq seq =
(* called on every token *)
let rec k stack token = match token with
| `Open -> `Open :: stack
| `Close -> collapse [] stack
| `Atom a -> (`Expr (Atom a)) :: stack
(* collapse last list into an `Expr *)
and collapse acc stack = match stack with
| `Open::stack' -> `Expr (List acc) :: stack'
| `Expr a::stack' -> collapse (a :: acc) stack'
| _ -> assert false
in
(* iterate on the sequence, given an empty initial stack *)
let stack = Sequence.fold k [] seq in
(* stack should contain exactly one expression *)
match stack with
| [`Expr expr] -> expr
| [] -> failwith "no Sexpr could be parsed"
| _ -> failwith "too many elements on the stack"
(** {2 Printing} *)
(** Print a token on the given formatter *)
let pp_token formatter token = match token with
| `Open -> Format.fprintf formatter "@[("
| `Close -> Format.fprintf formatter ")@]"
| `Atom s -> Format.pp_print_string formatter s
(** Print a sequence of Sexpr tokens on the given formatter *)
let pp_tokens formatter tokens =
let first = ref true in
let last = ref false in
Sequence.iter
(fun token ->
(match token with
| `Open -> (if not !first then Format.fprintf formatter " "); first := true
| `Close -> first := false; last := true
| _ -> if !first then first := false else Format.fprintf formatter " ");
pp_token formatter token;
if !last then last := false)
tokens
(** Pretty-print the S-expr. If [indent] is true, the S-expression
is printed with indentation. *)
let pp_sexpr ?(indent=false) formatter s =
if indent
then Format.fprintf formatter "@[<hov 4>%a@]" pp_tokens (traverse s)
else pp_tokens formatter (traverse s)
(** {2 Serializing} *)
let output_seq name subexpr k =
k `Open;
k (`Atom name);
Sequence.iter k subexpr;
k `Close
let output_str name str k =
k `Open;
k (`Atom name);
k (`Atom str);
k `Close
(** {2 Parsing} *)
(** Monadic combinators for parsing data from a sequence of tokens,
without converting to concrete S-expressions.
The [one] parser can raise ParseFailure if it fails to parse
the atomic type. *)
(** parser that returns a 'a *)
type 'a parser =
| Return : 'a -> 'a parser
| One : (token -> 'a) -> 'a parser
| Zero : (token -> 'a parser) -> 'a parser
(* | Maybe of (token -> 'a option) *)
| Bind : ('b parser * ('b -> 'a parser)) -> 'a parser
| Fail : string -> 'a parser
exception ParseFailure of string
let (>>=) p f = Bind (p, f)
let (>>) p p' = p >>= fun _ -> p'
let return x = Return x
let fail reason = Fail reason
let one f = One f
let skip = One (fun _ -> ())
let lookahead f = Zero f
let left = One (function | `Open -> ()
| _ -> raise (ParseFailure "expected '('"))
let right = One (function | `Close -> ()
| _ -> raise (ParseFailure "expected ')'"))
let pair f g =
f >>= fun x ->
g >>= fun y ->
return (x, y)
let triple f g h =
f >>= fun x ->
g >>= fun y ->
h >>= fun z ->
return (x, y, z)
(** [(name,p) ^|| p'] behaves as p if the next token is [`Atom name], and
like [p'] otherwise *)
let (^||) (name,p) p' =
lookahead
(fun token -> match token with
| `Atom s when s = name -> skip >> p ()
| _ -> p')
(** Maps the value returned by the parser *)
let map p f = p >>= fun x -> return (f x)
let p_str = one
(function | `Atom s -> s | _ -> raise (ParseFailure "expected string"))
let p_int = one
(function | `Atom s -> (try int_of_string s
with Failure _ -> raise (ParseFailure "expected int"))
| _ -> raise (ParseFailure "expected int"))
let p_bool = one
(function | `Atom s -> (try bool_of_string s
with Failure _ -> raise (ParseFailure "expected bool"))
| _ -> raise (ParseFailure "expected bool"))
let p_float = one
(function | `Atom s -> (try float_of_string s
with Failure _ -> raise (ParseFailure "expected float"))
| _ -> raise (ParseFailure "expected float"))
let many p =
let rec elements token =
match token with
| `Close -> return []
| _ ->
p >>= fun x ->
lookahead elements >>= fun l ->
return (x :: l)
in
left >> lookahead elements >>= fun l -> right >> return l
let many1 p =
p >>= fun x ->
many p >>= fun l ->
return (x::l)
(** parsing state that returns a 'a *)
type 'a state =
| Bottom : 'a state
| Push : ('b parser * ('b -> 'a state)) -> 'a state
(** Actually parse the sequence of tokens, with a callback to be called
on every parsed value. The callback decides whether to push another
state or whether to continue. *)
let parse_k p tokens k =
let rec state = Push(p, fun x -> match k x with `Stop -> Bottom | `Continue -> state) in
(* Token handler. It also takes the current parser. *)
let rec one_step state token =
match reduce state with
| Bottom -> (* should not happen, unless there are too many tokens *)
raise (ParseFailure "unexpected ')'")
| Push (Return _, cont) ->
assert false (* should be reduced *)
| Push (Zero f, cont) ->
let p' = f token in
let state' = Push (p', cont) in
one_step state' token (* do not consume token *)
| Push (One f, cont) ->
let x = f token in
let state' = cont x in
reduce state' (* consume token *)
(* | Maybe f, _ -> let x = f token in (Obj.magic cont) x *)
| Push (Bind (p', cont'), cont) ->
let cont'' x =
let p'' = cont' x in
Push (p'', cont)
in
let state' = Push (p', cont'') in
one_step state' token (* do not consume token *)
| Push (Fail reason, _) -> raise (ParseFailure reason)
(* Reduce parser state *)
and reduce state = match state with
| Push (Return x, cont) ->
let state' = cont x in
reduce state'
| _ -> state
in
(* iterate on the tokens *)
ignore (Sequence.fold one_step state tokens)
(** Parse one value *)
let parse p tokens =
let res = ref None in
parse_k p tokens (fun x -> res := Some x; `Stop);
(* return result *)
match !res with
| None -> raise (ParseFailure "incomplete input")
| Some x -> x
(** Parse a sequence of values *)
let parse_seq p tokens =
let seq_fun k =
parse_k p tokens (fun x -> k x; `Continue)
in
Sequence.from_iter seq_fun

132
examples/sexpr.mli Normal file
View file

@ -0,0 +1,132 @@
(*
Zipperposition: a functional superposition prover for prototyping
Copyright (C) 2012 Simon Cruanes
This is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301 USA.
*)
(* {1 Basic S-expressions, with printing and parsing} *)
type t =
| Atom of string (** An atom *)
| List of t list (** A list of S-expressions *)
(** S-expression *)
type token = [`Open | `Close | `Atom of string]
(** Token that compose a Sexpr once serialized *)
(** {2 Traverse a sequence of tokens} *)
val iter : (token -> unit) -> t -> unit
(** Iterate on the S-expression, calling the callback with tokens *)
val traverse : t -> token Sequence.t
(** Traverse. This yields a sequence of tokens *)
val validate : token Sequence.t -> token Sequence.t
(** Returns the same sequence of tokens, but during iteration, if
the structure of the Sexpr corresponding to the sequence
is wrong (bad parenthesing), Invalid_argument is raised
and iteration is stoped *)
(** {2 Text <-> tokens} *)
val lex : char Sequence.t -> token Sequence.t
(** Lex: create a sequence of tokens from the given sequence of chars. *)
val of_seq : token Sequence.t -> t
(** Build a Sexpr from a sequence of tokens, or raise Failure *)
(** {2 Printing} *)
val pp_token : Format.formatter -> token -> unit
(** Print a token on the given formatter *)
val pp_tokens : Format.formatter -> token Sequence.t -> unit
(** Print a sequence of Sexpr tokens on the given formatter *)
val pp_sexpr : ?indent:bool -> Format.formatter -> t -> unit
(** Pretty-print the S-expr. If [indent] is true, the S-expression
is printed with indentation. *)
(** {2 Serializing} *)
val output_seq : string -> token Sequence.t -> (token -> unit) -> unit
(** print a pair "(name @,sequence)" *)
val output_str : string -> string -> (token -> unit) -> unit
(** print a pair "(name str)" *)
(** {2 Parsing} *)
(** Monadic combinators for parsing data from a sequence of tokens,
without converting to concrete S-expressions. *)
type 'a parser
exception ParseFailure of string
val (>>=) : 'a parser -> ('a -> 'b parser) -> 'b parser
(** Monadic bind: computes a parser from the result of
the first parser *)
val (>>) : 'a parser -> 'b parser -> 'b parser
(** Like (>>=), but ignores the result of the first parser *)
val return : 'a -> 'a parser
(** Parser that consumes no input and return the given value *)
val fail : string -> 'a parser
(** Fails parsing with the given message *)
val one : (token -> 'a) -> 'a parser
(** consumes one token with the function *)
val skip : unit parser
(** Skip the token *)
val lookahead : (token -> 'a parser) -> 'a parser
(** choose parser given current token *)
val left : unit parser
(** Parses a `Open *)
val right : unit parser
(** Parses a `Close *)
val pair : 'a parser -> 'b parser -> ('a * 'b) parser
val triple : 'a parser -> 'b parser -> 'c parser -> ('a * 'b * 'c) parser
val (^||) : (string * (unit -> 'a parser)) -> 'a parser -> 'a parser
(** [(name,p) ^|| p'] behaves as [p ()] if the next token is [`Atom name], and
like [p'] otherwise *)
val map : 'a parser -> ('a -> 'b) -> 'b parser
(** Maps the value returned by the parser *)
val p_str : string parser
val p_int : int parser
val p_bool : bool parser
val many : 'a parser -> 'a list parser
val many1 : 'a parser -> 'a list parser
val parse : 'a parser -> token Sequence.t -> 'a
(** Parses exactly one value from the sequence of tokens. Raises
ParseFailure if anything goes wrong. *)
val parse_seq : 'a parser -> token Sequence.t -> 'a Sequence.t
(** Parses a sequence of values *)

131
examples/test_sexpr.ml Normal file
View file

@ -0,0 +1,131 @@
(** {2 Test sequences} *)
(** print a list of items using the printing function *)
let pp_list ?(sep=", ") pp_item formatter l =
Sequence.pp_seq ~sep pp_item formatter (Sequence.of_list l)
(** Set of integers *)
module ISet = Set.Make(struct type t = int let compare = compare end)
let iset = (module ISet : Set.S with type elt = int and type t = ISet.t)
module OrderedString = struct type t = string let compare = compare end
module SMap = Sequence.Map.Make(OrderedString)
let my_map = SMap.of_seq (Sequence.of_list ["1", 1; "2", 2; "3", 3; "answer", 42])
let sexpr = "(foo bar (bazz quux hello 42) world (zoo foo bar (1 2 (3 4))))"
type term = | Lambda of term | Const of string | Var of int | Apply of term * term
let random_term () =
let max = 10
and num = ref 0 in
let rec build depth =
if depth > 4 || !num > max then Const (random_const ()) else
match Random.int 6 with
| 0 -> if depth > 0 then Var (Random.int depth) else Const (random_const ())
| 1 -> incr num; Lambda (build (depth+1))
| 2 -> Const (random_const ())
| _ -> incr num; Apply ((build depth), (build depth))
and random_const () = [|"a"; "b"; "c"; "f"; "g"; "h"|].(Random.int 6)
in build 0
let rec sexpr_of_term t =
let f t k = match t with
| Var i -> Sexpr.output_str "var" (string_of_int i) k
| Lambda t' -> Sexpr.output_seq "lambda" (sexpr_of_term t') k
| Apply (t1, t2) -> Sexpr.output_seq "apply" (Sequence.append (sexpr_of_term t1) (sexpr_of_term t2)) k
| Const s -> Sexpr.output_str "const" s k
in Sequence.from_iter (f t)
let term_parser =
let open Sexpr in
let rec p_term () =
left >>
(("lambda", p_lambda) ^|| ("var", p_var) ^|| ("const", p_const) ^||
("apply", p_apply) ^|| fail "bad term") >>= fun x ->
right >> return x
and p_apply () =
p_term () >>= fun x ->
p_term () >>= fun y ->
return (Apply (x,y))
and p_var () = p_int >>= fun i -> return (Var i)
and p_const () = p_str >>= fun s -> return (Const s)
and p_lambda () = p_term () >>= fun t -> return (Lambda t)
in p_term ()
let term_of_sexp seq = Sexpr.parse term_parser seq
let test_term () =
let t = random_term () in
Format.printf "@[<h>random term: %a@]@." Sexpr.pp_tokens (sexpr_of_term t);
let tokens = sexpr_of_term t in
let t' = term_of_sexp tokens in
Format.printf "@[<h>parsed: %a@]@." Sexpr.pp_tokens (sexpr_of_term t');
()
let _ =
(* lists *)
let l = [0;1;2;3;4;5;6] in
let l' = Sequence.to_list
(Sequence.filter (fun x -> x mod 2 = 0) (Sequence.of_list l)) in
let l'' = Sequence.to_list
(Sequence.take 3 (Sequence.drop 1 (Sequence.of_list l))) in
let h = Hashtbl.create 3 in
for i = 0 to 5 do
Hashtbl.add h i (i*i);
done;
let l2 = Sequence.to_list
(Sequence.map (fun (x, y) -> (string_of_int x) ^ " -> " ^ (string_of_int y))
(Sequence.of_hashtbl h))
in
let l3 = Sequence.to_list (Sequence.rev (Sequence.int_range ~start:0 ~stop:42)) in
let set = List.fold_left (fun set x -> ISet.add x set) ISet.empty [4;3;100;42] in
let l4 = Sequence.to_list (Sequence.of_set iset set) in
Format.printf "l=@[<h>[%a]@]@." (pp_list Format.pp_print_int) l;
Format.printf "l'=@[<h>[%a]@]@." (pp_list Format.pp_print_int) l';
Format.printf "l''=@[<h>[%a]@]@." (pp_list Format.pp_print_int) l'';
Format.printf "l2=@[<h>[%a]@]@." (pp_list Format.pp_print_string) l2;
Format.printf "l3=@[<h>[%a]@]@." (pp_list Format.pp_print_int) l3;
Format.printf "s={@[<h>%a@]}@." (Sequence.pp_seq Format.pp_print_int) (Sequence.of_set iset set);
Format.printf "l4=@[<h>[%a]@]@." (pp_list Format.pp_print_int) l4;
Format.printf "l3[:5]+l4=@[<h>[%a]@]@." (Sequence.pp_seq Format.pp_print_int)
(Sequence.of_array
(Sequence.to_array (Sequence.append
(Sequence.take 5 (Sequence.of_list l3)) (Sequence.of_list l4))));
(* sequence, persistent, etc *)
let seq = Sequence.int_range ~start:0 ~stop:100000 in
let seq' = Sequence.persistent seq in
let stream = Sequence.to_stream seq' in
Format.printf "test length [0..100000]: persistent1 %d, stream %d, persistent2 %d"
(Sequence.length seq') (Sequence.length (Sequence.of_stream stream)) (Sequence.length seq');
(* maps *)
Format.printf "@[<h>map: %a@]@."
(Sequence.pp_seq (fun formatter (k,v) -> Format.fprintf formatter "\"%s\" -> %d" k v))
(SMap.to_seq my_map);
let module MyMapSeq = Sequence.Map.Adapt(Map.Make(OrderedString)) in
let my_map' = MyMapSeq.of_seq (Sequence.of_list ["1", 1; "2", 2; "3", 3; "answer", 42]) in
Format.printf "@[<h>map: %a@]@."
(Sequence.pp_seq (fun formatter (k,v) -> Format.fprintf formatter "\"%s\" -> %d" k v))
(MyMapSeq.to_seq my_map');
(* sum *)
let n = 1000000 in
let sum = Sequence.fold (+) 0 (Sequence.take n (Sequence.repeat 1)) in
Format.printf "%dx1 = %d@." n sum;
assert (n=sum);
(* sexpr *)
let s = Sexpr.of_seq (Sexpr.lex (Sequence.of_str sexpr)) in
let s = Sexpr.of_seq (Sequence.map
(function | `Atom s -> `Atom (String.capitalize s) | tok -> tok)
(Sexpr.traverse s))
in
Format.printf "@[<hov2>transform @[<h>%s@] into @[<h>%a@]@]@." sexpr (Sexpr.pp_sexpr ~indent:false) s;
Format.printf "@[<hv2> cycle:%a@]@." Sexpr.pp_tokens
(Sequence.concat (Sequence.take 10 (Sequence.repeat (Sexpr.traverse s))));
(* sexpr parsing/printing *)
for i = 0 to 20 do
Format.printf "%d-th term test@." i;
test_term ();
done;
()

2
invert/.merlin Normal file
View file

@ -0,0 +1,2 @@
REC
PKG delimcc

4
invert/invert.mldylib Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: d74492d261fcc87665b60e0331c04236)
SequenceInvert
# OASIS_STOP

4
invert/invert.mllib Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: d74492d261fcc87665b60e0331c04236)
SequenceInvert
# OASIS_STOP

62
invert/sequenceInvert.ml Normal file
View file

@ -0,0 +1,62 @@
(*
Copyright (c) 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 Interface to Delimcc (Invert control flow)} *)
type 'a gen = unit -> 'a option
type 'a res =
| Start
| Yield of 'a
| Stop
let _ret_none () = None
let _ret_unit () = ()
let to_gen seq =
let p = Delimcc.new_prompt () in
let _next = ref None in
ignore (Delimcc.push_prompt p
(fun () ->
Delimcc.take_subcont p (fun c () -> _next := Some c; Start);
seq
(fun x ->
Delimcc.take_subcont p (fun c () -> _next := Some c; Yield x)
);
_next := None;
Stop
));
(* call next subcont *)
let rec next () =
match !_next with
| None -> None
| Some f ->
begin match Delimcc.push_delim_subcont f _ret_unit with
| Start -> next ()
| Yield x -> Some x
| Stop -> None
end
in
next

32
invert/sequenceInvert.mli Normal file
View file

@ -0,0 +1,32 @@
(*
Copyright (c) 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 Interface to Delimcc (Invert control flow)} *)
type 'a gen = unit -> 'a option
val to_gen : 'a Sequence.t -> 'a gen
(** Use delimited continuations to iterate on the sequence step by step.
Relatively costly but still useful *)

610
myocamlbuild.ml Normal file
View file

@ -0,0 +1,610 @@
(* OASIS_START *)
(* DO NOT EDIT (digest: c4bb6d2ca42efb069d5612eb2bbcf244) *)
module OASISGettext = struct
(* # 22 "src/oasis/OASISGettext.ml" *)
let ns_ str =
str
let s_ str =
str
let f_ (str: ('a, 'b, 'c, 'd) format4) =
str
let fn_ fmt1 fmt2 n =
if n = 1 then
fmt1^^""
else
fmt2^^""
let init =
[]
end
module OASISExpr = struct
(* # 22 "src/oasis/OASISExpr.ml" *)
open OASISGettext
type test = string
type flag = string
type t =
| EBool of bool
| ENot of t
| EAnd of t * t
| EOr of t * t
| EFlag of flag
| ETest of test * string
type 'a choices = (t * 'a) list
let eval var_get t =
let rec eval' =
function
| EBool b ->
b
| ENot e ->
not (eval' e)
| EAnd (e1, e2) ->
(eval' e1) && (eval' e2)
| EOr (e1, e2) ->
(eval' e1) || (eval' e2)
| EFlag nm ->
let v =
var_get nm
in
assert(v = "true" || v = "false");
(v = "true")
| ETest (nm, vl) ->
let v =
var_get nm
in
(v = vl)
in
eval' t
let choose ?printer ?name var_get lst =
let rec choose_aux =
function
| (cond, vl) :: tl ->
if eval var_get cond then
vl
else
choose_aux tl
| [] ->
let str_lst =
if lst = [] then
s_ "<empty>"
else
String.concat
(s_ ", ")
(List.map
(fun (cond, vl) ->
match printer with
| Some p -> p vl
| None -> s_ "<no printer>")
lst)
in
match name with
| Some nm ->
failwith
(Printf.sprintf
(f_ "No result for the choice list '%s': %s")
nm str_lst)
| None ->
failwith
(Printf.sprintf
(f_ "No result for a choice list: %s")
str_lst)
in
choose_aux (List.rev lst)
end
# 132 "myocamlbuild.ml"
module BaseEnvLight = struct
(* # 22 "src/base/BaseEnvLight.ml" *)
module MapString = Map.Make(String)
type t = string MapString.t
let default_filename =
Filename.concat
(Sys.getcwd ())
"setup.data"
let load ?(allow_empty=false) ?(filename=default_filename) () =
if Sys.file_exists filename then
begin
let chn =
open_in_bin filename
in
let st =
Stream.of_channel chn
in
let line =
ref 1
in
let st_line =
Stream.from
(fun _ ->
try
match Stream.next st with
| '\n' -> incr line; Some '\n'
| c -> Some c
with Stream.Failure -> None)
in
let lexer =
Genlex.make_lexer ["="] st_line
in
let rec read_file mp =
match Stream.npeek 3 lexer with
| [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
Stream.junk lexer;
Stream.junk lexer;
Stream.junk lexer;
read_file (MapString.add nm value mp)
| [] ->
mp
| _ ->
failwith
(Printf.sprintf
"Malformed data file '%s' line %d"
filename !line)
in
let mp =
read_file MapString.empty
in
close_in chn;
mp
end
else if allow_empty then
begin
MapString.empty
end
else
begin
failwith
(Printf.sprintf
"Unable to load environment, the file '%s' doesn't exist."
filename)
end
let rec var_expand str env =
let buff =
Buffer.create ((String.length str) * 2)
in
Buffer.add_substitute
buff
(fun var ->
try
var_expand (MapString.find var env) env
with Not_found ->
failwith
(Printf.sprintf
"No variable %s defined when trying to expand %S."
var
str))
str;
Buffer.contents buff
let var_get name env =
var_expand (MapString.find name env) env
let var_choose lst env =
OASISExpr.choose
(fun nm -> var_get nm env)
lst
end
# 237 "myocamlbuild.ml"
module MyOCamlbuildFindlib = struct
(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
(** OCamlbuild extension, copied from
* http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
* by N. Pouillard and others
*
* Updated on 2009/02/28
*
* Modified by Sylvain Le Gall
*)
open Ocamlbuild_plugin
(* these functions are not really officially exported *)
let run_and_read =
Ocamlbuild_pack.My_unix.run_and_read
let blank_sep_strings =
Ocamlbuild_pack.Lexers.blank_sep_strings
let exec_from_conf exec =
let exec =
let env_filename = Pathname.basename BaseEnvLight.default_filename in
let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in
try
BaseEnvLight.var_get exec env
with Not_found ->
Printf.eprintf "W: Cannot get variable %s\n" exec;
exec
in
let fix_win32 str =
if Sys.os_type = "Win32" then begin
let buff = Buffer.create (String.length str) in
(* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'.
*)
String.iter
(fun c -> Buffer.add_char buff (if c = '\\' then '/' else c))
str;
Buffer.contents buff
end else begin
str
end
in
fix_win32 exec
let split s ch =
let buf = Buffer.create 13 in
let x = ref [] in
let flush () =
x := (Buffer.contents buf) :: !x;
Buffer.clear buf
in
String.iter
(fun c ->
if c = ch then
flush ()
else
Buffer.add_char buf c)
s;
flush ();
List.rev !x
let split_nl s = split s '\n'
let before_space s =
try
String.before s (String.index s ' ')
with Not_found -> s
(* ocamlfind command *)
let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x]
(* This lists all supported packages. *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
(* Mock to list available syntaxes. *)
let find_syntaxes () = ["camlp4o"; "camlp4r"]
let well_known_syntax = [
"camlp4.quotations.o";
"camlp4.quotations.r";
"camlp4.exceptiontracer";
"camlp4.extend";
"camlp4.foldgenerator";
"camlp4.listcomprehension";
"camlp4.locationstripper";
"camlp4.macro";
"camlp4.mapgenerator";
"camlp4.metagenerator";
"camlp4.profiler";
"camlp4.tracer"
]
let dispatch =
function
| After_options ->
(* By using Before_options one let command line options have an higher
* priority on the contrary using After_options will guarantee to have
* the higher priority override default commands by ocamlfind ones *)
Options.ocamlc := ocamlfind & A"ocamlc";
Options.ocamlopt := ocamlfind & A"ocamlopt";
Options.ocamldep := ocamlfind & A"ocamldep";
Options.ocamldoc := ocamlfind & A"ocamldoc";
Options.ocamlmktop := ocamlfind & A"ocamlmktop";
Options.ocamlmklib := ocamlfind & A"ocamlmklib"
| After_rules ->
(* When one link an OCaml library/binary/package, one should use
* -linkpkg *)
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter
begin fun pkg ->
let base_args = [A"-package"; A pkg] in
(* TODO: consider how to really choose camlp4o or camlp4r. *)
let syn_args = [A"-syntax"; A "camlp4o"] in
let args =
(* Heuristic to identify syntax extensions: whether they end in
".syntax"; some might not.
*)
if Filename.check_suffix pkg "syntax" ||
List.mem pkg well_known_syntax then
syn_args @ base_args
else
base_args
in
flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
end
(find_packages ());
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
List.iter begin fun syntax ->
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "infer_interface"; "syntax_"^syntax] &
S[A"-syntax"; A syntax];
end (find_syntaxes ());
(* The default "thread" tag is not compatible with ocamlfind.
* Indeed, the default rules add the "threads.cma" or "threads.cmxa"
* options when using this tag. When using the "-linkpkg" option with
* ocamlfind, this module will then be added twice on the command line.
*
* To solve this, one approach is to add the "-thread" option when using
* the "threads" package using the previous plugin.
*)
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]);
flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]);
flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]);
flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]);
| _ ->
()
end
module MyOCamlbuildBase = struct
(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
(** Base functions for writing myocamlbuild.ml
@author Sylvain Le Gall
*)
open Ocamlbuild_plugin
module OC = Ocamlbuild_pack.Ocaml_compiler
type dir = string
type file = string
type name = string
type tag = string
(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
type t =
{
lib_ocaml: (name * dir list * string list) list;
lib_c: (name * dir * file list) list;
flags: (tag list * (spec OASISExpr.choices)) list;
(* Replace the 'dir: include' from _tags by a precise interdepends in
* directory.
*)
includes: (dir * dir list) list;
}
let env_filename =
Pathname.basename
BaseEnvLight.default_filename
let dispatch_combine lst =
fun e ->
List.iter
(fun dispatch -> dispatch e)
lst
let tag_libstubs nm =
"use_lib"^nm^"_stubs"
let nm_libstubs nm =
nm^"_stubs"
let dispatch t e =
let env =
BaseEnvLight.load
~filename:env_filename
~allow_empty:true
()
in
match e with
| Before_options ->
let no_trailing_dot s =
if String.length s >= 1 && s.[0] = '.' then
String.sub s 1 ((String.length s) - 1)
else
s
in
List.iter
(fun (opt, var) ->
try
opt := no_trailing_dot (BaseEnvLight.var_get var env)
with Not_found ->
Printf.eprintf "W: Cannot get variable %s\n" var)
[
Options.ext_obj, "ext_obj";
Options.ext_lib, "ext_lib";
Options.ext_dll, "ext_dll";
]
| After_rules ->
(* Declare OCaml libraries *)
List.iter
(function
| nm, [], intf_modules ->
ocaml_lib nm;
let cmis =
List.map (fun m -> (String.uncapitalize m) ^ ".cmi")
intf_modules in
dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis
| nm, dir :: tl, intf_modules ->
ocaml_lib ~dir:dir (dir^"/"^nm);
List.iter
(fun dir ->
List.iter
(fun str ->
flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir]))
["compile"; "infer_interface"; "doc"])
tl;
let cmis =
List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi")
intf_modules in
dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"]
cmis)
t.lib_ocaml;
(* Declare directories dependencies, replace "include" in _tags. *)
List.iter
(fun (dir, include_dirs) ->
Pathname.define_context dir include_dirs)
t.includes;
(* Declare C libraries *)
List.iter
(fun (lib, dir, headers) ->
(* Handle C part of library *)
flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib]
(S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib";
A("-l"^(nm_libstubs lib))]);
flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib]
(S[A"-cclib"; A("-l"^(nm_libstubs lib))]);
flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib]
(S[A"-dllib"; A("dll"^(nm_libstubs lib))]);
(* When ocaml link something that use the C library, then one
need that file to be up to date.
*)
dep ["link"; "ocaml"; "program"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
dep ["compile"; "ocaml"; "program"; tag_libstubs lib]
[dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
(* TODO: be more specific about what depends on headers *)
(* Depends on .h files *)
dep ["compile"; "c"]
headers;
(* Setup search path for lib *)
flag ["link"; "ocaml"; "use_"^lib]
(S[A"-I"; P(dir)]);
)
t.lib_c;
(* Add flags *)
List.iter
(fun (tags, cond_specs) ->
let spec = BaseEnvLight.var_choose cond_specs env in
let rec eval_specs =
function
| S lst -> S (List.map eval_specs lst)
| A str -> A (BaseEnvLight.var_expand str env)
| spec -> spec
in
flag tags & (eval_specs spec))
t.flags
| _ ->
()
let dispatch_default t =
dispatch_combine
[
dispatch t;
MyOCamlbuildFindlib.dispatch;
]
end
# 594 "myocamlbuild.ml"
open Ocamlbuild_plugin;;
let package_default =
{
MyOCamlbuildBase.lib_ocaml =
[("sequence", [], []); ("invert", ["invert"], [])];
lib_c = [];
flags = [];
includes = []
}
;;
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
# 609 "myocamlbuild.ml"
(* OASIS_STOP *)
Ocamlbuild_plugin.dispatch dispatch_default;;

771
sequence.ml Normal file
View file

@ -0,0 +1,771 @@
(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Transient iterators, that abstract on a finite sequence of elements.} *)
(** Sequence abstract iterator type *)
type 'a t = ('a -> unit) -> unit
type 'a sequence = 'a t
type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit
(** Sequence of pairs of values of type ['a] and ['b]. *)
(** Build a sequence from a iter function *)
let from_iter f = f
let rec from_fun f k = match f () with
| None -> ()
| Some x -> k x; from_fun f k
let empty k = ()
let singleton x k = k x
let return x k = k x
let pure f k = k f
let doubleton x y k = k x; k y
let cons x l k = k x; l k
let snoc l x k = l k; k x
let repeat x k = while true do k x done
let rec iterate f x k =
k x;
iterate f (f x) k
let rec forever f k =
k (f ());
forever f k
let cycle s k = while true do s k; done
let iter f seq = seq f
let iteri f seq =
let r = ref 0 in
seq
(fun x ->
f !r x;
incr r)
let fold f init seq =
let r = ref init in
seq (fun elt -> r := f !r elt);
!r
let foldi f init seq =
let i = ref 0 in
let r = ref init in
seq
(fun elt ->
r := f !r !i elt;
incr i);
!r
let map f seq k = seq (fun x -> k (f x))
let mapi f seq k =
let i = ref 0 in
seq (fun x -> k (f !i x); incr i)
let filter p seq k = seq (fun x -> if p x then k x)
let append s1 s2 k = s1 k; s2 k
let concat s k = s (fun s' -> s' k)
let flatten s = concat s
let flatMap f seq k = seq (fun x -> f x k)
let flat_map = flatMap
let fmap f seq k =
seq (fun x -> match f x with
| None -> ()
| Some y -> k y
)
let filter_map = fmap
let intersperse elem seq k =
let first = ref true in
seq (fun x -> (if !first then first := false else k elem); k x)
(** Mutable unrolled list to serve as intermediate storage *)
module MList = struct
type 'a node =
| Nil
| Cons of 'a array * int ref * 'a node ref
(* build and call callback on every element *)
let of_seq_with seq k =
let start = ref Nil in
let chunk_size = ref 8 in
(* fill the list. prev: tail-reference from previous node *)
let prev, cur = ref start, ref Nil in
seq
(fun x ->
k x; (* callback *)
match !cur with
| Nil ->
let n = !chunk_size in
if n < 4096 then chunk_size := 2 * !chunk_size;
cur := Cons (Array.make n x, ref 1, ref Nil)
| Cons (a,n,next) ->
assert (!n < Array.length a);
a.(!n) <- x;
incr n;
if !n = Array.length a then begin
!prev := !cur;
prev := next;
cur := Nil
end
);
!prev := !cur;
!start
let of_seq seq =
of_seq_with seq (fun _ -> ())
let is_empty = function
| Nil -> true
| Cons _ -> false
let rec iter f l = match l with
| Nil -> ()
| Cons (a, n, tl) ->
for i=0 to !n - 1 do f a.(i) done;
iter f !tl
let iteri f l =
let rec iteri i f l = match l with
| Nil -> ()
| Cons (a, n, tl) ->
for j=0 to !n - 1 do f (i+j) a.(j) done;
iteri (i+ !n) f !tl
in iteri 0 f l
let rec iter_rev f l = match l with
| Nil -> ()
| Cons (a, n, tl) ->
iter_rev f !tl;
for i = !n-1 downto 0 do f a.(i) done
let length l =
let rec len acc l = match l with
| Nil -> acc
| Cons (_, n, tl) -> len (acc+ !n) !tl
in len 0 l
(** Get element by index *)
let rec get l i = match l with
| Nil -> raise (Invalid_argument "MList.get")
| Cons (a, n, _) when i < !n -> a.(i)
| Cons (_, n, tl) -> get !tl (i- !n)
let to_seq l k = iter k l
let _to_next arg l =
let cur = ref l in
let i = ref 0 in (* offset in cons *)
let rec get_next _ = match !cur with
| Nil -> None
| Cons (_, n, tl) when !i = !n ->
cur := !tl;
i := 0;
get_next arg
| Cons (a, n, _) ->
let x = a.(!i) in
incr i;
Some x
in get_next
let to_gen l = _to_next () l
let to_stream l =
Stream.from (_to_next 42 l) (* 42=magic cookiiiiiie *)
let to_klist l =
let rec make (l,i) () = match l with
| Nil -> `Nil
| Cons (_, n, tl) when i = !n -> make (!tl,0) ()
| Cons (a, n, _) -> `Cons (a.(i), make (l,i+1))
in make (l,0)
end
let persistent seq =
let l = MList.of_seq seq in
MList.to_seq l
type 'a lazy_state =
| LazySuspend
| LazyCached of 'a t
let persistent_lazy (seq:'a t) =
let r = ref LazySuspend in
fun k ->
match !r with
| LazyCached seq' -> seq' k
| LazySuspend ->
(* here if this traversal is interruted, no caching occurs *)
let seq' = MList.of_seq_with seq k in
r := LazyCached (MList.to_seq seq')
let sort ?(cmp=Pervasives.compare) seq =
(* use an intermediate list, then sort the list *)
let l = fold (fun l x -> x::l) [] seq in
let l = List.fast_sort cmp l in
fun k -> List.iter k l
let group ?(eq=fun x y -> x = y) seq k =
let cur = ref [] in
seq (fun x ->
match !cur with
| [] -> cur := [x]
| (y::_) as l when eq x y ->
cur := x::l (* [x] belongs to the group *)
| (_::_) as l ->
k l; (* yield group, and start another one *)
cur := [x]);
(* last list *)
if !cur <> [] then k !cur
let uniq ?(eq=fun x y -> x = y) seq k =
let has_prev = ref false
and prev = ref (Obj.magic 0) in (* avoid option type, costly *)
seq (fun x ->
if !has_prev && eq !prev x
then () (* duplicate *)
else begin
has_prev := true;
prev := x;
k x
end)
let sort_uniq (type elt) ?(cmp=Pervasives.compare) seq =
let module S = Set.Make(struct
type t = elt
let compare = cmp
end) in
let set = fold (fun acc x -> S.add x acc) S.empty seq in
fun k -> S.iter k set
let product outer inner k =
outer (fun x ->
inner (fun y -> k (x,y))
)
let product2 outer inner k =
outer (fun x ->
inner (fun y -> k x y)
)
let join ~join_row s1 s2 k =
s1 (fun a ->
s2 (fun b ->
match join_row a b with
| None -> ()
| Some c -> k c
)
) (* yield the combination of [a] and [b] *)
let rec unfoldr f b k = match f b with
| None -> ()
| Some (x, b') ->
k x;
unfoldr f b' k
let scan f acc seq k =
k acc;
let acc = ref acc in
seq (fun elt -> let acc' = f !acc elt in k acc'; acc := acc')
let max ?(lt=fun x y -> x < y) seq =
let ret = ref None in
seq (fun x -> match !ret with
| None -> ret := Some x
| Some y -> if lt y x then ret := Some x);
!ret
let min ?(lt=fun x y -> x < y) seq =
let ret = ref None in
seq (fun x -> match !ret with
| None -> ret := Some x
| Some y -> if lt x y then ret := Some x);
!ret
exception ExitSequence
let head seq =
let r = ref None in
try
seq (fun x -> r := Some x; raise ExitSequence); None
with ExitSequence -> !r
let head_exn seq =
match head seq with
| None -> invalid_arg "Sequence.head_exn"
| Some x -> x
let take n seq k =
let count = ref 0 in
try
seq (fun x ->
incr count;
k x;
if !count = n then raise ExitSequence
)
with ExitSequence -> ()
let take_while p seq k =
try
seq (fun x -> if p x then k x else raise ExitSequence)
with ExitSequence -> ()
let drop n seq k =
let count = ref 0 in
seq (fun x -> if !count >= n then k x else incr count)
let drop_while p seq k =
let drop = ref true in
seq (fun x ->
if !drop
then if p x then () else (drop := false; k x)
else k x)
let rev seq =
let l = MList.of_seq seq in
fun k -> MList.iter_rev k l
let for_all p seq =
try
seq (fun x -> if not (p x) then raise ExitSequence);
true
with ExitSequence -> false
(** Exists there some element satisfying the predicate? *)
let exists p seq =
try
seq (fun x -> if p x then raise ExitSequence);
false
with ExitSequence -> true
let mem ?(eq=(=)) x seq = exists (eq x) seq
let find f seq =
let r = ref None in
begin try
seq (fun x -> match f x with
| None -> ()
| Some _ as res -> r := res
);
with ExitSequence -> ()
end;
!r
let length seq =
let r = ref 0 in
seq (fun _ -> incr r);
!r
let is_empty seq =
try seq (fun _ -> raise ExitSequence); true
with ExitSequence -> false
(** {2 Transform a sequence} *)
let empty2 k = ()
let is_empty2 seq2 =
try ignore (seq2 (fun _ _ -> raise ExitSequence)); true
with ExitSequence -> false
let length2 seq2 =
let r = ref 0 in
seq2 (fun _ _ -> incr r);
!r
let zip seq2 k = seq2 (fun x y -> k (x,y))
let unzip seq k = seq (fun (x,y) -> k x y)
let zip_i seq k =
let r = ref 0 in
seq (fun x -> let n = !r in incr r; k n x)
let fold2 f acc seq2 =
let acc = ref acc in
seq2 (fun x y -> acc := f !acc x y);
!acc
let iter2 f seq2 = seq2 f
let map2 f seq2 k = seq2 (fun x y -> k (f x y))
let map2_2 f g seq2 k =
seq2 (fun x y -> k (f x y) (g x y))
(** {2 Basic data structures converters} *)
let to_list seq = List.rev (fold (fun y x -> x::y) [] seq)
let to_rev_list seq = fold (fun y x -> x :: y) [] seq
let to_opt = head
let of_opt o k = match o with
| None -> ()
| Some x -> k x
let of_list l k = List.iter k l
let to_array seq =
let l = MList.of_seq seq in
let n = MList.length l in
if n = 0
then [||]
else begin
let a = Array.make n (MList.get l 0) in
MList.iteri (fun i x -> a.(i) <- x) l;
a
end
let of_array a k =
for i = 0 to Array.length a - 1 do
k (Array.unsafe_get a i)
done
let of_array_i a k =
for i = 0 to Array.length a - 1 do
k (i, Array.unsafe_get a i)
done
let of_array2 a k =
for i = 0 to Array.length a - 1 do
k i (Array.unsafe_get a i)
done
let array_slice a i j k =
assert (i >= 0 && j < Array.length a);
for idx = i to j do
k a.(idx); (* iterate on sub-array *)
done
let of_stream s k = Stream.iter k s
let to_stream seq =
let l = MList.of_seq seq in
MList.to_stream l
let to_stack s seq = iter (fun x -> Stack.push x s) seq
let of_stack s k = Stack.iter k s
let to_queue q seq = seq (fun x -> Queue.push x q)
let of_queue q k = Queue.iter k q
let hashtbl_add h seq =
seq (fun (k,v) -> Hashtbl.add h k v)
let hashtbl_replace h seq =
seq (fun (k,v) -> Hashtbl.replace h k v)
let to_hashtbl seq =
let h = Hashtbl.create 3 in
hashtbl_replace h seq;
h
let to_hashtbl2 seq2 =
let h = Hashtbl.create 3 in
seq2 (fun k v -> Hashtbl.replace h k v);
h
let of_hashtbl h k = Hashtbl.iter (fun a b -> k (a, b)) h
let of_hashtbl2 h k = Hashtbl.iter k h
let hashtbl_keys h k = Hashtbl.iter (fun a b -> k a) h
let hashtbl_values h k = Hashtbl.iter (fun a b -> k b) h
let of_str s k = String.iter k s
let to_str seq =
let b = Buffer.create 64 in
iter (fun c -> Buffer.add_char b c) seq;
Buffer.contents b
let concat_str seq =
let b = Buffer.create 64 in
iter (Buffer.add_string b) seq;
Buffer.contents b
exception OneShotSequence
let of_in_channel ic =
let first = ref true in
fun k ->
if not !first
then raise OneShotSequence
else (
first := false;
try
while true do
let c = input_char ic in k c
done
with End_of_file -> ()
)
let to_buffer seq buf =
seq (fun c -> Buffer.add_char buf c)
(** Iterator on integers in [start...stop] by steps 1 *)
let int_range ~start ~stop k =
for i = start to stop do k i done
let int_range_dec ~start ~stop k =
for i = start downto stop do k i done
let of_set (type s) (type v) m set =
let module S = (val m : Set.S with type t = s and type elt = v) in
fun k -> S.iter k set
let to_set (type s) (type v) m seq =
let module S = (val m : Set.S with type t = s and type elt = v) in
fold
(fun set x -> S.add x set)
S.empty seq
type 'a gen = unit -> 'a option
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
let of_gen g =
(* consume the generator to build a MList *)
let rec iter1 k = match g () with
| None -> ()
| Some x -> k x; iter1 k
in
let l = MList.of_seq iter1 in
MList.to_seq l
let to_gen seq =
let l = MList.of_seq seq in
MList.to_gen l
let rec of_klist l k = match l() with
| `Nil -> ()
| `Cons (x,tl) -> k x; of_klist tl k
let to_klist seq =
let l = MList.of_seq seq in
MList.to_klist l
(** {2 Functorial conversions between sets and sequences} *)
module Set = struct
module type S = sig
include Set.S
val of_seq : elt sequence -> t
val to_seq : t -> elt sequence
val to_list : t -> elt list
val of_list : elt list -> t
end
(** Create an enriched Set module from the given one *)
module Adapt(X : Set.S) = struct
let to_seq set k = X.iter k set
let of_seq seq = fold (fun set x -> X.add x set) X.empty seq
let of_list l = of_seq (of_list l)
let to_list set = to_list (to_seq set)
include X
end
(** Functor to build an extended Set module from an ordered type *)
module Make(X : Set.OrderedType) = struct
module MySet = Set.Make(X)
include Adapt(MySet)
end
end
(** {2 Conversion between maps and sequences.} *)
module Map = struct
module type S = sig
include Map.S
val to_seq : 'a t -> (key * 'a) sequence
val of_seq : (key * 'a) sequence -> 'a t
val keys : 'a t -> key sequence
val values : 'a t -> 'a sequence
val to_list : 'a t -> (key * 'a) list
val of_list : (key * 'a) list -> 'a t
end
(** Adapt a pre-existing Map module to make it sequence-aware *)
module Adapt(M : Map.S) = struct
let to_seq m = from_iter (fun k -> M.iter (fun x y -> k (x,y)) m)
let of_seq seq = fold (fun m (k,v) -> M.add k v m) M.empty seq
let keys m = from_iter (fun k -> M.iter (fun x _ -> k x) m)
let values m = from_iter (fun k -> M.iter (fun _ y -> k y) m)
let of_list l = of_seq (of_list l)
let to_list x = to_list (to_seq x)
include M
end
(** Create an enriched Map module, with sequence-aware functions *)
module Make(V : Map.OrderedType) : S with type key = V.t = struct
module M = Map.Make(V)
include Adapt(M)
end
end
(** {2 Infinite sequences of random values} *)
let random_int bound = forever (fun () -> Random.int bound)
let random_bool = forever Random.bool
let random_float bound = forever (fun () -> Random.float bound)
let random_array a k =
assert (Array.length a > 0);
while true do
let i = Random.int (Array.length a) in
k a.(i);
done
let random_list l = random_array (Array.of_list l)
(** {2 Infix functions} *)
module Infix = struct
let (--) i j = int_range ~start:i ~stop:j
let (--^) i j = int_range_dec ~start:i ~stop:j
let (>>=) x f = flat_map f x
let (>|=) x f = map f x
let (<*>) funs args k =
funs (fun f -> args (fun x -> k (f x)))
let (<+>) = append
end
include Infix
(** {2 Pretty printing of sequences} *)
(** Pretty print a sequence of ['a], using the given pretty printer
to print each elements. An optional separator string can be provided. *)
let pp_seq ?(sep=", ") pp_elt formatter seq =
let first = ref true in
seq
(fun x ->
(if !first then first := false
else begin
Format.pp_print_string formatter sep;
Format.pp_print_cut formatter ();
end);
pp_elt formatter x)
let pp_buf ?(sep=", ") pp_elt buf seq =
let first = ref true in
seq
(fun x ->
if !first then first := false else Buffer.add_string buf sep;
pp_elt buf x)
let to_string ?sep pp_elt seq =
let buf = Buffer.create 25 in
pp_buf ?sep (fun buf x -> Buffer.add_string buf (pp_elt x)) buf seq;
Buffer.contents buf
(** {2 Basic IO} *)
module IO = struct
let lines_of ?(mode=0o644) ?(flags=[Open_rdonly]) filename =
fun k ->
let ic = open_in_gen flags mode filename in
try
while true do
let line = input_line ic in
k line
done
with
| End_of_file -> close_in ic
| e -> close_in_noerr ic; raise e
let chunks_of ?(mode=0o644) ?(flags=[]) ?(size=1024) filename =
fun k ->
let ic = open_in_gen flags mode filename in
try
let buf = String.create size in
let n = ref 0 in
let stop = ref false in
while not !stop do
n := 0;
(* try to read [size] chars. If [input] returns [0] it means
the end of file, so we stop, but first we yield the current chunk *)
while !n < size && not !stop do
let n' = input ic buf !n (size - !n) in
if n' = 0 then stop := true else n := !n + n';
done;
if !n > 0
then k (String.sub buf 0 !n)
done;
close_in ic
with e ->
close_in_noerr ic;
raise e
let write_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq =
let oc = open_out_gen flags mode filename in
try
seq (fun s -> output oc s 0 (String.length s));
close_out oc
with e ->
close_out oc;
raise e
let write_lines ?mode ?flags filename seq =
write_to ?mode ?flags filename (snoc (intersperse "\n" seq) "\n")
end

4
sequence.mldylib Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5)
Sequence
# OASIS_STOP

587
sequence.mli Normal file
View file

@ -0,0 +1,587 @@
(*
copyright (c) 2013, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Simple and Efficient Iterators} *)
(** The iterators are designed to allow easy transfer (mappings) between data
structures, without defining [n^2] conversions between the [n] types. The
implementation relies on the assumption that a sequence can be iterated
on as many times as needed; this choice allows for high performance
of many combinators. However, for transient iterators, the {!persistent}
function is provided, storing elements of a transient iterator
in memory; the iterator can then be used several times (See further).
Note that some combinators also return sequences (e.g. {!group}). The
transformation is computed on the fly every time one iterates over
the resulting sequence. If a transformation performs heavy computation,
{!persistent} can also be used as intermediate storage.
Most functions are {b lazy}, i.e. they do not actually use their arguments
until their result is iterated on. For instance, if one calls {!map}
on a sequence, one gets a new sequence, but nothing else happens until
this new sequence is used (by folding or iterating on it).
If a sequence is built from an iteration function that is {b repeatable}
(i.e. calling it several times always iterates on the same set of
elements, for instance List.iter or Map.iter), then
the resulting {!t} object is also repeatable. For {b one-time iter functions}
such as iteration on a file descriptor or a {!Stream},
the {!persistent} function can be used to iterate and store elements in
a memory structure; the result is a sequence that iterates on the elements
of this memory structure, cheaply and repeatably. *)
type +'a t = ('a -> unit) -> unit
(** A sequence of values of type ['a]. If you give it a function ['a -> unit]
it will be applied to every element of the sequence successively. *)
type +'a sequence = 'a t
type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit
(** Sequence of pairs of values of type ['a] and ['b]. *)
(** {2 Build a sequence} *)
val from_iter : (('a -> unit) -> unit) -> 'a t
(** Build a sequence from a iter function *)
val from_fun : (unit -> 'a option) -> 'a t
(** Call the function repeatedly until it returns None. This
sequence is transient, use {!persistent} if needed! *)
val empty : 'a t
(** Empty sequence. It contains no element. *)
val singleton : 'a -> 'a t
(** Singleton sequence, with exactly one element. *)
val doubleton : 'a -> 'a -> 'a t
(** Sequence with exactly two elements *)
val cons : 'a -> 'a t -> 'a t
(** [cons x l] yields [x], then yields from [l].
Same as [append (singleton x) l] *)
val snoc : 'a t -> 'a -> 'a t
(** Same as {!cons} but yields the element after iterating on [l] *)
val return : 'a -> 'a t
(** Synonym to {!singleton} *)
val pure : 'a -> 'a t
(** Synonym to {!singleton} *)
val repeat : 'a -> 'a t
(** Infinite sequence of the same element. You may want to look
at {!take} and the likes if you iterate on it. *)
val iterate : ('a -> 'a) -> 'a -> 'a t
(** [iterate f x] is the infinite sequence [x, f(x), f(f(x)), ...] *)
val forever : (unit -> 'b) -> 'b t
(** Sequence that calls the given function to produce elements.
The sequence may be transient (depending on the function), and definitely
is infinite. You may want to use {!take} and {!persistent}. *)
val cycle : 'a t -> 'a t
(** Cycle forever through the given sequence. Assume the given sequence can
be traversed any amount of times (not transient). This yields an
infinite sequence, you should use something like {!take} not to loop
forever. *)
(** {2 Consume a sequence} *)
val iter : ('a -> unit) -> 'a t -> unit
(** Consume the sequence, passing all its arguments to the function.
Basically [iter f seq] is just [seq f]. *)
val iteri : (int -> 'a -> unit) -> 'a t -> unit
(** Iterate on elements and their index in the sequence *)
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
(** Fold over elements of the sequence, consuming it *)
val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b
(** Fold over elements of the sequence and their index, consuming it *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Map objects of the sequence into other elements, lazily *)
val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t
(** Map objects, along with their index in the sequence *)
val for_all : ('a -> bool) -> 'a t -> bool
(** Do all elements satisfy the predicate? *)
val exists : ('a -> bool) -> 'a t -> bool
(** Exists there some element satisfying the predicate? *)
val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool
(** Is the value a member of the sequence?
@param eq the equality predicate to use (default [(=)])
@since 0.5 *)
val find : ('a -> 'b option) -> 'a t -> 'b option
(** Find the first element on which the function doesn't return [None]
@since 0.5 *)
val length : 'a t -> int
(** How long is the sequence? Forces the sequence. *)
val is_empty : 'a t -> bool
(** Is the sequence empty? Forces the sequence. *)
(** {2 Transform a sequence} *)
val filter : ('a -> bool) -> 'a t -> 'a t
(** Filter on elements of the sequence *)
val append : 'a t -> 'a t -> 'a t
(** Append two sequences. Iterating on the result is like iterating
on the first, then on the second. *)
val concat : 'a t t -> 'a t
(** Concatenate a sequence of sequences into one sequence. *)
val flatten : 'a t t -> 'a t
(** Alias for {!concat} *)
val flatMap : ('a -> 'b t) -> 'a t -> 'b t
(** Monadic bind. Intuitively, it applies the function to every element of the
initial sequence, and calls {!concat}. *)
val flat_map : ('a -> 'b t) -> 'a t -> 'b t
(** Alias to {!flatMap} with a more explicit name
@since 0.5 *)
val fmap : ('a -> 'b option) -> 'a t -> 'b t
(** Specialized version of {!flatMap} for options. *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
(** Alias to {!fmap} with a more explicit name
@since 0.5 *)
val intersperse : 'a -> 'a t -> 'a t
(** Insert the single element between every element of the sequence *)
(** {2 Caching} *)
val persistent : 'a t -> 'a t
(** Iterate on the sequence, storing elements in an efficient internal structure..
The resulting sequence can be iterated on as many times as needed.
{b Note}: calling persistent on an already persistent sequence
will still make a new copy of the sequence! *)
val persistent_lazy : 'a t -> 'a t
(** Lazy version of {!persistent}. When calling [persistent_lazy s],
a new sequence [s'] is immediately returned (without actually consuming
[s]) in constant time; the first time [s'] is iterated on,
it also consumes [s] and caches its content into a inner data
structure that will back [s'] for future iterations.
{b warning}: on the first traversal of [s'], if the traversal
is interrupted prematurely ({!take}, etc.) then [s'] will not be
memorized, and the next call to [s'] will traverse [s] again. *)
(** {2 Misc} *)
val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t
(** Sort the sequence. Eager, O(n) ram and O(n ln(n)) time.
It iterates on elements of the argument sequence immediately,
before it sorts them. *)
val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t
(** Sort the sequence and remove duplicates. Eager, same as [sort] *)
val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t
(** Group equal consecutive elements. *)
val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t
(** Remove consecutive duplicate elements. Basically this is
like [fun seq -> map List.hd (group seq)]. *)
val product : 'a t -> 'b t -> ('a * 'b) t
(** Cartesian product of the sequences. When calling [product a b],
the caller {b MUST} ensure that [b] can be traversed as many times
as required (several times), possibly by calling {!persistent} on it
beforehand. *)
val product2 : 'a t -> 'b t -> ('a, 'b) t2
(** Binary version of {!product}. Same requirements.
@since 0.5 *)
val join : join_row:('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t
(** [join ~join_row a b] combines every element of [a] with every
element of [b] using [join_row]. If [join_row] returns None, then
the two elements do not combine. Assume that [b] allows for multiple
iterations. *)
val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a t
(** [unfoldr f b] will apply [f] to [b]. If it
yields [Some (x,b')] then [x] is returned
and unfoldr recurses with [b']. *)
val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t
(** Sequence of intermediate results *)
val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option
(** Max element of the sequence, using the given comparison function.
@return None if the sequence is empty, Some [m] where [m] is the maximal
element otherwise *)
val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option
(** Min element of the sequence, using the given comparison function.
see {!max} for more details. *)
val head : 'a t -> 'a option
(** First element, if any, otherwise [None]
@since 0.5.1 *)
val head_exn : 'a t -> 'a
(** First element, if any, fails
@raise Invalid_argument if the sequence is empty
@since 0.5.1 *)
val take : int -> 'a t -> 'a t
(** Take at most [n] elements from the sequence. Works on infinite
sequences. *)
val take_while : ('a -> bool) -> 'a t -> 'a t
(** Take elements while they satisfy the predicate, then stops iterating.
Will work on an infinite sequence [s] if the predicate is false for at
least one element of [s]. *)
val drop : int -> 'a t -> 'a t
(** Drop the [n] first elements of the sequence. Lazy. *)
val drop_while : ('a -> bool) -> 'a t -> 'a t
(** Predicate version of {!drop} *)
val rev : 'a t -> 'a t
(** Reverse the sequence. O(n) memory and time, needs the
sequence to be finite. The result is persistent and does
not depend on the input being repeatable. *)
(** {2 Binary sequences} *)
val empty2 : ('a, 'b) t2
val is_empty2 : (_, _) t2 -> bool
val length2 : (_, _) t2 -> int
val zip : ('a, 'b) t2 -> ('a * 'b) t
val unzip : ('a * 'b) t -> ('a, 'b) t2
val zip_i : 'a t -> (int, 'a) t2
(** Zip elements of the sequence with their index in the sequence *)
val fold2 : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t2 -> 'c
val iter2 : ('a -> 'b -> unit) -> ('a, 'b) t2 -> unit
val map2 : ('a -> 'b -> 'c) -> ('a, 'b) t2 -> 'c t
val map2_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'd) -> ('a, 'b) t2 -> ('c, 'd) t2
(** [map2_2 f g seq2] maps each [x, y] of seq2 into [f x y, g x y] *)
(** {2 Basic data structures converters} *)
val to_list : 'a t -> 'a list
(** Convert the sequence into a list. Preserves order of elements.
This function is tail-recursive, but consumes 2*n memory.
If order doesn't matter to you, consider {!to_rev_list}. *)
val to_rev_list : 'a t -> 'a list
(** Get the list of the reversed sequence (more efficient than {!to_list}) *)
val of_list : 'a list -> 'a t
val to_opt : 'a t -> 'a option
(** Alias to {!head}
@since 0.5.1 *)
val to_array : 'a t -> 'a array
(** Convert to an array. Currently not very efficient because
an intermediate list is used. *)
val of_array : 'a array -> 'a t
val of_array_i : 'a array -> (int * 'a) t
(** Elements of the array, with their index *)
val of_array2 : 'a array -> (int, 'a) t2
val array_slice : 'a array -> int -> int -> 'a t
(** [array_slice a i j] Sequence of elements whose indexes range
from [i] to [j] *)
val of_opt : 'a option -> 'a t
(** Iterate on 0 or 1 values.
@since 0.5.1 *)
val of_stream : 'a Stream.t -> 'a t
(** Sequence of elements of a stream (usable only once) *)
val to_stream : 'a t -> 'a Stream.t
(** Convert to a stream. linear in memory and time (a copy is made in memory) *)
val to_stack : 'a Stack.t -> 'a t -> unit
(** Push elements of the sequence on the stack *)
val of_stack : 'a Stack.t -> 'a t
(** Sequence of elements of the stack (same order as [Stack.iter]) *)
val to_queue : 'a Queue.t -> 'a t -> unit
(** Push elements of the sequence into the queue *)
val of_queue : 'a Queue.t -> 'a t
(** Sequence of elements contained in the queue, FIFO order *)
val hashtbl_add : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit
(** Add elements of the sequence to the hashtable, with
Hashtbl.add *)
val hashtbl_replace : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit
(** Add elements of the sequence to the hashtable, with
Hashtbl.replace (erases conflicting bindings) *)
val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t
(** Build a hashtable from a sequence of key/value pairs *)
val to_hashtbl2 : ('a, 'b) t2 -> ('a, 'b) Hashtbl.t
(** Build a hashtable from a sequence of key/value pairs *)
val of_hashtbl : ('a, 'b) Hashtbl.t -> ('a * 'b) t
(** Sequence of key/value pairs from the hashtable *)
val of_hashtbl2 : ('a, 'b) Hashtbl.t -> ('a, 'b) t2
(** Sequence of key/value pairs from the hashtable *)
val hashtbl_keys : ('a, 'b) Hashtbl.t -> 'a t
val hashtbl_values : ('a, 'b) Hashtbl.t -> 'b t
val of_str : string -> char t
val to_str : char t -> string
val concat_str : string t -> string
(** Concatenate strings together, eagerly.
Also see {!intersperse} to add a separator.
@since 0.5 *)
exception OneShotSequence
(** Raised when the user tries to iterate several times on
a transient iterator *)
val of_in_channel : in_channel -> char t
(** Iterates on characters of the input (can block when one
iterates over the sequence). If you need to iterate
several times on this sequence, use {!persistent}.
@raise OneShotSequence when used more than once. *)
val to_buffer : char t -> Buffer.t -> unit
(** Copy content of the sequence into the buffer *)
val int_range : start:int -> stop:int -> int t
(** Iterator on integers in [start...stop] by steps 1. Also see
{!(--)} for an infix version. *)
val int_range_dec : start:int -> stop:int -> int t
(** Iterator on decreasing integers in [stop...start] by steps -1.
See {!(--^)} for an infix version *)
val of_set : (module Set.S with type elt = 'a and type t = 'b) -> 'b -> 'a t
(** Convert the given set to a sequence. The set module must be provided. *)
val to_set : (module Set.S with type elt = 'a and type t = 'b) -> 'a t -> 'b
(** Convert the sequence to a set, given the proper set module *)
type 'a gen = unit -> 'a option
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
val of_gen : 'a gen -> 'a t
(** Traverse eagerly the generator and build a sequence from it *)
val to_gen : 'a t -> 'a gen
(** Make the sequence persistent (O(n)) and then iterate on it. Eager. *)
val of_klist : 'a klist -> 'a t
(** Iterate on the lazy list *)
val to_klist : 'a t -> 'a klist
(** Make the sequence persistent and then iterate on it. Eager. *)
(** {2 Functorial conversions between sets and sequences} *)
module Set : sig
module type S = sig
include Set.S
val of_seq : elt sequence -> t
val to_seq : t -> elt sequence
val to_list : t -> elt list
val of_list : elt list -> t
end
(** Create an enriched Set module from the given one *)
module Adapt(X : Set.S) : S with type elt = X.elt and type t = X.t
(** Functor to build an extended Set module from an ordered type *)
module Make(X : Set.OrderedType) : S with type elt = X.t
end
(** {2 Conversion between maps and sequences.} *)
module Map : sig
module type S = sig
include Map.S
val to_seq : 'a t -> (key * 'a) sequence
val of_seq : (key * 'a) sequence -> 'a t
val keys : 'a t -> key sequence
val values : 'a t -> 'a sequence
val to_list : 'a t -> (key * 'a) list
val of_list : (key * 'a) list -> 'a t
end
(** Adapt a pre-existing Map module to make it sequence-aware *)
module Adapt(M : Map.S) : S with type key = M.key and type 'a t = 'a M.t
(** Create an enriched Map module, with sequence-aware functions *)
module Make(V : Map.OrderedType) : S with type key = V.t
end
(** {2 Infinite sequences of random values} *)
val random_int : int -> int t
(** Infinite sequence of random integers between 0 and
the given higher bound (see Random.int) *)
val random_bool : bool t
(** Infinite sequence of random bool values *)
val random_float : float -> float t
val random_array : 'a array -> 'a t
(** Sequence of choices of an element in the array *)
val random_list : 'a list -> 'a t
(** Infinite sequence of random elements of the list. Basically the
same as {!random_array}. *)
(** {2 Infix functions} *)
module Infix : sig
val (--) : int -> int -> int t
(** [a -- b] is the range of integers from [a] to [b], both included,
in increasing order. It will therefore be empty if [a > b]. *)
val (--^) : int -> int -> int t
(** [a --^ b] is the range of integers from [b] to [a], both included,
in decreasing order (starts from [a]).
It will therefore be empty if [a < b]. *)
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** Monadic bind (infix version of {!flat_map}
@since 0.5 *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
(** Infix version of {!map}
@since 0.5 *)
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
(** Applicative operator (product+application)
@since 0.5 *)
val (<+>) : 'a t -> 'a t -> 'a t
(** Concatenation of sequences
@since 0.5 *)
end
include module type of Infix
(** {2 Pretty printing of sequences} *)
val pp_seq : ?sep:string -> (Format.formatter -> 'a -> unit) ->
Format.formatter -> 'a t -> unit
(** Pretty print a sequence of ['a], using the given pretty printer
to print each elements. An optional separator string can be provided. *)
val pp_buf : ?sep:string -> (Buffer.t -> 'a -> unit) ->
Buffer.t -> 'a t -> unit
(** Print into a buffer *)
val to_string : ?sep:string -> ('a -> string) -> 'a t -> string
(** Print into a string *)
(** {2 Basic IO}
Very basic interface to manipulate files as sequence of chunks/lines. The
sequences take care of opening and closing files properly; every time
one iterates over a sequence, the file is opened/closed again.
Example: copy a file ["a"] into file ["b"], removing blank lines:
{[
Sequence.(IO.lines_of "a" |> filter (fun l-> l<> "") |> IO.write_lines "b");;
]}
By chunks of [4096] bytes:
{[
Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");;
]}
@since 0.5.1 *)
module IO : sig
val lines_of : ?mode:int -> ?flags:open_flag list ->
string -> string t
(** [lines_of filename] reads all lines of the given file. It raises the
same exception as would opening the file and read from it, except
from [End_of_file] (which is caught). The file is {b always} properly
closed.
Every time the sequence is iterated on, the file is opened again, so
different iterations might return different results
@param mode default [0o644]
@param flags default: [[Open_rdonly]] *)
val chunks_of : ?mode:int -> ?flags:open_flag list -> ?size:int ->
string -> string t
(** Read chunks of the given [size] from the file. The last chunk might be
smaller. Behaves like {!lines_of} regarding errors and options.
Every time the sequence is iterated on, the file is opened again, so
different iterations might return different results *)
val write_to : ?mode:int -> ?flags:open_flag list ->
string -> string t -> unit
(** [write_to filename seq] writes all strings from [seq] into the given
file. It takes care of opening and closing the file.
@param mode default [0o644]
@param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *)
val write_lines : ?mode:int -> ?flags:open_flag list ->
string -> string t -> unit
(** Same as {!write_to}, but intercales ['\n'] between each string *)
end

4
sequence.mllib Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5)
Sequence
# OASIS_STOP

4
sequence.odocl Normal file
View file

@ -0,0 +1,4 @@
# OASIS_START
# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5)
Sequence
# OASIS_STOP

7205
setup.ml Normal file
View file

File diff suppressed because it is too large Load diff

9
tests/run_tests.ml Normal file
View file

@ -0,0 +1,9 @@
open OUnit
let suite =
"run_tests" >:::
[ Test_sequence.suite; ]
let _ =
OUnit.run_test_tt_main suite

220
tests/test_sequence.ml Normal file
View file

@ -0,0 +1,220 @@
open OUnit
module S = Sequence
open Sequence.Infix
let pp_ilist l =
let b = Buffer.create 15 in
Format.bprintf b "@[<h>%a@]" (S.pp_seq Format.pp_print_int) (S.of_list l);
Buffer.contents b
let test_empty () =
let seq = S.empty in
OUnit.assert_bool "empty" (S.is_empty seq);
OUnit.assert_bool "empty"
(try S.iter (fun _ -> raise Exit) seq; true with Exit -> false);
()
let test_repeat () =
let seq = S.repeat "hello" in
OUnit.assert_equal ["hello"; "hello"; "hello"]
(seq |> S.take 3 |> S.to_list);
()
let test_concat () =
let s1 = (1 -- 5) in
let s2 = (6 -- 10) in
let l = [1;2;3;4;5;6;7;8;9;10] in
OUnit.assert_equal l (S.to_list (S.append s1 s2));
()
let test_fold () =
let n = (1 -- 10)
|> S.fold (+) 0 in
OUnit.assert_equal 55 n;
()
let test_foldi () =
let l = ["hello"; "world"]
|> S.of_list
|> S.foldi (fun acc i x -> (i,x) :: acc) [] in
OUnit.assert_equal [1, "world"; 0, "hello"] l;
()
let test_exists () =
(1 -- 100)
|> S.exists (fun x -> x = 59)
|> OUnit.assert_bool "exists";
(1 -- 100)
|> S.exists (fun x -> x < 0)
|> (fun x -> not x)
|> OUnit.assert_bool "not exists";
()
let test_length () =
(1 -- 1000) |> S.length |> OUnit.assert_equal 1000
let test_concat () =
1 -- 1000
|> S.map (fun i -> (i -- (i+1)))
|> S.concat
|> S.length
|> OUnit.assert_equal 2000
let test_flatMap () =
1 -- 1000
|> S.flatMap (fun i -> (i -- (i+1)))
|> S.length
|> OUnit.assert_equal 2000
let test_intersperse () =
1 -- 100
|> (fun seq -> S.intersperse 0 seq)
|> S.take 10
|> S.to_list
|> OUnit.assert_equal [1;0;2;0;3;0;4;0;5;0]
let test_not_persistent () =
let printer = pp_ilist in
let stream = Stream.from (fun i -> if i < 5 then Some i else None) in
let seq = S.of_stream stream in
OUnit.assert_equal ~printer [0;1;2;3;4] (seq |> S.to_list);
OUnit.assert_equal ~printer [] (seq |> S.to_list);
()
let test_persistent () =
let printer = pp_ilist in
let stream = Stream.from (fun i -> if i < 5 then Some i else None) in
let seq = S.of_stream stream in
(* consume seq into a persistent version of itself *)
let seq' = S.persistent seq in
OUnit.assert_equal ~printer [] (seq |> S.to_list);
OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_list);
OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_list);
OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_stream |> S.of_stream |> S.to_list);
()
let test_big_persistent () =
let printer = pp_ilist in
let seq = 0 -- 10_000 in
let seq' = S.persistent seq in
OUnit.assert_equal 10_001 (S.length seq');
OUnit.assert_equal 10_001 (S.length seq');
OUnit.assert_equal ~printer [0;1;2;3] (seq' |> S.take 4 |> S.to_list);
()
let test_sort () =
1 -- 100
|> S.sort ~cmp:(fun i j -> j - i)
|> S.take 4
|> S.to_list
|> OUnit.assert_equal [100;99;98;97]
let test_sort_uniq () =
[42;1;2;3;4;5;4;3;2;1]
|> S.of_list
|> S.sort_uniq
|> S.to_list
|> OUnit.assert_equal [1;2;3;4;5;42]
let test_group () =
[1;2;3;3;2;2;3;4]
|> S.of_list |> S.group |> S.to_list
|> OUnit.assert_equal [[1];[2];[3;3];[2;2];[3];[4]]
let test_uniq () =
[1;2;2;3;4;4;4;3;3]
|> S.of_list |> S.uniq |> S.to_list
|> OUnit.assert_equal [1;2;3;4;3]
let test_product () =
let stream = Stream.from (fun i -> if i < 3 then Some i else None) in
let a = S.of_stream stream in
let b = S.of_list ["a";"b";"c"] in
let s = S.product a b |> S.map (fun (x,y) -> y,x)
|> S.to_list |> List.sort compare in
OUnit.assert_equal ["a",0; "a", 1; "a", 2;
"b",0; "b", 1; "b", 2;
"c",0; "c", 1; "c", 2;] s
let test_join () =
let s1 = (1 -- 3) in
let s2 = S.of_list ["1"; "2"] in
let join_row i j =
if string_of_int i = j then Some (string_of_int i ^ " = " ^ j) else None
in
let s = S.join ~join_row s1 s2 in
OUnit.assert_equal ["1 = 1"; "2 = 2"] (S.to_list s);
()
let test_scan () =
1 -- 5
|> S.scan (+) 0
|> S.to_list
|> OUnit.assert_equal ~printer:pp_ilist [0;1;3;6;10;15]
let test_drop () =
1 -- 5 |> S.drop 2 |> S.to_list |> OUnit.assert_equal [3;4;5]
let test_rev () =
1 -- 5 |> S.rev |> S.to_list |> OUnit.assert_equal [5;4;3;2;1]
let test_unfoldr () =
let f x = if x < 5 then Some (string_of_int x,x+1) else None in
S.unfoldr f 0
|> S.to_list
|> OUnit.assert_equal ["0"; "1"; "2"; "3"; "4"]
let test_hashtbl () =
let h = 1 -- 5
|> S.zip_i
|> S.to_hashtbl2 in
0 -- 4
|> S.iter (fun i -> OUnit.assert_equal (i+1) (Hashtbl.find h i));
OUnit.assert_equal [0;1;2;3;4] (S.hashtbl_keys h |> S.sort |> S.to_list);
()
let test_buff () =
let b = Buffer.create 4 in
"hello world"
|> S.of_str |> S.rev |> S.map Char.uppercase
|> (fun seq -> S.to_buffer seq b);
OUnit.assert_equal "DLROW OLLEH" (Buffer.contents b);
()
let test_int_range () =
OUnit.assert_equal ~printer:pp_ilist [1;2;3;4] S.(to_list (1--4));
OUnit.assert_equal ~printer:pp_ilist [10;9;8;7;6] S.(to_list (10 --^ 6));
OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10--4));
OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10 --^ 60));
()
let suite =
"test_sequence" >:::
[ "test_empty" >:: test_empty;
"test_repeat" >:: test_repeat;
"test_concat" >:: test_concat;
"test_fold" >:: test_fold;
"test_foldi" >:: test_foldi;
"test_exists" >:: test_exists;
"test_length" >:: test_length;
"test_concat" >:: test_concat;
"test_flatMap" >:: test_flatMap;
"test_intersperse" >:: test_intersperse;
"test_not_persistent" >:: test_not_persistent;
"test_persistent" >:: test_persistent;
"test_big_persistent" >:: test_big_persistent;
"test_sort" >:: test_sort;
"test_sort_uniq" >:: test_sort;
"test_group" >:: test_group;
"test_uniq" >:: test_uniq;
"test_product" >:: test_product;
"test_join" >:: test_join;
"test_scan" >:: test_scan;
"test_drop" >:: test_drop;
"test_rev" >:: test_rev;
"test_unfoldr" >:: test_unfoldr;
"test_hashtbl" >:: test_hashtbl;
"test_int_range" >:: test_int_range;
]