├── .github └── workflows │ ├── gh-pages.yml │ └── main.yml ├── .gitignore ├── .ocamlformat ├── CHANGELOG.md ├── Makefile ├── README.md ├── dune-project ├── oseq.opam ├── src ├── OSeq.ml ├── OSeq.mli ├── dune ├── mkflags.ml └── mkshims.ml └── tests └── unit ├── dune └── t_oseq.ml /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master # Set a branch name to trigger deployment 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@main 13 | 14 | - name: Cache opam 15 | id: cache-opam 16 | uses: actions/cache@v2 17 | with: 18 | path: ~/.opam 19 | key: opam-ubuntu-latest-4.12.0 20 | 21 | - uses: avsm/setup-ocaml@v1 22 | with: 23 | ocaml-version: '4.12.0' 24 | 25 | - name: Pin 26 | run: opam pin -n . 27 | 28 | - name: Depext 29 | run: opam depext -yt oseq 30 | 31 | - name: Deps 32 | run: opam install -d . --deps-only 33 | 34 | - name: Build 35 | run: opam exec -- dune build @doc 36 | 37 | - name: Deploy 38 | uses: peaceiris/actions-gh-pages@v3 39 | with: 40 | github_token: ${{ secrets.GITHUB_TOKEN }} 41 | publish_dir: ./_build/default/_doc/_html/ 42 | destination_dir: dev 43 | enable_jekyll: true 44 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | branches: 8 | - master 9 | jobs: 10 | run: 11 | name: Build 12 | strategy: 13 | matrix: 14 | os: 15 | - macos-latest 16 | - ubuntu-latest 17 | - windows-latest 18 | ocaml-compiler: 19 | - 4.08.x 20 | - 4.13.x 21 | runs-on: ${{ matrix.os }} 22 | steps: 23 | - uses: actions/checkout@v2 24 | - uses: ocaml/setup-ocaml@v2 25 | with: 26 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 27 | - run: opam pin -n . 28 | - run: opam depext -yt oseq 29 | - run: opam install -t . --deps-only 30 | - run: opam exec -- dune build 31 | - run: opam exec -- dune runtest 32 | if: ${{ matrix.os == 'ubuntu-latest'}} 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | _build 3 | *.native 4 | *.docdir 5 | *.html 6 | man/ 7 | *.install 8 | .merlin 9 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.24.1 2 | profile=conventional 3 | margin=80 4 | if-then-else=k-r 5 | parens-ite=true 6 | parens-tuple=multi-line-only 7 | sequence-style=terminator 8 | type-decl=compact 9 | break-cases=toplevel 10 | cases-exp-indent=2 11 | field-space=tight-decl 12 | leading-nested-match-parens=true 13 | module-item-spacing=compact 14 | quiet=true 15 | ocaml-version=4.08.0 16 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.5.1 2 | 3 | - do not use qtest anymore 4 | 5 | ## 0.5 6 | 7 | - use ocamlformat 8 | - add let-operators 9 | - require OCaml 4.08 10 | - breaking: remove most labels, ensure compatibility with extended Seq 11 | 12 | ## 0.4.1 13 | 14 | - fix error in tests related to `-nolabels` 15 | 16 | ## 0.4 17 | 18 | - use `include Seq` so we're forward compatible with OCaml 19 | - add relational operators: group_by, group_by_fold, join_by, join_by_fold 20 | - add `{flat_map,app}_interleave`, `to_iter`, `to_gen` 21 | - add head_exn/tail_exn 22 | 23 | - fix: make `product` more fair by using interleave 24 | - fix: handle exceptions in OSeq.memoize 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: build test 3 | 4 | build: 5 | @dune build @install 6 | 7 | test: 8 | @dune runtest --no-buffer --force 9 | 10 | clean: 11 | @dune clean 12 | 13 | doc: 14 | @dune build @doc 15 | 16 | benchs: 17 | @dune build $(addprefix bench/, $(BENCH_TARGETS)) 18 | 19 | VERSION=$(shell awk '/^version:/ {print $$2}' oseq.opam) 20 | 21 | update_next_tag: 22 | @echo "update version to $(VERSION)..." 23 | sed -i "s/NEXT_VERSION/$(VERSION)/g" src/*.ml src/*.mli 24 | sed -i "s/NEXT_RELEASE/$(VERSION)/g" src/*.ml src/*.mli 25 | 26 | reindent: 27 | @which ocp-indent || ( echo "require ocp-indent" ; exit 1 ) 28 | @find src '(' -name '*.ml' -or -name '*.mli' ')' -type f -print0 | xargs -0 echo "reindenting: " 29 | @find src '(' -name '*.ml' -or -name '*.mli' ')' -type f -print0 | xargs -0 ocp-indent -i 30 | 31 | WATCH?=@install 32 | watch: 33 | @dune build $(WATCH) -w 34 | 35 | .PHONY: benchs tests examples update_next_tag watch 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OSeq 2 | 3 | [![build status](https://github.com/c-cube/oseq/workflows/build/badge.svg)](https://github.com/c-cube/oseq/actions/) 4 | 5 | Simple list of suspensions, as a composable lazy iterator that behaves like a value. 6 | 7 | The type of sequences, `'a OSeq.t`, is compatible with the new standard type 8 | of iterators `'a Seq.t`. 9 | 10 | ## Documentation 11 | 12 | https://c-cube.github.io/oseq/ 13 | 14 | ## License 15 | 16 | BSD license. 17 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name oseq) 3 | -------------------------------------------------------------------------------- /oseq.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "oseq" 3 | version: "0.5.1" 4 | author: "Simon Cruanes" 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | license: "BSD-2-clause" 7 | build: [ 8 | ["dune" "build" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 10 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 11 | ] 12 | depends: [ 13 | "dune" { >= "1.0" } 14 | "qcheck" {with-test} 15 | "gen" {with-test} 16 | "containers" {with-test} 17 | "odoc" {with-doc} 18 | "ocaml" { >= "4.08.0" } 19 | ] 20 | tags: [ "sequence" "iterator" "seq" "pure" "list" ] 21 | homepage: "https://github.com/c-cube/oseq/" 22 | doc: "https://c-cube.github.io/oseq/" 23 | bug-reports: "https://github.com/c-cube/oseq/issues" 24 | dev-repo: "git+https://github.com/c-cube/oseq.git" 25 | synopsis: "Simple list of suspensions, as a composable lazy iterator that behaves like a value" 26 | description: "Extends the new standard library's `Seq` module with many useful combinators." 27 | -------------------------------------------------------------------------------- /src/OSeq.ml: -------------------------------------------------------------------------------- 1 | open Seq 2 | 3 | type 'a seq = 'a Seq.t (* alias *) 4 | type 'a iter = ('a -> unit) -> unit 5 | type 'a gen = unit -> 'a option 6 | type 'a equal = 'a -> 'a -> bool 7 | type 'a ord = 'a -> 'a -> int 8 | type 'a printer = Format.formatter -> 'a -> unit 9 | 10 | let empty () = Nil 11 | 12 | let is_empty l = 13 | match l () with 14 | | Nil -> true 15 | | Cons _ -> false 16 | 17 | let return x () = Cons (x, empty) 18 | let cons a b () = Cons (a, b) 19 | 20 | let head_exn g = 21 | match g () with 22 | | Cons (x, _) -> x 23 | | Nil -> invalid_arg "OSeq.head_exn" 24 | 25 | let tail_exn g : _ t = 26 | match g () with 27 | | Cons (_, l) -> l 28 | | Nil -> invalid_arg "OSeq.tail_exn" 29 | 30 | let rec ( -- ) i j () = 31 | if i = j then 32 | Cons (i, empty) 33 | else if i < j then 34 | Cons (i, i + 1 -- j) 35 | else 36 | Cons (i, i - 1 -- j) 37 | 38 | let ( --^ ) i j = 39 | if i = j then 40 | empty 41 | else if i < j then 42 | i -- (j - 1) 43 | else 44 | i -- (j + 1) 45 | 46 | let rec map f l () = 47 | match l () with 48 | | Nil -> Nil 49 | | Cons (x, tail) -> Cons (f x, map f tail) 50 | 51 | let rec fold_map f acc l () = 52 | match l () with 53 | | Nil -> Nil 54 | | Cons (x, tl) -> 55 | let acc = f acc x in 56 | Cons (acc, fold_map f acc tl) 57 | 58 | let rec repeatedly f () = Cons (f (), repeatedly f) 59 | let rec repeat x () = Cons (x, repeat x) 60 | 61 | let init n f = 62 | let rec aux r () = 63 | if r >= n then 64 | Nil 65 | else ( 66 | let x = f r in 67 | Cons (x, aux (r + 1)) 68 | ) 69 | in 70 | aux 0 71 | 72 | let mapi f l = 73 | let rec aux f l i () = 74 | match l () with 75 | | Nil -> Nil 76 | | Cons (x, tl) -> Cons (f i x, aux f tl (i + 1)) 77 | in 78 | aux f l 0 79 | 80 | let rec filter_map f (l : 'a t) () = 81 | match l () with 82 | | Nil -> Nil 83 | | Cons (x, l') -> 84 | (match f x with 85 | | None -> filter_map f l' () 86 | | Some y -> Cons (y, filter_map f l')) 87 | 88 | let filter f l = 89 | let rec aux f l () = 90 | match l () with 91 | | Nil -> Nil 92 | | Cons (x, tl) when f x -> Cons (x, aux f tl) 93 | | Cons (_, tl) -> aux f tl () 94 | in 95 | aux f l 96 | 97 | let rec append a b () = 98 | match a () with 99 | | Nil -> b () 100 | | Cons (x, tl) -> Cons (x, append tl b) 101 | 102 | let rec cycle l () = append l (cycle l) () 103 | 104 | let iterate f x = 105 | let rec aux f x () = 106 | let y = f x in 107 | Cons (x, aux f y) 108 | in 109 | aux f x 110 | 111 | let rec fold f acc l = 112 | match l () with 113 | | Nil -> acc 114 | | Cons (x, tl) -> fold f (f acc x) tl 115 | 116 | let fold_left = fold 117 | 118 | let foldi f acc l = 119 | let rec foldi f i acc l = 120 | match l () with 121 | | Nil -> acc 122 | | Cons (x, tl) -> foldi f (succ i) (f i acc x) tl 123 | in 124 | foldi f 0 acc l 125 | 126 | let reduce f g = 127 | match g () with 128 | | Nil -> invalid_arg "reduce" 129 | | Cons (x, tl) -> fold f x tl 130 | 131 | let rec iter f l = 132 | match l () with 133 | | Nil -> () 134 | | Cons (x, l') -> 135 | f x; 136 | iter f l' 137 | 138 | let iteri f l = 139 | let rec aux f l i = 140 | match l () with 141 | | Nil -> () 142 | | Cons (x, l') -> 143 | f i x; 144 | aux f l' (i + 1) 145 | in 146 | aux f l 0 147 | 148 | let length l = fold (fun acc _ -> acc + 1) 0 l 149 | 150 | let rec unfold f acc () = 151 | match f acc with 152 | | None -> Nil 153 | | Some (x, acc') -> Cons (x, unfold f acc') 154 | 155 | let rec flat_map f l () = 156 | match l () with 157 | | Nil -> Nil 158 | | Cons (x, tl) -> fm_app_ f (f x) tl () 159 | 160 | and fm_app_ f l l' () = 161 | match l () with 162 | | Nil -> flat_map f l' () 163 | | Cons (x, tl) -> Cons (x, fm_app_ f tl l') 164 | 165 | let take_nth n g = 166 | let rec aux i g () = 167 | match g () with 168 | | Nil -> Nil 169 | | Cons (_, tl) when i > 0 -> aux (i - 1) tl () 170 | | Cons (x, tl) -> 171 | assert (i = 0); 172 | Cons (x, aux (n - 1) tl) 173 | in 174 | aux 0 g 175 | 176 | let rec nth i l = 177 | match l () with 178 | | Nil -> raise Not_found 179 | | Cons (x, _) when i = 0 -> x 180 | | Cons (_, tl) -> nth (i - 1) tl 181 | 182 | let mem eq x gen = 183 | let rec mem eq x gen = 184 | match gen () with 185 | | Nil -> false 186 | | Cons (y, tl) -> eq x y || mem eq x tl 187 | in 188 | mem eq x gen 189 | 190 | let rec for_all p gen = 191 | match gen () with 192 | | Nil -> true 193 | | Cons (x, tl) -> p x && for_all p tl 194 | 195 | let rec exists p gen = 196 | match gen () with 197 | | Nil -> false 198 | | Cons (x, tl) -> p x || exists p tl 199 | 200 | let min ~lt gen = 201 | match gen () with 202 | | Cons (x, tl) -> 203 | fold 204 | (fun min x -> 205 | if lt x min then 206 | x 207 | else 208 | min) 209 | x tl 210 | | Nil -> invalid_arg "min" 211 | 212 | let max ~lt gen = 213 | match gen () with 214 | | Cons (x, tl) -> 215 | fold 216 | (fun max x -> 217 | if lt max x then 218 | x 219 | else 220 | max) 221 | x tl 222 | | Nil -> invalid_arg "max" 223 | 224 | let equal eq gen1 gen2 = 225 | let rec check gen1 gen2 = 226 | match gen1 (), gen2 () with 227 | | Nil, Nil -> true 228 | | Cons (x1, tl1), Cons (x2, tl2) when eq x1 x2 -> check tl1 tl2 229 | | _ -> false 230 | in 231 | check gen1 gen2 232 | 233 | (* [partition p l] returns the elements that satisfy [p], 234 | and the elements that do not satisfy [p] *) 235 | let partition p gen = filter p gen, filter (fun x -> not (p x)) gen 236 | 237 | let zip_index gen = 238 | let rec aux r gen () = 239 | match gen () with 240 | | Nil -> Nil 241 | | Cons (x, tl) -> Cons ((r, x), aux (r + 1) tl) 242 | in 243 | aux 0 gen 244 | 245 | let rec map2 f l1 l2 () = 246 | match l1 (), l2 () with 247 | | Nil, _ | _, Nil -> Nil 248 | | Cons (x1, l1'), Cons (x2, l2') -> Cons (f x1 x2, map2 f l1' l2') 249 | 250 | let rec fold2 f acc l1 l2 = 251 | match l1 (), l2 () with 252 | | Nil, _ | _, Nil -> acc 253 | | Cons (x1, l1'), Cons (x2, l2') -> fold2 f (f acc x1 x2) l1' l2' 254 | 255 | let rec iter2 f l1 l2 = 256 | match l1 (), l2 () with 257 | | Nil, _ | _, Nil -> () 258 | | Cons (x1, l1'), Cons (x2, l2') -> 259 | f x1 x2; 260 | iter2 f l1' l2' 261 | 262 | let rec for_all2 f l1 l2 = 263 | match l1 (), l2 () with 264 | | Nil, _ | _, Nil -> true 265 | | Cons (x1, l1'), Cons (x2, l2') -> f x1 x2 && for_all2 f l1' l2' 266 | 267 | let rec exists2 f l1 l2 = 268 | match l1 (), l2 () with 269 | | Nil, _ | _, Nil -> false 270 | | Cons (x1, l1'), Cons (x2, l2') -> f x1 x2 || exists2 f l1' l2' 271 | 272 | let rec zip a b () = 273 | match a (), b () with 274 | | Nil, _ | _, Nil -> Nil 275 | | Cons (x, a'), Cons (y, b') -> Cons ((x, y), zip a' b') 276 | 277 | let unzip l = 278 | let rec first l () = 279 | match l () with 280 | | Nil -> Nil 281 | | Cons ((x, _), tl) -> Cons (x, first tl) 282 | and second l () = 283 | match l () with 284 | | Nil -> Nil 285 | | Cons ((_, y), tl) -> Cons (y, second tl) 286 | in 287 | first l, second l 288 | 289 | let compare cmp gen1 gen2 : int = 290 | let rec aux gen1 gen2 = 291 | match gen1 (), gen2 () with 292 | | Nil, Nil -> 0 293 | | Cons (x1, tl1), Cons (x2, tl2) -> 294 | let c = cmp x1 x2 in 295 | if c <> 0 then 296 | c 297 | else 298 | aux tl1 tl2 299 | | Cons _, Nil -> 1 300 | | Nil, Cons _ -> -1 301 | in 302 | aux gen1 gen2 303 | 304 | let rec find p e = 305 | match e () with 306 | | Nil -> None 307 | | Cons (x, _) when p x -> Some x 308 | | Cons (_, tl) -> find p tl 309 | 310 | let rec find_map f e = 311 | match e () with 312 | | Nil -> None 313 | | Cons (x, tl) -> 314 | (match f x with 315 | | None -> find_map f tl 316 | | Some _ as res -> res) 317 | 318 | let sum e = fold ( + ) 0 e 319 | 320 | (** {2 Fair Combinations} *) 321 | 322 | let rec interleave a b () = 323 | match a () with 324 | | Nil -> b () 325 | | Cons (x, tail) -> Cons (x, interleave b tail) 326 | 327 | let rec flat_map_interleave f a () = 328 | match a () with 329 | | Nil -> Nil 330 | | Cons (x, tail) -> 331 | let y = f x in 332 | interleave y (flat_map_interleave f tail) () 333 | 334 | let rec app_interleave f a () = 335 | match f () with 336 | | Nil -> Nil 337 | | Cons (f1, fs) -> interleave (map f1 a) (app_interleave fs a) () 338 | 339 | let rec flatten l () = 340 | match l () with 341 | | Nil -> Nil 342 | | Cons (x, tl) -> flat_app_ x tl () 343 | 344 | and flat_app_ l l' () = 345 | match l () with 346 | | Nil -> flatten l' () 347 | | Cons (x, tl) -> Cons (x, flat_app_ tl l') 348 | 349 | let rec take n (l : 'a t) () = 350 | if n = 0 then 351 | Nil 352 | else ( 353 | match l () with 354 | | Nil -> Nil 355 | | Cons (x, l') -> Cons (x, take (n - 1) l') 356 | ) 357 | 358 | let rec take_while p l () = 359 | match l () with 360 | | Nil -> Nil 361 | | Cons (x, l') -> 362 | if p x then 363 | Cons (x, take_while p l') 364 | else 365 | Nil 366 | 367 | let rec drop n (l : 'a t) () = 368 | match l () with 369 | | l' when n = 0 -> l' 370 | | Nil -> Nil 371 | | Cons (_, l') -> drop (n - 1) l' () 372 | 373 | let rec drop_while p l () = 374 | match l () with 375 | | Nil -> Nil 376 | | Cons (x, l') when p x -> drop_while p l' () 377 | | Cons _ as res -> res 378 | 379 | let rec fold_while f acc gen = 380 | match gen () with 381 | | Nil -> acc 382 | | Cons (x, tl) -> 383 | let acc, cont = f acc x in 384 | (match cont with 385 | | `Stop -> acc 386 | | `Continue -> fold_while f acc tl) 387 | 388 | let scan f acc g : _ t = 389 | let rec aux f acc g () = 390 | match g () with 391 | | Nil -> Cons (acc, empty) 392 | | Cons (x, tl) -> 393 | let acc' = f acc x in 394 | Cons (acc, aux f acc' tl) 395 | in 396 | aux f acc g 397 | 398 | let unfold_scan f acc g = 399 | let rec aux f acc g () = 400 | match g () with 401 | | Nil -> Nil 402 | | Cons (x, tl) -> 403 | let acc, res = f acc x in 404 | Cons (res, aux f acc tl) 405 | in 406 | aux f acc g 407 | 408 | let product_with f l1 l2 = 409 | (* take next element from [l1] *) 410 | let rec loop l1 () = 411 | match l1 () with 412 | | Nil -> Nil 413 | | Cons (x1, tl1) -> 414 | let seq = interleave (map (fun x2 -> f x1 x2) l2) (loop tl1) in 415 | seq () 416 | in 417 | loop l1 418 | 419 | let product l1 l2 = product_with (fun x y -> x, y) l1 l2 420 | let app fs xs = product_with (fun f x -> f x) fs xs 421 | 422 | module Infix = struct 423 | let[@inline] ( >>= ) xs f = flat_map f xs 424 | let[@inline] ( >|= ) xs f = map f xs 425 | let[@inline] ( >>| ) xs f = map f xs 426 | let ( <*> ) = app 427 | let ( -- ) = ( -- ) 428 | let ( --^ ) = ( --^ ) 429 | let[@inline] ( let+ ) x f = map f x 430 | let[@inline] ( let* ) x f = flat_map f x 431 | let ( and+ ) = product 432 | let ( and* ) = product 433 | end 434 | 435 | include Infix 436 | 437 | let product3 l1 l2 l3 = 438 | (fun x1 x2 x3 -> x1, x2, x3) |> return <*> l1 <*> l2 <*> l3 439 | 440 | let product4 l1 l2 l3 l4 = 441 | (fun x1 x2 x3 x4 -> x1, x2, x3, x4) |> return <*> l1 <*> l2 <*> l3 <*> l4 442 | 443 | let product5 l1 l2 l3 l4 l5 = 444 | (fun x1 x2 x3 x4 x5 -> x1, x2, x3, x4, x5) 445 | |> return <*> l1 <*> l2 <*> l3 <*> l4 <*> l5 446 | 447 | let product6 l1 l2 l3 l4 l5 l6 = 448 | (fun x1 x2 x3 x4 x5 x6 -> x1, x2, x3, x4, x5, x6) 449 | |> return <*> l1 <*> l2 <*> l3 <*> l4 <*> l5 <*> l6 450 | 451 | let product7 l1 l2 l3 l4 l5 l6 l7 = 452 | (fun x1 x2 x3 x4 x5 x6 x7 -> x1, x2, x3, x4, x5, x6, x7) 453 | |> return <*> l1 <*> l2 <*> l3 <*> l4 <*> l5 <*> l6 <*> l7 454 | 455 | let rec cartesian_product l () = 456 | match l () with 457 | | Nil -> Cons ([], empty) 458 | | Cons (l1, tail) -> 459 | let tail = cartesian_product tail in 460 | product_with (fun x tl -> x :: tl) l1 tail () 461 | 462 | (* cartesian product of lists of lists *) 463 | let map_product_l f l = 464 | let l = map f l in 465 | cartesian_product l 466 | 467 | let rec group eq l () = 468 | match l () with 469 | | Nil -> Nil 470 | | Cons (x, l') -> 471 | Cons (cons x (take_while (eq x) l'), group eq (drop_while (eq x) l')) 472 | 473 | let rec uniq_rec_ eq prev l () = 474 | match prev, l () with 475 | | _, Nil -> Nil 476 | | None, Cons (x, l') -> Cons (x, uniq_rec_ eq (Some x) l') 477 | | Some y, Cons (x, l') -> 478 | if eq x y then 479 | uniq_rec_ eq prev l' () 480 | else 481 | Cons (x, uniq_rec_ eq (Some x) l') 482 | 483 | let uniq eq l = uniq_rec_ eq None l 484 | 485 | let chunks n e = 486 | let rec aux e () = 487 | match e () with 488 | | Nil -> Nil 489 | | Cons (x, tl) -> 490 | let a = Array.make n x in 491 | fill a 1 tl 492 | and fill a i e = 493 | (* fill the array. [i]: current index to fill *) 494 | if i = n then 495 | Cons (a, aux e) 496 | else ( 497 | match e () with 498 | | Nil -> Cons (Array.sub a 0 i, empty) (* last array is not full *) 499 | | Cons (x, tl) -> 500 | a.(i) <- x; 501 | fill a (i + 1) tl 502 | ) 503 | in 504 | aux e 505 | 506 | (* Put [x] between elements of [enum] *) 507 | let intersperse x g = 508 | let rec aux_with_sep g () = 509 | match g () with 510 | | Nil -> Nil 511 | | Cons (y, g') -> Cons (x, cons y (aux_with_sep g')) 512 | in 513 | fun () -> 514 | match g () with 515 | | Nil -> Nil 516 | | Cons (x, g) -> Cons (x, aux_with_sep g) 517 | 518 | (* functional queue *) 519 | module F_queue = struct 520 | type 'a t = { hd: 'a list; tl: 'a list } 521 | (** Queue containing elements of type 'a *) 522 | 523 | let empty = { hd = []; tl = [] } 524 | 525 | (* invariant: if hd=[], then tl=[] *) 526 | let make_ hd tl = 527 | match hd with 528 | | [] -> { hd = List.rev tl; tl = [] } 529 | | _ :: _ -> { hd; tl } 530 | 531 | let list_is_empty = function 532 | | [] -> true 533 | | _ :: _ -> false 534 | 535 | let is_empty q = list_is_empty q.hd 536 | let push x q = make_ q.hd (x :: q.tl) 537 | 538 | let pop_exn q = 539 | match q.hd with 540 | | [] -> 541 | assert (list_is_empty q.tl); 542 | invalid_arg "F_queue.pop_exn" 543 | | x :: hd' -> 544 | let q' = make_ hd' q.tl in 545 | x, q' 546 | end 547 | 548 | type 'a merge_op = Merge_from of 'a t | Merge_start of 'a t t 549 | 550 | let merge gens : _ t = 551 | (* recursive function to get next element 552 | @param q the already produced generators 553 | @param tl the generators still untouched *) 554 | let rec next (q : 'a merge_op F_queue.t) () = 555 | if F_queue.is_empty q then 556 | Nil 557 | else ( 558 | match F_queue.pop_exn q with 559 | | Merge_from g, q' -> yield_from g q' 560 | | Merge_start gens, q' -> 561 | (match gens () with 562 | | Nil -> next q' () 563 | | Cons (g, gens') -> 564 | let q' = F_queue.push (Merge_start gens') q' in 565 | yield_from g q') 566 | ) 567 | and yield_from g q = 568 | match g () with 569 | | Nil -> next q () 570 | | Cons (x, g') -> Cons (x, next (F_queue.push (Merge_from g') q)) 571 | in 572 | let q = F_queue.push (Merge_start gens) F_queue.empty in 573 | next q 574 | 575 | let intersection cmp gen1 gen2 : _ t = 576 | let rec next x1 x2 () = 577 | match x1, x2 with 578 | | Cons (y1, tl1), Cons (y2, tl2) -> 579 | let c = cmp y1 y2 in 580 | if c = 0 (* equal elements, yield! *) then 581 | Cons (y1, fun () -> next (tl1 ()) (tl2 ()) ()) 582 | else if c < 0 (* drop y1 *) then 583 | next (tl1 ()) x2 () 584 | else 585 | (* drop y2 *) 586 | next x1 (tl2 ()) () 587 | | _ -> Nil 588 | in 589 | fun () -> next (gen1 ()) (gen2 ()) () 590 | 591 | let rec zip_with f a b () = 592 | match a (), b () with 593 | | Cons (xa, tla), Cons (xb, tlb) -> Cons (f xa xb, zip_with f tla tlb) 594 | | _ -> Nil 595 | 596 | let sorted_merge cmp gen1 gen2 : _ t = 597 | let rec next x1 x2 () = 598 | match x1, x2 with 599 | | Nil, Nil -> Nil 600 | | Cons (y1, tl1), Cons (y2, tl2) -> 601 | if cmp y1 y2 <= 0 then 602 | Cons (y1, next (tl1 ()) x2) 603 | else 604 | Cons (y2, next x1 (tl2 ())) 605 | | Cons _, Nil -> x1 606 | | Nil, Cons _ -> x2 607 | in 608 | fun () -> next (gen1 ()) (gen2 ()) () 609 | 610 | let round_robin ?(n = 2) gen : _ t list = 611 | let rec start i = 612 | if i = n then 613 | [] 614 | else ( 615 | let g = take_nth n (drop i gen) in 616 | g :: start (i + 1) 617 | ) 618 | in 619 | start 0 620 | 621 | (** {2 Combinatorics} *) 622 | 623 | (* state of the permutation machine. One machine manages one element [x], 624 | and depends on a deeper machine [g] that generates permutations of the 625 | list minus this element (down to the empty list). 626 | The machine can do two things: 627 | - insert the element in the current list of [g], at any position 628 | - obtain the next list of [g] 629 | *) 630 | 631 | let permutations l = 632 | let rec aux n l = 633 | match l with 634 | | [] -> 635 | assert (n = 0); 636 | return [] 637 | | x :: tail -> aux (n - 1) tail >>= fun tail -> insert_ x [] tail 638 | (* insert [x] in [tail[i…n]] *) 639 | and insert_ x left right : _ t = 640 | match right with 641 | | [] -> return (List.rev (x :: left)) 642 | | y :: right' -> 643 | cons (List.rev_append left (x :: right)) (insert_ x (y :: left) right') 644 | in 645 | aux (List.length l) l 646 | 647 | let combinations n g = 648 | assert (n >= 0); 649 | let rec make_state n l () = 650 | match n, l () with 651 | | 0, _ -> Cons ([], empty) 652 | | _, Nil -> Nil 653 | | _, Cons (x, tail) -> 654 | let m1 = make_state (n - 1) tail in 655 | let m2 = make_state n tail in 656 | add x m1 m2 () 657 | and add x m1 m2 () = 658 | match m1 () with 659 | | Nil -> m2 () 660 | | Cons (l, m1') -> Cons (x :: l, add x m1' m2) 661 | in 662 | make_state n g 663 | 664 | let power_set g : _ t = 665 | let rec make_state l () = 666 | match l with 667 | | [] -> Cons ([], empty) 668 | | x :: tail -> 669 | let m = make_state tail in 670 | add x m () 671 | and add x m () = 672 | match m () with 673 | | Nil -> Nil 674 | | Cons (l, m') -> Cons (x :: l, cons l (add x m')) 675 | in 676 | let l = fold (fun acc x -> x :: acc) [] g in 677 | make_state l 678 | 679 | (** {2 Conversions} *) 680 | 681 | let rec to_rev_list_rec_ acc l = 682 | match l () with 683 | | Nil -> acc 684 | | Cons (x, l') -> to_rev_list_rec_ (x :: acc) l' 685 | 686 | let to_rev_list l = to_rev_list_rec_ [] l 687 | 688 | let to_list l = 689 | let rec direct i (l : 'a t) = 690 | match l () with 691 | | Nil -> [] 692 | | _ when i = 0 -> List.rev (to_rev_list_rec_ [] l) 693 | | Cons (x, f) -> x :: direct (i - 1) f 694 | in 695 | direct 200 l 696 | 697 | let of_list l = 698 | let rec aux l () = 699 | match l with 700 | | [] -> Nil 701 | | x :: l' -> Cons (x, aux l') 702 | in 703 | aux l 704 | 705 | let of_array ?(start = 0) ?len a = 706 | let len = 707 | match len with 708 | | Some l -> l 709 | | None -> Array.length a - start 710 | in 711 | let rec aux a i () = 712 | if i = len then 713 | Nil 714 | else 715 | Cons (a.(i), aux a (i + 1)) 716 | in 717 | aux a start 718 | 719 | let to_array l = 720 | match l () with 721 | | Nil -> [||] 722 | | Cons (x, _) -> 723 | let n = length l in 724 | let a = Array.make n x in 725 | (* need first elem to create [a] *) 726 | iteri (fun i x -> a.(i) <- x) l; 727 | a 728 | 729 | let to_buffer buf g = iter (Buffer.add_char buf) g 730 | 731 | let of_string ?(start = 0) ?len s = 732 | let len = 733 | match len with 734 | | None -> String.length s - start 735 | | Some n -> 736 | assert (n + start < String.length s); 737 | n 738 | in 739 | let rec aux i () = 740 | if i >= start + len then 741 | Nil 742 | else ( 743 | let x = s.[i] in 744 | Cons (x, aux (i + 1)) 745 | ) 746 | in 747 | aux 0 748 | 749 | let to_string s = 750 | let buf = Buffer.create 16 in 751 | to_buffer buf s; 752 | Buffer.contents buf 753 | 754 | let concat_string ~sep s = 755 | match s () with 756 | | Nil -> "" 757 | | Cons (x, tl) -> 758 | let sep_len = String.length sep in 759 | let len = 760 | fold (fun len s -> String.length s + sep_len + len) (String.length x) tl 761 | in 762 | let bytes = Bytes.make len '\000' in 763 | let (_ : int) = 764 | fold 765 | (fun off s -> 766 | let slen = String.length s in 767 | assert (off + slen <= len); 768 | Bytes.unsafe_blit (Bytes.unsafe_of_string s) 0 bytes off slen; 769 | if off + slen < len then ( 770 | (* not the last chunk *) 771 | Bytes.unsafe_blit 772 | (Bytes.unsafe_of_string sep) 773 | 0 bytes (off + slen) sep_len; 774 | off + slen + sep_len 775 | ) else 776 | off + slen) 777 | 0 s 778 | in 779 | Bytes.unsafe_to_string bytes 780 | 781 | let rec to_iter res k = 782 | match res () with 783 | | Nil -> () 784 | | Cons (s, f) -> 785 | k s; 786 | to_iter f k 787 | 788 | let to_gen l = 789 | let l = ref l in 790 | fun () -> 791 | match !l () with 792 | | Nil -> None 793 | | Cons (x, l') -> 794 | l := l'; 795 | Some x 796 | 797 | type 'a of_gen_state = Of_gen_thunk of 'a gen | Of_gen_saved of 'a node 798 | 799 | let of_gen g = 800 | let rec consume r () = 801 | match !r with 802 | | Of_gen_saved cons -> cons 803 | | Of_gen_thunk g -> 804 | (match g () with 805 | | None -> 806 | r := Of_gen_saved Nil; 807 | Nil 808 | | Some x -> 809 | let tl = consume (ref (Of_gen_thunk g)) in 810 | let l = Cons (x, tl) in 811 | r := Of_gen_saved l; 812 | l) 813 | in 814 | consume (ref (Of_gen_thunk g)) 815 | 816 | let rec of_gen_transient f () = 817 | match f () with 818 | | None -> Nil 819 | | Some x -> Cons (x, of_gen_transient f) 820 | 821 | let sort cmp l = 822 | let l = to_list l in 823 | of_list (List.sort cmp l) 824 | 825 | let sort_uniq cmp l = 826 | let l = to_list l in 827 | uniq (fun x y -> cmp x y = 0) (of_list (List.sort cmp l)) 828 | 829 | let lines g : _ t = 830 | let rec aux g buf () = 831 | match g () with 832 | | Nil -> 833 | (* only return a non-empty line *) 834 | if Buffer.length buf = 0 then 835 | Nil 836 | else ( 837 | let s = Buffer.contents buf in 838 | Buffer.clear buf; 839 | Cons (s, empty) 840 | ) 841 | | Cons (c, tl) -> 842 | if c = '\n' then ( 843 | let s = Buffer.contents buf in 844 | Buffer.clear buf; 845 | Cons (s, aux tl buf) 846 | ) else ( 847 | Buffer.add_char buf c; 848 | aux tl buf () 849 | ) 850 | in 851 | aux g (Buffer.create 16) 852 | 853 | let unlines g : _ t = 854 | let rec aux g st () = 855 | match st with 856 | | `Stop -> Nil 857 | | `Next -> 858 | (match g () with 859 | | Nil -> Nil 860 | | Cons ("", tl) -> Cons ('\n', aux tl st) (* empty line *) 861 | | Cons (s, tl) -> Cons (s.[0], aux tl (`Consume (s, 1)))) 862 | | `Consume (s, i) when i = String.length s -> Cons ('\n', aux g `Next) 863 | | `Consume (s, i) -> Cons (s.[i], aux g (`Consume (s, i + 1))) 864 | in 865 | aux g `Next 866 | 867 | type 'a memoize = MemoThunk | MemoSave of 'a node | MemoExn of exn 868 | 869 | let rec memoize f = 870 | let r = ref MemoThunk in 871 | fun () -> 872 | match !r with 873 | | MemoSave l -> l 874 | | MemoExn e -> raise e 875 | | MemoThunk -> 876 | (try 877 | let l = 878 | match f () with 879 | | Nil -> Nil 880 | | Cons (x, tail) -> Cons (x, memoize tail) 881 | in 882 | r := MemoSave l; 883 | l 884 | with e -> 885 | r := MemoExn e; 886 | raise e) 887 | 888 | module Generator = struct 889 | type 'a t = 890 | | Skip 891 | | Yield of 'a 892 | | Delay of (unit -> 'a t) 893 | | Append of 'a t * 'a t 894 | 895 | let empty = Skip 896 | let yield x = Yield x 897 | let ( >>= ) x f = Append (x, Delay f) 898 | let delay f = Delay f 899 | 900 | let run (x : 'a t) : 'a seq = 901 | let rec aux l () = 902 | match l with 903 | | [] -> Nil 904 | | Skip :: tl -> aux tl () 905 | | Yield x :: tl -> Cons (x, aux tl) 906 | | Delay f :: tl -> aux (f () :: tl) () 907 | | Append (x1, x2) :: tl -> aux (x1 :: x2 :: tl) () 908 | in 909 | aux [ x ] 910 | end 911 | 912 | module type HashedType = Hashtbl.HashedType 913 | 914 | let group_by_fold (type k) (module K : HashedType with type t = k) ~project 915 | ~fold ~init seq = 916 | let module Tbl = Hashtbl.Make (K) in 917 | (* compute group table *) 918 | let tbl = 919 | lazy 920 | (let tbl = Tbl.create 32 in 921 | iter 922 | (fun x -> 923 | let key = project x in 924 | let acc = try Tbl.find tbl key with Not_found -> init in 925 | let acc = fold acc x in 926 | Tbl.replace tbl key acc) 927 | seq; 928 | Tbl.to_seq tbl) 929 | in 930 | (* delay start *) 931 | fun () -> (Lazy.force tbl) () 932 | 933 | let group_by key ~project seq = 934 | group_by_fold key ~project ~fold:(fun l x -> x :: l) ~init:[] seq 935 | 936 | let group_count key seq = 937 | group_by_fold key ~project:(fun x -> x) ~fold:(fun n _x -> n + 1) ~init:0 seq 938 | 939 | let join_by (type k) (module Key : HashedType with type t = k) ~project_left 940 | ~project_right ~merge seq1 seq2 : _ t = 941 | let module Tbl = Hashtbl.Make (Key) in 942 | let tbl_left = Tbl.create 16 in 943 | let tbl_right = Tbl.create 16 in 944 | 945 | let seq1 = ref seq1 in 946 | let seq2 = ref seq2 in 947 | 948 | let get_l tbl k = try Tbl.find tbl k with Not_found -> [] in 949 | 950 | let next_left = ref true in 951 | let q = Queue.create () in 952 | 953 | let rec gen () = 954 | match Queue.take q with 955 | | x -> Some x 956 | | exception Queue.Empty -> 957 | if !next_left then ( 958 | next_left := false; 959 | match !seq1 () with 960 | | Nil -> () 961 | | Cons (x, tl1) -> 962 | seq1 := tl1; 963 | let key = project_left x in 964 | Tbl.replace tbl_left key (x :: get_l tbl_left key); 965 | (* join [x] with the RHS items that have the same key *) 966 | let ys = get_l tbl_right key in 967 | List.iter 968 | (fun y -> 969 | match merge key x y with 970 | | None -> () 971 | | Some r -> Queue.push r q) 972 | ys 973 | ) else ( 974 | next_left := true; 975 | match !seq2 () with 976 | | Nil -> () 977 | | Cons (y, tl2) -> 978 | seq2 := tl2; 979 | let key = project_right y in 980 | Tbl.replace tbl_right key (y :: get_l tbl_right key); 981 | (* join [y] with the LHS items that have the same key *) 982 | let xs = get_l tbl_left key in 983 | List.iter 984 | (fun x -> 985 | match merge key x y with 986 | | None -> () 987 | | Some r -> Queue.push r q) 988 | xs 989 | ); 990 | gen () 991 | in 992 | memoize (of_gen_transient gen) 993 | 994 | let join_by_fold (type k) (module Key : HashedType with type t = k) 995 | ~project_left ~project_right ~init ~merge seq1 seq2 : _ t = 996 | let module Tbl = Hashtbl.Make (Key) in 997 | let tbl_left = Tbl.create 16 in 998 | let get_l tbl k = try Tbl.find tbl k with Not_found -> [] in 999 | 1000 | (* index all of [seq1] by key *) 1001 | iter 1002 | (fun x -> 1003 | let key = project_left x in 1004 | Tbl.replace tbl_left key (x :: get_l tbl_left key)) 1005 | seq1; 1006 | 1007 | let tbl = Tbl.create 16 in 1008 | 1009 | (* do product by iterating on [seq2] *) 1010 | iter 1011 | (fun y -> 1012 | let key = project_right y in 1013 | let xs = get_l tbl_left key in 1014 | match xs with 1015 | | [] -> () 1016 | | _ -> 1017 | let acc = try Tbl.find tbl key with Not_found -> init in 1018 | let acc = List.fold_left (fun acc x -> merge key x y acc) acc xs in 1019 | Tbl.replace tbl key acc) 1020 | seq2; 1021 | 1022 | Tbl.to_seq tbl |> map snd 1023 | 1024 | module IO = struct 1025 | let with_file_in ?(mode = 0o644) ?(flags = []) filename f = 1026 | let ic = open_in_gen flags mode filename in 1027 | try 1028 | let x = f ic in 1029 | close_in_noerr ic; 1030 | x 1031 | with e -> 1032 | close_in_noerr ic; 1033 | raise e 1034 | 1035 | let with_in ?mode ?flags filename f = 1036 | with_file_in ?mode ?flags filename (fun ic -> 1037 | f @@ of_gen 1038 | @@ fun () -> try Some (input_char ic) with End_of_file -> None) 1039 | 1040 | let with_lines ?mode ?flags filename f = 1041 | with_file_in ?mode ?flags filename (fun ic -> 1042 | f @@ of_gen 1043 | @@ fun () -> try Some (input_line ic) with End_of_file -> None) 1044 | 1045 | let with_file_out ?(mode = 0o644) ?(flags = [ Open_creat; Open_wronly ]) 1046 | filename f = 1047 | let oc = open_out_gen flags mode filename in 1048 | try 1049 | let x = f oc in 1050 | close_out oc; 1051 | x 1052 | with e -> 1053 | close_out_noerr oc; 1054 | raise e 1055 | 1056 | let write_str ?mode ?flags ?(sep = "") filename g = 1057 | with_file_out ?mode ?flags filename (fun oc -> 1058 | iteri 1059 | (fun i s -> 1060 | if i > 0 then output_string oc sep; 1061 | output_string oc s) 1062 | g) 1063 | 1064 | let write ?mode ?flags filename g = 1065 | with_file_out ?mode ?flags filename (fun oc -> 1066 | iter (fun c -> output_char oc c) g) 1067 | 1068 | let write_lines ?mode ?flags filename g = 1069 | with_file_out ?mode ?flags filename (fun oc -> 1070 | iter 1071 | (fun s -> 1072 | output_string oc s; 1073 | output_char oc '\n') 1074 | g) 1075 | end 1076 | 1077 | module type MONAD = sig 1078 | type 'a t 1079 | 1080 | val return : 'a -> 'a t 1081 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 1082 | end 1083 | 1084 | module Traverse (M : MONAD) = struct 1085 | open M 1086 | 1087 | let map_m f l = 1088 | let rec aux acc l = 1089 | match l () with 1090 | | Nil -> return (of_list (List.rev acc)) 1091 | | Cons (x, l') -> f x >>= fun x' -> aux (x' :: acc) l' 1092 | in 1093 | aux [] l 1094 | 1095 | let sequence_m l = map_m (fun x -> x) l 1096 | 1097 | let rec fold_m f acc l = 1098 | match l () with 1099 | | Nil -> return acc 1100 | | Cons (x, l') -> f acc x >>= fun acc' -> fold_m f acc' l' 1101 | end 1102 | 1103 | let pp ?(sep = ",") pp_item fmt l = 1104 | let rec pp fmt l = 1105 | match l () with 1106 | | Nil -> () 1107 | | Cons (x, l') -> 1108 | Format.pp_print_string fmt sep; 1109 | Format.pp_print_cut fmt (); 1110 | pp_item fmt x; 1111 | pp fmt l' 1112 | in 1113 | match l () with 1114 | | Nil -> () 1115 | | Cons (x, l') -> 1116 | pp_item fmt x; 1117 | pp fmt l' 1118 | 1119 | include Seq 1120 | -------------------------------------------------------------------------------- /src/OSeq.mli: -------------------------------------------------------------------------------- 1 | (** OSeq: Functional Iterators *) 2 | 3 | type 'a t = 'a Seq.t 4 | type 'a seq = 'a Seq.t (* alias *) 5 | type 'a iter = ('a -> unit) -> unit 6 | type 'a gen = unit -> 'a option 7 | type 'a equal = 'a -> 'a -> bool 8 | type 'a ord = 'a -> 'a -> int 9 | type 'a printer = Format.formatter -> 'a -> unit 10 | 11 | val empty : 'a t 12 | (** Empty iterator, with no elements *) 13 | 14 | val return : 'a -> 'a t 15 | (** One-element iterator *) 16 | 17 | val cons : 'a -> 'a t -> 'a t 18 | 19 | val repeat : 'a -> 'a t 20 | (** Repeat same element endlessly *) 21 | 22 | val head_exn : 'a t -> 'a 23 | (** Returns first element, or fails. 24 | @raise Invalid_argument on an empty sequence 25 | @since 0.4 *) 26 | 27 | val tail_exn : 'a t -> 'a t 28 | (** Returns list without its first element, or fails. 29 | @raise Invalid_argument on an empty sequence 30 | @since 0.4 *) 31 | 32 | val cycle : 'a t -> 'a t 33 | (** Cycle through the iterator infinitely. The iterator shouldn't be empty. 34 | {[# OSeq.(cycle (1--3) |> take 10 |> to_list);; 35 | - : int list = [1; 2; 3; 1; 2; 3; 1; 2; 3; 1] 36 | ]} 37 | *) 38 | 39 | val iterate : ('a -> 'a) -> 'a -> 'a t 40 | (** [iterate x f] is [[x; f x; f (f x); f (f (f x)); ...]]. 41 | 42 | {[# OSeq.(iterate 0 succ |> take 10 |> to_list);; 43 | - : int list = [0; 1; 2; 3; 4; 5; 6; 7; 8; 9] 44 | ]} 45 | *) 46 | 47 | val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t 48 | (** Dual of {!fold}, with a deconstructing operation. It keeps on 49 | unfolding the ['b] value into a new ['b], and a ['a] which is yielded, 50 | until [None] is returned. 51 | 52 | {[# OSeq.(unfold (fun x -> if x<5 then Some (string_of_int x, x+1) else None) 0 |> to_list);; 53 | - : string list = ["0"; "1"; "2"; "3"; "4"] 54 | ]} 55 | *) 56 | 57 | val repeatedly : (unit -> 'a) -> 'a t 58 | (** Call the same function an infinite number of times (useful for instance 59 | if the function is a random iterator). *) 60 | 61 | val init : int -> (int -> 'a) -> 'a t 62 | (** Calls the function, starting from 0, on increasing indices, up to [n-1]. 63 | [n] must be non-negative. 64 | For instance [init 4 (fun x->x)] will yield 0, 1, 2, and 3. *) 65 | 66 | (** {2 Basic combinators} *) 67 | 68 | val is_empty : _ t -> bool 69 | (** Check whether the iterator is empty. Pops an element, if any *) 70 | 71 | val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 72 | (** Fold on the iterator, tail-recursively. *) 73 | 74 | val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 75 | (** Alias to {!fold} *) 76 | 77 | val foldi : (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b 78 | (** Fold on the iterator, tail-recursively. 79 | @since 0.3 *) 80 | 81 | val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a 82 | (** Fold on non-empty iterators. 83 | @raise Invalid_argument on an empty iterator *) 84 | 85 | val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t 86 | (** Like {!fold}, but keeping successive values of the accumulator. 87 | 88 | {[ 89 | # OSeq.(scan (+) 0 (1--5) |> to_list);; 90 | - : int list = [0; 1; 3; 6; 10; 15] 91 | ]} 92 | *) 93 | 94 | val unfold_scan : ('b -> 'a -> 'b * 'c) -> 'b -> 'a t -> 'c t 95 | (** A mix of {!unfold} and {!scan}. The current state is combined with 96 | the current element to produce a new state, and an output value 97 | of type 'c. *) 98 | 99 | val iter : ('a -> unit) -> 'a t -> unit 100 | (** Iterate on the iterator . *) 101 | 102 | val iteri : (int -> 'a -> unit) -> 'a t -> unit 103 | (** Iterate on elements with their index in the iterator, from 0. *) 104 | 105 | val length : _ t -> int 106 | (** Length of an iterator (linear time). *) 107 | 108 | val map : ('a -> 'b) -> 'a t -> 'b t 109 | (** Lazy map. No iteration is performed now, the function will be called 110 | when the result is traversed. *) 111 | 112 | val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t 113 | (** Lazy map with indexing starting from 0. No iteration is performed now, 114 | the function will be called when the result is traversed. *) 115 | 116 | val app : ('a -> 'b) t -> 'a t -> 'b t 117 | (** Applicative *) 118 | 119 | val fold_map : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t 120 | (** Lazy fold and map. No iteration is performed now, the function will be 121 | called when the result is traversed. The result is 122 | an iterator over the successive states of the fold. 123 | The final accumulator is discarded. 124 | Unlike {!scan}, fold_map does not return the first accumulator. 125 | *) 126 | 127 | val append : 'a t -> 'a t -> 'a t 128 | (** Append the two iterators; the result contains the elements of the first, 129 | then the elements of the second iterator. *) 130 | 131 | val flatten : 'a t t -> 'a t 132 | (** Flatten the iterator of iterators *) 133 | 134 | val flat_map : ('a -> 'b t) -> 'a t -> 'b t 135 | (** Monadic bind; each element is transformed to a sub-iterator 136 | which is then iterated on, before the next element is processed, 137 | and so on. *) 138 | 139 | val app_interleave : ('a -> 'b) t -> 'a t -> 'b t 140 | (** Same as {!app} but interleaves the values of the function 141 | and the argument iterators. 142 | See {!interleave} for more details. 143 | @since 0.4 *) 144 | 145 | val flat_map_interleave : ('a -> 'b t) -> 'a t -> 'b t 146 | (** [flat_map_interleave f seq] is similar to [flat_map f seq], 147 | except that each sub-sequence is interleaved rather than concatenated in 148 | order. See {!interleave} for more details. 149 | @since 0.4 *) 150 | 151 | val mem : ('a -> 'a -> bool) -> 'a -> 'a t -> bool 152 | (** Is the given element, member of the iterator? *) 153 | 154 | val take : int -> 'a t -> 'a t 155 | (** Take at most n elements *) 156 | 157 | val drop : int -> 'a t -> 'a t 158 | (** Drop n elements *) 159 | 160 | val nth : int -> 'a t -> 'a 161 | (** n-th element, or Not_found 162 | @raise Not_found if the iterator contains less than [n] arguments *) 163 | 164 | val take_nth : int -> 'a t -> 'a t 165 | (** [take_nth n g] returns every element of [g] whose index 166 | is a multiple of [n]. For instance [take_nth 2 (1--10) |> to_list] 167 | will return [[1;3;5;7;9]] *) 168 | 169 | val filter : ('a -> bool) -> 'a t -> 'a t 170 | (** Filter out elements that do not satisfy the predicate. *) 171 | 172 | val take_while : ('a -> bool) -> 'a t -> 'a t 173 | (** Take elements while they satisfy the predicate. *) 174 | 175 | val fold_while : ('a -> 'b -> 'a * [ `Stop | `Continue ]) -> 'a -> 'b t -> 'a 176 | (** Fold elements until (['a, `Stop]) is indicated by the accumulator. *) 177 | 178 | val drop_while : ('a -> bool) -> 'a t -> 'a t 179 | (** Drop elements while they satisfy the predicate. *) 180 | 181 | val filter_map : ('a -> 'b option) -> 'a t -> 'b t 182 | (** Maps some elements to 'b, drop the other ones *) 183 | 184 | val zip_index : 'a t -> (int * 'a) t 185 | (** Zip elements with their index in the iterator *) 186 | 187 | val unzip : ('a * 'b) t -> 'a t * 'b t 188 | (** Unzip into two iterators, splitting each pair *) 189 | 190 | val partition : ('a -> bool) -> 'a t -> 'a t * 'a t 191 | (** [partition p l] returns the elements that satisfy [p], 192 | and the elements that do not satisfy [p] *) 193 | 194 | val for_all : ('a -> bool) -> 'a t -> bool 195 | (** Is the predicate true for all elements? *) 196 | 197 | val exists : ('a -> bool) -> 'a t -> bool 198 | (** Is the predicate true for at least one element? *) 199 | 200 | val min : lt:('a -> 'a -> bool) -> 'a t -> 'a 201 | (** Minimum element, according to the given comparison function. 202 | @raise Invalid_argument if the iterator is empty *) 203 | 204 | val max : lt:('a -> 'a -> bool) -> 'a t -> 'a 205 | (** Maximum element, see {!min} 206 | @raise Invalid_argument if the iterator is empty *) 207 | 208 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 209 | (** Equality of iterators. *) 210 | 211 | val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int 212 | (** Lexicographic comparison of iterators. If a iterator is a prefix 213 | of the other one, it is considered smaller. *) 214 | 215 | val find : ('a -> bool) -> 'a t -> 'a option 216 | (** [find p e] returns the first element of [e] to satisfy [p], 217 | or None. *) 218 | 219 | val find_map : ('a -> 'b option) -> 'a t -> 'b option 220 | (** [find_map f e] returns the result of [f] on the first element of [e] 221 | for which it returns [Some _], or [None] otherwise. 222 | @since 0.3 *) 223 | 224 | val sum : int t -> int 225 | (** Sum of all elements *) 226 | 227 | (** {2 Multiple iterators} *) 228 | 229 | val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t 230 | (** Map on the two iterators. Stops once one of them is exhausted.*) 231 | 232 | val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit 233 | (** Iterate on the two iterators. Stops once one of them is exhausted.*) 234 | 235 | val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc 236 | (** Fold the common prefix of the two iterators *) 237 | 238 | val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool 239 | (** Succeeds if all pairs of elements satisfy the predicate. 240 | Ignores elements of an iterator if the other runs dry. *) 241 | 242 | val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool 243 | (** Succeeds if some pair of elements satisfy the predicate. 244 | Ignores elements of an iterator if the other runs dry. *) 245 | 246 | val zip_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t 247 | (** Combine common part of the gens (stops when one is exhausted) *) 248 | 249 | val zip : 'a t -> 'b t -> ('a * 'b) t 250 | (** Zip together the common part of the gens *) 251 | 252 | (** {2 Complex combinators} *) 253 | 254 | val merge : 'a t t -> 'a t 255 | (** Pick elements fairly in each sub-iterator. The merge of gens 256 | [e1, e2, ... ] picks elements in [e1], [e2], 257 | in [e3], [e1], [e2] .... Once an iterator is empty, it is skipped; 258 | when they are all empty, and none remains in the input, 259 | their merge is also empty. 260 | For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *) 261 | 262 | val intersection : ('a -> 'a -> int) -> 'a t -> 'a t -> 'a t 263 | (** Intersection of two sorted iterators. Only elements that occur in both 264 | inputs appear in the output *) 265 | 266 | val sorted_merge : ('a -> 'a -> int) -> 'a t -> 'a t -> 'a t 267 | (** Merge two sorted iterators into a sorted iterator *) 268 | 269 | val round_robin : ?n:int -> 'a t -> 'a t list 270 | (** Split the iterator into [n] iterators in a fair way. Elements with 271 | [index = k mod n] with go to the k-th iterator. [n] default value 272 | is 2. *) 273 | 274 | val interleave : 'a t -> 'a t -> 'a t 275 | (** [interleave a b] yields an element of [a], then an element of [b], 276 | and so on. When one of the iterators is exhausted, this behaves like the 277 | other iterator. 278 | *) 279 | 280 | val intersperse : 'a -> 'a t -> 'a t 281 | (** Put the separator element between all elements of the given iterator *) 282 | 283 | val product : 'a t -> 'b t -> ('a * 'b) t 284 | (** Cartesian product, in no predictable order. Works even if some of the 285 | arguments are infinite. *) 286 | 287 | val product3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 288 | (** Cartesian product of three iterators, see product. 289 | @since 0.2 *) 290 | 291 | val product4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t 292 | (** Cartesian product of four iterators, see product. 293 | @since 0.2 *) 294 | 295 | val product5 : 296 | 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t 297 | (** Cartesian product of five iterators, see product. 298 | @since 0.2 *) 299 | 300 | val product6 : 301 | 'a t -> 302 | 'b t -> 303 | 'c t -> 304 | 'd t -> 305 | 'e t -> 306 | 'f t -> 307 | ('a * 'b * 'c * 'd * 'e * 'f) t 308 | (** Cartesian product of six iterators, see product. 309 | @since 0.2 *) 310 | 311 | val product7 : 312 | 'a t -> 313 | 'b t -> 314 | 'c t -> 315 | 'd t -> 316 | 'e t -> 317 | 'f t -> 318 | 'g t -> 319 | ('a * 'b * 'c * 'd * 'e * 'f * 'g) t 320 | (** Cartesian product of seven iterators, see product. 321 | @since 0.2 *) 322 | 323 | val cartesian_product : 'a t t -> 'a list t 324 | (** Produce the cartesian product of this sequence of sequences, 325 | by returning all the ways of picking one element per sequence. 326 | {b NOTE} the order of the returned sequence is unspecified. 327 | 328 | This assumes each sub-sequence is finite, and that the main sequence 329 | is also finite. 330 | 331 | For example: 332 | {[ 333 | # cartesian_product [[1;2];[3];[4;5;6]] |> sort = 334 | [[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]];; 335 | # cartesian_product [[1;2];[];[4;5;6]] = [];; 336 | # cartesian_product [[1;2];[3];[4];[5];[6]] |> sort = 337 | [[1;3;4;5;6];[2;3;4;5;6]];; 338 | ]} 339 | invariant: [cartesian_product l = map_product_l id l]. 340 | @since 0.2 *) 341 | 342 | val map_product_l : ('a -> 'b t) -> 'a t -> 'b list t 343 | (** [map_product_l f l] maps each element of [l] to a list of 344 | objects of type ['b] using [f]. 345 | We obtain [[l1;l2;...;ln]] where [length l=n] and [li : 'b list]. 346 | Then, it returns all the ways of picking exactly one element per [li]. 347 | @since 0.2 *) 348 | 349 | val group : ('a -> 'a -> bool) -> 'a t -> 'a t t 350 | (** Group equal consecutive elements together. *) 351 | 352 | val uniq : ('a -> 'a -> bool) -> 'a t -> 'a t 353 | (** Remove consecutive duplicate elements. Basically this is 354 | like [fun e -> map List.hd (group e)]. *) 355 | 356 | val sort : ('a -> 'a -> int) -> 'a t -> 'a t 357 | (** Sort according to the given comparison function. The iterator must be finite. *) 358 | 359 | val sort_uniq : ('a -> 'a -> int) -> 'a t -> 'a t 360 | (** Sort and remove duplicates. The iterator must be finite. *) 361 | 362 | val chunks : int -> 'a t -> 'a array t 363 | (** [chunks n e] returns a iterator of arrays of length [n], composed 364 | of successive elements of [e]. The last array may be smaller 365 | than [n] *) 366 | 367 | val permutations : 'a list -> 'a list t 368 | (** Permutations of the list. *) 369 | 370 | val combinations : int -> 'a t -> 'a list t 371 | (** Combinations of given length. The ordering of the elements within 372 | each combination is unspecified. 373 | Example (ignoring ordering): 374 | [combinations 2 (1--3) |> to_list = [[1;2]; [1;3]; [2;3]]] *) 375 | 376 | val power_set : 'a t -> 'a list t 377 | (** All subsets of the iterator (in no particular order). The ordering of 378 | the elements within each subset is unspecified. *) 379 | 380 | (** {2 Relational combinators} *) 381 | 382 | module type HashedType = Hashtbl.HashedType 383 | (** A type that can be compared and hashed. 384 | invariant: for any [x] and [y], if [equal x y] then [hash x=hash y] must hold. 385 | 386 | @since 0.4 *) 387 | 388 | val group_by : 389 | (module HashedType with type t = 'key) -> 390 | project:('a -> 'key) -> 391 | 'a t -> 392 | ('key * 'a list) t 393 | (** Group together elements that project onto the same key, 394 | ignoring their order of appearance. The order of each resulting list 395 | is unspecified. 396 | 397 | This function needs to consume the whole input before it can emit anything. 398 | 399 | @since 0.4 *) 400 | 401 | val group_by_fold : 402 | (module HashedType with type t = 'key) -> 403 | project:('a -> 'key) -> 404 | fold:('b -> 'a -> 'b) -> 405 | init:'b -> 406 | 'a t -> 407 | ('key * 'b) t 408 | (** Group together elements that project onto the same key, 409 | folding them into some aggregate of type ['b] as they are met. 410 | This is the most general version of the "group_by" functions. 411 | 412 | This function needs to consume the whole input before it can emit anything. 413 | @since 0.4 *) 414 | 415 | val group_count : (module HashedType with type t = 'a) -> 'a t -> ('a * int) t 416 | (** Map each distinct element to its number of occurrences in the whole seq. 417 | Similar to 418 | [group_by_fold hash_key ~project:(fun x->x) ~fold:(fun a _->a+1) ~init:0 seq]. 419 | 420 | This function needs to consume the whole input before it can emit anything. 421 | @since 0.4 *) 422 | 423 | val join_by : 424 | (module HashedType with type t = 'key) -> 425 | project_left:('a -> 'key) -> 426 | project_right:('b -> 'key) -> 427 | merge:('key -> 'a -> 'b -> 'c option) -> 428 | 'a t -> 429 | 'b t -> 430 | 'c t 431 | (** [join_by ~project_left ~project_right ~merge a b] takes every pair 432 | of elements [x] from [a] and [y] from [b], and if they map onto the 433 | same key [k] by [project_left] and [project_right] respectively, 434 | and if [merge k x y = Some res], then it yields [res]. 435 | 436 | If [merge k x y] returns [None], the combination 437 | of values is discarded. 438 | 439 | This function works with infinite inputs, it does not have to consume 440 | the whole input before yielding elements. 441 | 442 | @since 0.4 *) 443 | 444 | val join_by_fold : 445 | (module HashedType with type t = 'key) -> 446 | project_left:('a -> 'key) -> 447 | project_right:('b -> 'key) -> 448 | init:'c -> 449 | merge:('key -> 'a -> 'b -> 'c -> 'c) -> 450 | 'a t -> 451 | 'b t -> 452 | 'c t 453 | (** [join_by_fold ~project_left ~project_right ~init ~merge a b] takes every pair 454 | of elements [x] from [a] and [y] from [b], and if they map onto the 455 | same key [k] by [project_left] and [project_right] respectively, 456 | it fold [x] and [y] into the accumulator for this key (which starts at [init]). 457 | 458 | This function consumes both inputs entirely before it emits anything. 459 | 460 | @since 0.4 *) 461 | 462 | (** {2 Basic conversion functions} *) 463 | 464 | val of_list : 'a list -> 'a t 465 | (** Enumerate elements of the list *) 466 | 467 | val to_list : 'a t -> 'a list 468 | (** non tail-call trasnformation to list, in the same order *) 469 | 470 | val to_rev_list : 'a t -> 'a list 471 | (** Tail call conversion to list, in reverse order (more efficient) *) 472 | 473 | val to_array : 'a t -> 'a array 474 | (** Convert the iterator to an array (not very efficient). 475 | The iterator must be memoized, as it's traversed twice. *) 476 | 477 | val of_array : ?start:int -> ?len:int -> 'a array -> 'a t 478 | (** Iterate on (a slice of) the given array *) 479 | 480 | val of_gen : 'a gen -> 'a t 481 | (** Build a functional iterator from a mutable, imperative generator. 482 | The result is properly memoized and can be iterated on several times, 483 | as a normal functional value. *) 484 | 485 | val of_gen_transient : 'a gen -> 'a t 486 | (** Build a functional iterator from a mutable, imperative generator. 487 | Note that the resulting iterator is not going to be really functional 488 | because the underlying generator can be consumed only once. 489 | Use {!memoize} to recover the proper semantics, or use {!of_gen} 490 | directly. *) 491 | 492 | val to_gen : 'a t -> 'a gen 493 | (** Build a mutable iterator that traverses this functional iterator. 494 | @since 0.4 *) 495 | 496 | val of_string : ?start:int -> ?len:int -> string -> char t 497 | (** Iterate on bytes of the string *) 498 | 499 | val to_string : char t -> string 500 | (** Convert into a string *) 501 | 502 | val to_buffer : Buffer.t -> char t -> unit 503 | (** Traverse the iterator and writes its content to the buffer *) 504 | 505 | val to_iter : 'a t -> 'a iter 506 | (** Iterate on the whole sequence. 507 | @since 0.4 *) 508 | 509 | val concat_string : sep:string -> string t -> string 510 | (** [concat_string ~sep s] concatenates all strings of [i], separated with [sep]. 511 | The iterator must be memoized. 512 | @since 0.3 *) 513 | 514 | val lines : char t -> string t 515 | (** Group together chars belonging to the same line *) 516 | 517 | val unlines : string t -> char t 518 | (** Explode lines into their chars, adding a ['\n'] after each one *) 519 | 520 | module Infix : sig 521 | val ( -- ) : int -> int -> int t 522 | (** Integer range, inclusive *) 523 | 524 | val ( --^ ) : int -> int -> int t 525 | (** Integer range, exclusive in the right bound *) 526 | 527 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 528 | (** Monadic bind operator *) 529 | 530 | val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t 531 | (** Infix map operator *) 532 | 533 | val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t 534 | (** Infix map operator *) 535 | 536 | val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t 537 | 538 | val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t 539 | (** Alias for {!map} 540 | @since 0.5 *) 541 | 542 | val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t 543 | (** Alias for {!product} 544 | @since 0.5 *) 545 | 546 | val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t 547 | (** Alias for {!flat_map} 548 | @since 0.5 *) 549 | 550 | val ( and* ) : 'a t -> 'b t -> ('a * 'b) t 551 | (** Alias for {!product} 552 | @since 0.5 *) 553 | end 554 | 555 | include module type of Infix 556 | 557 | val pp : ?sep:string -> 'a printer -> 'a t printer 558 | (** Pretty print the content of the iterator on a formatter. *) 559 | 560 | val memoize : 'a t -> 'a t 561 | (** Store content of the transient iterator in memory, to be able to iterate 562 | on it several times later. *) 563 | 564 | (** {2 Easy interface to Produce Iterators} *) 565 | 566 | (** This interface is designed to make it easy to build complex streams of 567 | values in a way that resembles Python's generators (using "yield"). 568 | 569 | {[ 570 | let naturals : int OSeq.t = OSeq.Generator.( 571 | let rec aux n = yield n >>= fun () -> aux (n+1) in 572 | run (aux 0) 573 | ) 574 | ]} 575 | 576 | {[ 577 | type 'a tree = E | N of 'a tree * 'a * 'a tree 578 | 579 | let traverse (t:'a tree) : 'a OSeq.t = 580 | let open OSeq.Generator in 581 | let rec trav = function 582 | | E -> empty 583 | | N (l,v,r) -> trav l >>= fun () -> yield v >>= fun () -> trav r 584 | in 585 | run (trav t) 586 | ]} 587 | 588 | *) 589 | module Generator : sig 590 | type 'a t 591 | (** Type for writing generators (of type ['a OSeq.Generator.t]) 592 | that can be used to construct an iterator of type ['a OSeq.t] *) 593 | 594 | val empty : 'a t 595 | (** Empty generator, yields no value *) 596 | 597 | val yield : 'a -> 'a t 598 | (** Yield one value *) 599 | 600 | val ( >>= ) : 'a t -> (unit -> 'a t) -> 'a t 601 | (** [gen1 >>= fun () -> gen2] first yields all values from [gen1], 602 | and then all values from [gen2] *) 603 | 604 | val delay : (unit -> 'a t) -> 'a t 605 | (** Delayed generator, will evaluate the function when needed *) 606 | 607 | val run : 'a t -> 'a seq 608 | (** Iterator over the values yielded by the generator *) 609 | end 610 | 611 | (** {2 Basic IO} *) 612 | module IO : sig 613 | val with_in : 614 | ?mode:int -> ?flags:open_flag list -> string -> (char t -> 'a) -> 'a 615 | (** [with_in filename f] opens [filename] and calls [f g], 616 | where [g] is a generator of characters from the file. 617 | The generator is only valid within 618 | the scope in which [f] is called. *) 619 | 620 | val with_lines : 621 | ?mode:int -> ?flags:open_flag list -> string -> (string t -> 'a) -> 'a 622 | (** [with_lines filename f] opens file [filename] and calls [f g], 623 | where [g] is a generator that iterates on the lines from the file. 624 | Do not use the generator outside of the scope of [f] *) 625 | 626 | val write_str : 627 | ?mode:int -> 628 | ?flags:open_flag list -> 629 | ?sep:string -> 630 | string -> 631 | string t -> 632 | unit 633 | (** [write_to filename g] writes all strings from [g] into the given 634 | file. It takes care of opening and closing the file. Does not 635 | add [sep] after the last string. 636 | @param mode default [0o644] 637 | @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. 638 | @param sep separator between each string (e.g. newline) *) 639 | 640 | val write : ?mode:int -> ?flags:open_flag list -> string -> char t -> unit 641 | (** Same as {!write_str} but with individual characters *) 642 | 643 | val write_lines : 644 | ?mode:int -> ?flags:open_flag list -> string -> string t -> unit 645 | (** [write_lines file g] is similar to [write_str file g ~sep:"\n"] but 646 | also adds ['\n'] at the end of the file *) 647 | end 648 | 649 | (** {2 Monadic Operations} *) 650 | module type MONAD = sig 651 | type 'a t 652 | 653 | val return : 'a -> 'a t 654 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 655 | end 656 | 657 | module Traverse (M : MONAD) : sig 658 | val sequence_m : 'a M.t t -> 'a t M.t 659 | val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t 660 | val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t 661 | end 662 | 663 | include module type of Seq with type 'a node = 'a Seq.node and type 'a t := 'a t 664 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets flambda.flags) 3 | (deps (file mkflags.ml)) 4 | (mode fallback) 5 | (action (run ocaml ./mkflags.ml))) 6 | 7 | (library 8 | (name oseq) 9 | (public_name oseq) 10 | (wrapped false) 11 | (modules OSeq) 12 | (flags :standard -safe-string -warn-error -a+8) 13 | (ocamlopt_flags :standard (:include flambda.flags))) 14 | -------------------------------------------------------------------------------- /src/mkflags.ml: -------------------------------------------------------------------------------- 1 | 2 | let () = 3 | let major, minor = 4 | Scanf.sscanf Sys.ocaml_version "%u.%u" 5 | (fun major minor -> major, minor) 6 | in 7 | let after_4_3 = (major, minor) >= (4, 3) in 8 | let flags_file = open_out "flambda.flags" in 9 | if after_4_3 then ( 10 | output_string flags_file "(-O3 -unbox-closures -unbox-closures-factor 20 -color always)\n"; 11 | ) else ( 12 | output_string flags_file "()\n"; 13 | ); 14 | close_out flags_file 15 | -------------------------------------------------------------------------------- /src/mkshims.ml: -------------------------------------------------------------------------------- 1 | 2 | let code_before_407 = 3 | {| 4 | let rec seq_of_list_ l () = 5 | match l with 6 | | [] -> Seq.Nil 7 | | x :: tl -> Seq.Cons (x, seq_of_list_ tl) 8 | module Tbl_make(H:Hashtbl.HashedType) = struct 9 | include Hashtbl.Make(H) 10 | 11 | let to_seq tbl = 12 | let l = fold (fun k v l -> (k,v) :: l) tbl [] in 13 | seq_of_list_ l 14 | end|} 15 | 16 | let code_after_407 = 17 | {|module Tbl_make = Hashtbl.Make 18 | |} 19 | 20 | let () = 21 | let major, minor = 22 | Scanf.sscanf Sys.ocaml_version "%u.%u" 23 | (fun major minor -> major, minor) 24 | in 25 | let after_4_7 = (major, minor) >= (4, 7) in 26 | if after_4_7 then ( 27 | print_string code_after_407 28 | ) else ( 29 | print_string code_before_407 30 | ) 31 | -------------------------------------------------------------------------------- /tests/unit/dune: -------------------------------------------------------------------------------- 1 | 2 | (tests 3 | (names t_oseq) 4 | (libraries oseq containers qcheck-core qcheck-core.runner ounit2)) 5 | -------------------------------------------------------------------------------- /tests/unit/t_oseq.ml: -------------------------------------------------------------------------------- 1 | module Q = QCheck 2 | open OSeq 3 | 4 | let spf = Printf.sprintf 5 | let pp_ilist = Q.Print.(list int) 6 | let plist f l = "[" ^ String.concat ";" (List.map f l) ^ "]" 7 | let ppair f1 f2 (x, y) = Printf.sprintf "(%s,%s)" (f1 x) (f2 y) 8 | let pint i = string_of_int i 9 | let popt p x = Q.Print.option p x 10 | let pilist l = plist pint l 11 | let pistrlist l = plist (ppair pint (spf "%S")) l 12 | let pilistlist l = plist (plist pint) l 13 | let pi2list l = plist (ppair pint pint) l 14 | let pstrlist l = plist (Printf.sprintf "%S") l 15 | let lsort l = List.sort Stdlib.compare l 16 | let ofll l = l |> of_list |> map of_list 17 | 18 | let cmp_lii_unord l1 l2 : bool = 19 | List.sort Stdlib.compare l1 = List.sort Stdlib.compare l2 20 | 21 | (* list of qcheck tests *) 22 | let qchecks = ref [] 23 | let ounits = ref [] 24 | 25 | let add_qcheck line gen prop = 26 | let test = Q.Test.make gen prop ~name:(spf "qcheck %d" line) in 27 | qchecks := test :: !qchecks 28 | 29 | let add_ounit f = ounits := f :: !ounits 30 | 31 | (* compat test, ensure Seq.t and OSeq.t are the same *) 32 | let () = 33 | add_ounit @@ fun () -> 34 | ignore (Seq.empty : int OSeq.t); 35 | ignore (OSeq.empty : int Seq.t) 36 | 37 | let () = 38 | add_ounit @@ fun () -> 39 | let seq = empty in 40 | OUnit.assert_bool "empty" (is_empty seq); 41 | OUnit.assert_bool "empty" 42 | (try 43 | iter (fun _ -> raise Exit) seq; 44 | true 45 | with Exit -> false) 46 | 47 | let () = 48 | add_ounit @@ fun () -> 49 | OUnit.assert_equal ~printer:pilist [ 0; 1; 2; 3; 4; 5 ] (0 -- 5 |> to_list); 50 | OUnit.assert_equal ~printer:pilist [ 0 ] (0 -- 0 |> to_list); 51 | OUnit.assert_equal ~printer:pilist [ 5; 4; 3; 2 ] (5 -- 2 |> to_list) 52 | 53 | let () = 54 | add_ounit @@ fun () -> 55 | OUnit.assert_equal ~printer:pilist [ 1; 2; 3; 4 ] (1 --^ 5 |> to_list); 56 | OUnit.assert_equal ~printer:pilist [ 5; 4; 3; 2 ] (5 --^ 1 |> to_list); 57 | OUnit.assert_equal ~printer:pilist [ 1 ] (1 --^ 2 |> to_list); 58 | OUnit.assert_equal ~printer:pilist [] (0 --^ 0 |> to_list) 59 | 60 | let () = 61 | add_ounit @@ fun () -> 62 | OUnit.assert_equal ~printer:pilist 63 | (repeat 0 |> take 4 |> to_list) 64 | [ 0; 0; 0; 0 ]; 65 | OUnit.assert_equal ~printer:pilist (repeat 1 |> take 0 |> to_list) [] 66 | 67 | let () = 68 | add_ounit @@ fun () -> 69 | OUnit.assert_equal ~printer:pilist [ 0; 1; 2; 3; 4 ] 70 | (init 5 (fun i -> i) |> to_list) 71 | 72 | let () = 73 | add_ounit @@ fun () -> 74 | OUnit.assert_equal ~printer:pi2list 75 | [ 0, 1; 1, 2; 2, 3 ] 76 | (mapi (fun i x -> i, x) (1 -- 3) |> to_list) 77 | 78 | let () = 79 | add_ounit @@ fun () -> 80 | OUnit.assert_equal ~printer:pilist [ 6; 12; 18; 24; 30 ] 81 | (filter_map 82 | (fun x -> 83 | if x mod 2 = 0 then 84 | Some (x * 3) 85 | else 86 | None) 87 | (1 -- 10) 88 | |> to_list) 89 | 90 | let () = 91 | add_ounit @@ fun () -> 92 | OUnit.assert_equal ~printer:pilist [ 0; 1; 2; 3; 4 ] 93 | (iterate (( + ) 1) 0 |> take 5 |> to_list) 94 | 95 | let () = 96 | add_ounit @@ fun () -> 97 | OUnit.assert_equal ~printer:pistrlist 98 | [ 1, "b"; 0, "a" ] 99 | (foldi (fun i acc x -> (i, x) :: acc) [] (of_list [ "a"; "b" ])) 100 | 101 | let () = 102 | add_ounit @@ fun () -> 103 | OUnit.assert_equal ~printer:pilist [ 1; 2; 1; 2; 1 ] 104 | (cycle (of_list [ 1; 2 ]) |> take 5 |> to_list); 105 | OUnit.assert_equal ~printer:pint 0 106 | (cycle (of_list [ 1; ~-1 ]) |> take 100_000 |> fold ( + ) 0) 107 | 108 | let () = 109 | add_ounit @@ fun () -> 110 | OUnit.assert_equal ~printer:pilist 111 | [ 0; 1; 2; 3; 4; 5; 6; 7; 8; 9 ] 112 | (let f = function 113 | | 10 -> None 114 | | x -> Some (x, x + 1) 115 | in 116 | unfold f 0 |> to_list) 117 | 118 | let () = 119 | add_qcheck __LINE__ 120 | Q.(pair (fun1 Observable.int (small_list int)) (small_list int)) 121 | (fun (f, l) -> 122 | of_list l 123 | |> flat_map (fun x -> of_list (Q.Fn.apply f x)) 124 | |> to_list 125 | = CCList.flat_map (Q.Fn.apply f) l) 126 | 127 | let () = 128 | add_qcheck __LINE__ 129 | Q.(pair (fun1 Observable.int (small_list int)) (small_list int)) 130 | (fun (f, l) -> 131 | of_list l 132 | |> flat_map (fun x -> of_list (Q.Fn.apply f x)) 133 | |> to_list 134 | = (of_list l |> map (Q.Fn.apply f) |> map of_list |> flatten |> to_list)) 135 | 136 | let () = 137 | add_ounit @@ fun () -> 138 | OUnit.assert_equal ~printer:pint 4 (nth 4 (0 -- 10)); 139 | OUnit.assert_equal ~printer:pint 8 (nth 8 (0 -- 10)) 140 | 141 | let () = 142 | add_ounit @@ fun () -> 143 | OUnit.assert_bool "t" 144 | (try 145 | ignore (nth 11 (1 -- 10)); 146 | false 147 | with Not_found -> true) 148 | 149 | let () = 150 | add_ounit @@ fun () -> 151 | OUnit.assert_equal ~printer:pint ~-2 152 | (min ~lt:( < ) (of_list [ 1; 4; 6; 0; 11; -2 ])); 153 | OUnit.assert_bool "t" 154 | (try 155 | ignore (min ~lt:( < ) empty); 156 | false 157 | with Invalid_argument _ -> true) 158 | 159 | let () = 160 | add_ounit @@ fun () -> 161 | OUnit.assert_equal ~printer:pint 11 162 | (max ~lt:( < ) (of_list [ 1; 4; 6; 0; 11; -2 ])); 163 | OUnit.assert_bool "t" 164 | (try 165 | ignore (max ~lt:( < ) empty); 166 | false 167 | with Invalid_argument _ -> true) 168 | 169 | let () = 170 | add_qcheck __LINE__ 171 | (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) 172 | (fun (l1, l2) -> equal Stdlib.( = ) (of_list l1) (of_list l2) = (l1 = l2)) 173 | 174 | let () = 175 | add_ounit @@ fun () -> 176 | OUnit.assert_equal ~printer:(ppair pilist pilist) 177 | ([ 2; 4; 6; 8; 10 ], [ 1; 3; 5; 7; 9 ]) 178 | ( partition (fun x -> x mod 2 = 0) (1 -- 10) |> fun (x, y) -> 179 | to_list x, to_list y ) 180 | 181 | let () = 182 | add_ounit @@ fun () -> 183 | OUnit.assert_equal ~printer:pi2list 184 | [ 0, 1; 1, 2; 2, 3; 3, 4; 4, 5 ] 185 | (zip_index (1 -- 5) |> to_list) 186 | 187 | let () = 188 | add_qcheck __LINE__ 189 | Q.(list (pair int int)) 190 | (fun l -> 191 | let l = of_list l in 192 | let a, b = unzip l in 193 | equal ( = ) l (zip a b)) 194 | 195 | let () = 196 | add_qcheck __LINE__ 197 | (Q.pair (Q.list Q.small_int) (Q.list Q.small_int)) 198 | (fun (l1, l2) -> 199 | let sign x = 200 | if x < 0 then 201 | -1 202 | else if x = 0 then 203 | 0 204 | else 205 | 1 206 | in 207 | sign (compare Stdlib.compare (of_list l1) (of_list l2)) 208 | = sign (Stdlib.compare l1 l2)) 209 | 210 | let () = 211 | add_ounit @@ fun () -> 212 | OUnit.assert_equal ~printer:(popt pint) 213 | (find (fun x -> x >= 5) (1 -- 10)) 214 | (Some 5); 215 | OUnit.assert_equal ~printer:(popt pint) (find (fun x -> x > 5) (1 -- 4)) None 216 | 217 | let () = 218 | add_ounit @@ fun () -> 219 | OUnit.assert_equal ~printer:(popt pint) 220 | (find_map 221 | (fun x -> 222 | if x >= 5 then 223 | Some (-x) 224 | else 225 | None) 226 | (1 -- 10)) 227 | (Some (-5)); 228 | OUnit.assert_equal ~printer:(popt pint) 229 | (find_map 230 | (fun x -> 231 | if x > 5 then 232 | Some (-x) 233 | else 234 | None) 235 | (1 -- 4)) 236 | None; 237 | OUnit.assert_equal ~printer:(popt pint) 238 | (find_map (fun _ -> None) (1 -- 10)) 239 | None 240 | 241 | let () = 242 | add_ounit @@ fun () -> OUnit.assert_equal ~printer:pint (sum (1 -- 10)) 55 243 | 244 | let () = 245 | add_ounit @@ fun () -> 246 | OUnit.assert_equal ~printer:pilist 247 | (of_list [ 1; 2; 3; 4 ] |> take_while (fun x -> x < 4) |> to_list) 248 | [ 1; 2; 3 ] 249 | 250 | let () = 251 | add_qcheck __LINE__ 252 | (Q.pair (Q.list Q.small_int) Q.small_int) 253 | (fun (l, n) -> 254 | let s = of_list l in 255 | let s1, s2 = take n s, drop n s in 256 | append s1 s2 |> to_list = l) 257 | 258 | let () = 259 | add_ounit @@ fun () -> 260 | OUnit.assert_equal ~printer:pint 2 261 | (fold_while 262 | (fun acc b -> 263 | if b then 264 | acc + 1, `Continue 265 | else 266 | acc, `Stop) 267 | 0 268 | (of_list [ true; true; false; true ])) 269 | 270 | let () = 271 | add_ounit @@ fun () -> 272 | OUnit.assert_equal ~printer:(plist pilist) 273 | [ []; [ 2 ]; [ 3; 2 ]; [ 4; 3; 2 ]; [ 5; 4; 3; 2 ]; [ 6; 5; 4; 3; 2 ] ] 274 | (scan (fun acc x -> (x + 1) :: acc) [] (1 -- 5) |> to_list) 275 | 276 | let () = 277 | add_ounit @@ fun () -> 278 | OUnit.assert_equal ~printer:pilist [ 0; 1; 3; 6; 10 ] 279 | (unfold_scan (fun acc x -> x + acc, acc) 0 (1 -- 5) |> to_list) 280 | 281 | let () = 282 | add_qcheck __LINE__ 283 | Q.(pair (small_list int) (small_list int)) 284 | (fun (l1, l2) -> 285 | lsort (List.flatten @@ List.map (fun x -> List.map (fun y -> x, y) l2) l1) 286 | = lsort (product (of_list l1) (of_list l2) |> to_list)) 287 | 288 | let () = 289 | add_ounit @@ fun () -> 290 | let l = 291 | product (of_list [ true; false ]) (1 -- max_int) |> take 10 |> to_list 292 | in 293 | OUnit.assert_bool "a bit fair" (List.exists (fun (b, _) -> b = false) l) 294 | 295 | let () = 296 | add_ounit @@ fun () -> 297 | OUnit.assert_equal ~printer:(plist pilist) ~cmp:cmp_lii_unord 298 | [ 299 | [ 1; 3; 4 ]; 300 | [ 1; 3; 5 ]; 301 | [ 1; 3; 6 ]; 302 | [ 2; 3; 4 ]; 303 | [ 2; 3; 5 ]; 304 | [ 2; 3; 6 ]; 305 | ] 306 | (to_list @@ cartesian_product @@ ofll [ [ 1; 2 ]; [ 3 ]; [ 4; 5; 6 ] ]); 307 | OUnit.assert_equal ~printer:(plist pilist) ~cmp:cmp_lii_unord [] 308 | (to_list @@ cartesian_product @@ ofll [ [ 1; 2 ]; []; [ 4; 5; 6 ] ]); 309 | OUnit.assert_equal ~printer:(plist pilist) ~cmp:cmp_lii_unord [ [] ] 310 | (to_list @@ cartesian_product empty); 311 | OUnit.assert_equal ~printer:(plist pilist) ~cmp:cmp_lii_unord 312 | [ [ 1; 3; 4; 5; 6 ]; [ 2; 3; 4; 5; 6 ] ] 313 | (to_list @@ cartesian_product 314 | @@ ofll [ [ 1; 2 ]; [ 3 ]; [ 4 ]; [ 5 ]; [ 6 ] ]) 315 | 316 | let () = 317 | add_ounit @@ fun () -> 318 | OUnit.assert_equal ~printer:(plist pilist) 319 | [ [ 1; 1; 1 ]; [ 2; 2 ]; [ 3; 3 ]; [ 1 ] ] 320 | (of_list [ 1; 1; 1; 2; 2; 3; 3; 1 ] |> group ( = ) |> map to_list |> to_list) 321 | 322 | let () = 323 | add_qcheck __LINE__ 324 | Q.(small_list int) 325 | (fun l -> of_list l |> group ( = ) |> flatten |> to_list = l) 326 | 327 | let () = 328 | add_ounit @@ fun () -> 329 | OUnit.assert_equal ~printer:(plist pilist) 330 | (List.map to_list [ 0 -- 24; 25 -- 49; 50 -- 74; 75 -- 99; 100 -- 100 ]) 331 | (chunks 25 (0 -- 100) |> map Array.to_list |> to_list) 332 | 333 | let () = 334 | add_ounit @@ fun () -> 335 | OUnit.assert_equal ~printer:pilist [] (intersperse 0 empty |> to_list); 336 | OUnit.assert_equal ~printer:pilist [ 1 ] (intersperse 0 (return 1) |> to_list); 337 | OUnit.assert_equal ~printer:pilist 338 | [ 1; 0; 2; 0; 3; 0; 4; 0; 5 ] 339 | (intersperse 0 (1 -- 5) |> to_list) 340 | 341 | let () = 342 | add_ounit @@ fun () -> 343 | OUnit.assert_equal ~printer:pilist 344 | [ 1; 2; 3; 4; 5; 6; 7; 8; 9 ] 345 | (merge 346 | (of_list 347 | [ of_list [ 1; 3; 5 ]; of_list [ 2; 4; 6 ]; of_list [ 7; 8; 9 ] ]) 348 | |> to_list |> List.sort Stdlib.compare); 349 | OUnit.assert_equal ~printer:pilist [ 1; 2; 3; 4; 5; 6 ] 350 | (merge (of_list [ of_list [ 1; 3; 6 ]; of_list [ 2; 5 ]; of_list [ 4 ] ]) 351 | |> to_list) 352 | 353 | let () = 354 | add_ounit @@ fun () -> 355 | OUnit.assert_bool "t" 356 | @@ mem ( = ) (3, 5) 357 | @@ take 20_000 @@ merge 358 | @@ map (fun i -> iterate succ 0 |> map (fun j -> i, j)) 359 | @@ iterate succ 0 360 | 361 | let () = 362 | add_ounit @@ fun () -> 363 | let e = of_list [ 1 -- 3; 4 -- 6; 7 -- 9 ] in 364 | let e' = merge e in 365 | OUnit.assert_equal 366 | [ 1; 2; 3; 4; 5; 6; 7; 8; 9 ] 367 | (to_list e' |> List.sort Stdlib.compare) 368 | 369 | let () = 370 | add_ounit @@ fun () -> 371 | OUnit.assert_equal ~printer:pilist [ 1; 2; 4; 8 ] 372 | (intersection Stdlib.compare 373 | (of_list [ 1; 1; 2; 3; 4; 8 ]) 374 | (of_list [ 1; 2; 4; 5; 6; 7; 8; 9 ]) 375 | |> to_list) 376 | 377 | let () = 378 | add_qcheck __LINE__ (Q.list Q.small_int) (fun l -> 379 | zip_with (fun x y -> x, y) (of_list l) (of_list l) 380 | |> unzip |> fst |> to_list = l) 381 | 382 | let () = 383 | add_ounit @@ fun () -> 384 | let e = zip_with ( + ) (repeat 1) (4 -- 7) in 385 | OUnit.assert_equal [ 5; 6; 7; 8 ] (to_list e) 386 | 387 | let () = 388 | add_ounit @@ fun () -> 389 | OUnit.assert_equal ~printer:pilist 390 | [ 1; 2; 2; 2; 3; 4; 5; 5; 6; 10; 11; 100 ] 391 | (sorted_merge Stdlib.compare 392 | (of_list [ 1; 2; 2; 3; 5; 10; 100 ]) 393 | (of_list [ 2; 4; 5; 6; 11 ]) 394 | |> to_list) 395 | 396 | let () = 397 | add_ounit @@ fun () -> 398 | OUnit.assert_equal ~printer:pilistlist 399 | [ [ 1; 4; 7; 10 ]; [ 2; 5; 8; 11 ]; [ 3; 6; 9; 12 ] ] 400 | (round_robin ~n:3 (1 -- 12) |> List.map to_list) 401 | 402 | let () = 403 | add_ounit @@ fun () -> 404 | let e = round_robin ~n:2 (1 -- 10) in 405 | match e with 406 | | [ a; b ] -> 407 | OUnit.assert_equal ~printer:pilist [ 1; 3; 5; 7; 9 ] (to_list a); 408 | OUnit.assert_equal ~printer:pilist [ 2; 4; 6; 8; 10 ] (to_list b) 409 | | _ -> OUnit.assert_failure "wrong list lenght" 410 | 411 | let () = 412 | add_ounit @@ fun () -> 413 | let e = round_robin ~n:3 (1 -- 999) in 414 | let l = List.map length e in 415 | OUnit.assert_equal ~printer:pilist [ 333; 333; 333 ] l 416 | 417 | let () = 418 | add_ounit @@ fun () -> 419 | OUnit.assert_equal ~printer:pilistlist 420 | [ 421 | [ 1; 2; 3 ]; 422 | [ 1; 3; 2 ]; 423 | [ 2; 1; 3 ]; 424 | [ 2; 3; 1 ]; 425 | [ 3; 1; 2 ]; 426 | [ 3; 2; 1 ]; 427 | ] 428 | (permutations CCList.(1 -- 3) |> to_list |> List.sort Stdlib.compare); 429 | OUnit.assert_equal ~printer:pilistlist [ [] ] (permutations [] |> to_list); 430 | OUnit.assert_equal ~printer:pilistlist [ [ 1 ] ] 431 | (permutations [ 1 ] |> to_list) 432 | 433 | let () = 434 | add_ounit @@ fun () -> 435 | OUnit.assert_equal ~printer:pilistlist 436 | [ [ 1; 2 ]; [ 1; 3 ]; [ 1; 4 ]; [ 2; 3 ]; [ 2; 4 ]; [ 3; 4 ] ] 437 | (combinations 2 (1 -- 4) 438 | |> map (List.sort Stdlib.compare) 439 | |> to_list |> List.sort Stdlib.compare); 440 | OUnit.assert_equal ~printer:pilistlist [ [] ] 441 | (combinations 0 (1 -- 4) |> to_list); 442 | OUnit.assert_equal ~printer:pilistlist [ [ 1 ] ] 443 | (combinations 1 (return 1) |> to_list) 444 | 445 | let () = 446 | add_ounit @@ fun () -> 447 | OUnit.assert_equal ~printer:pilistlist 448 | [ []; [ 1 ]; [ 1; 2 ]; [ 1; 2; 3 ]; [ 1; 3 ]; [ 2 ]; [ 2; 3 ]; [ 3 ] ] 449 | (power_set (1 -- 3) 450 | |> map (List.sort Stdlib.compare) 451 | |> to_list |> List.sort Stdlib.compare); 452 | OUnit.assert_equal ~printer:pilistlist [ [] ] (power_set empty |> to_list); 453 | OUnit.assert_equal ~printer:pilistlist [ []; [ 1 ] ] 454 | (power_set (return 1) 455 | |> map (List.sort Stdlib.compare) 456 | |> to_list |> List.sort Stdlib.compare) 457 | 458 | let () = add_qcheck __LINE__ Q.(array int) (fun a -> of_array a |> to_array = a) 459 | 460 | let () = 461 | add_ounit @@ fun () -> 462 | OUnit.assert_equal ~printer:pilist 463 | (of_array [| 1; 2; 3 |] |> to_list) 464 | [ 1; 2; 3 ]; 465 | OUnit.assert_equal ~printer:(Q.Print.array pint) 466 | (of_list [ 1; 2; 3 ] |> to_array) 467 | [| 1; 2; 3 |] 468 | 469 | let () = 470 | add_qcheck __LINE__ 471 | Q.(pair (list string) string) 472 | (fun (s, sep) -> String.concat sep s = concat_string ~sep (of_list s)) 473 | 474 | let () = 475 | add_ounit @@ fun () -> 476 | OUnit.assert_equal ~printer:Q.Print.string 477 | (concat_string ~sep:"" (of_list [ "a"; "b"; "coucou" ])) 478 | "abcoucou"; 479 | OUnit.assert_equal ~printer:Q.Print.string 480 | (concat_string ~sep:"random" (return "a")) 481 | "a"; 482 | OUnit.assert_equal ~printer:Q.Print.string 483 | (concat_string ~sep:"," (of_list [ "a"; "b"; "c"; ""; ""; "d" ])) 484 | "a,b,c,,,d"; 485 | OUnit.assert_equal ~printer:Q.Print.string 486 | (concat_string ~sep:"random" empty) 487 | "" 488 | 489 | let () = 490 | add_ounit @@ fun () -> 491 | let g = 492 | let n = ref 0 in 493 | fun () -> 494 | Some 495 | (incr n; 496 | !n) 497 | in 498 | let l = of_gen g in 499 | OUnit.assert_equal [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ] (take 10 l |> to_list); 500 | OUnit.assert_equal [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ] (take 10 l |> to_list); 501 | OUnit.assert_equal [ 11; 12 ] (drop 10 l |> take 2 |> to_list) 502 | 503 | let () = 504 | add_ounit @@ fun () -> 505 | OUnit.assert_equal ~printer:pstrlist [ "abc"; "de"; "" ] 506 | (lines (of_string "abc\nde\n\n") |> to_list) 507 | 508 | let () = 509 | add_qcheck __LINE__ Q.printable_string (fun s -> 510 | of_string s |> lines |> unlines |> to_string |> String.trim 511 | = String.trim s) 512 | 513 | let () = 514 | add_ounit @@ fun () -> 515 | let naturals = 516 | Generator.( 517 | let rec aux n = yield n >>= fun () -> aux (n + 1) in 518 | run (aux 0)) 519 | in 520 | let naturals' = unfold (fun n -> Some (n, n + 1)) 0 in 521 | OUnit.assert_equal 522 | ~printer:Q.Print.(list int) 523 | (take 100 naturals' |> to_list) 524 | (take 100 naturals |> to_list) 525 | 526 | let () = 527 | add_qcheck __LINE__ 528 | Q.(small_list int) 529 | (fun l -> 530 | let seq = of_list l in 531 | let seq2 = 532 | let open Generator in 533 | let rec aux seq = 534 | match seq () with 535 | | Nil -> empty 536 | | Cons (x, tl) -> yield x >>= fun () -> aux tl 537 | in 538 | run (aux seq) 539 | in 540 | equal Stdlib.( = ) seq seq2) 541 | 542 | module IntK = struct 543 | type t = int 544 | 545 | let equal = ( = ) 546 | let hash x = x land max_int 547 | end 548 | 549 | let () = 550 | add_ounit @@ fun () -> 551 | [ 1; 2; 3; 3; 2; 2; 3; 4 ] |> of_list 552 | |> group_by (module IntK) ~project:(fun x -> x) 553 | |> map snd |> sort Stdlib.compare |> to_list 554 | |> OUnit.assert_equal [ [ 1 ]; [ 2; 2; 2 ]; [ 3; 3; 3 ]; [ 4 ] ] 555 | 556 | (* test for compat with seq *) 557 | module Foo : module type of Seq = OSeq 558 | 559 | let () = 560 | Printf.printf "running unit tests…\n%!"; 561 | List.iter (fun t -> t ()) !ounits; 562 | Printf.printf "ran %d unit tests\n%!" (List.length !ounits); 563 | 564 | Printf.printf "running qcheck tests…\n%!"; 565 | let errcode = QCheck_base_runner.run_tests ~colors:false !qchecks in 566 | if errcode <> 0 then exit errcode 567 | --------------------------------------------------------------------------------