├── .github └── workflows │ ├── gh-pages.yml │ └── main.yml ├── .gitignore ├── .header ├── LICENSE ├── Makefile ├── README.md ├── dune ├── dune-project ├── lwt-pipe.opam ├── qtest ├── Makefile └── dune └── src ├── Lwt_pipe.ml ├── Lwt_pipe.mli └── dune /.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@v2 22 | with: 23 | ocaml-version: '4.13.0' 24 | 25 | - name: Pin 26 | run: opam pin -n . 27 | 28 | - name: Depext 29 | run: opam depext -yt lwt-pipe 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 | - ubuntu-latest 16 | #- macos-latest 17 | #- windows-latest 18 | ocaml-compiler: 19 | - 4.03.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 lwt-pipe 29 | - run: opam install -t . --deps-only 30 | - run: opam exec -- dune build 31 | - run: opam exec -- dune runtest 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.native 3 | *.docdir 4 | *.install 5 | .merlin 6 | -------------------------------------------------------------------------------- /.header: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Simon Cruanes 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. Redistributions in binary 9 | form must reproduce the above copyright notice, this list of conditions and 10 | the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 17 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 19 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 20 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 21 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 22 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all build clean install 2 | 3 | all: build test 4 | 5 | build: 6 | @dune build @install 7 | 8 | clean: 9 | @dune clean 10 | 11 | install: 12 | @dune install 13 | 14 | test: build 15 | @dune runtest --force --no-buffer 16 | 17 | doc: 18 | dune build @doc 19 | 20 | watch: 21 | @dune build @all -w 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lwt Pipe [![build](https://github.com/c-cube/lwt-pipe/actions/workflows/main.yml/badge.svg)](https://github.com/c-cube/lwt-pipe/actions/workflows/main.yml) 2 | 3 | An alternative to `Lwt_stream` with interfaces for producers and consumers 4 | and a bounded internal buffer. 5 | 6 | [Online Documentation](https://c-cube.github.io/lwt-pipe/) 7 | 8 | ## Build 9 | 10 | ``` 11 | opam install lwt-pipe 12 | ``` 13 | 14 | or: 15 | 16 | ``` 17 | opam pin https://github.com/c-cube/lwt-pipe.git 18 | ``` 19 | 20 | ## License 21 | 22 | permissive free software (BSD-2) 23 | 24 | ## Use 25 | 26 | A pipe can be used as a regular iterator: 27 | 28 | ```ocaml 29 | # #require "lwt";; 30 | # #require "lwt-pipe";; 31 | 32 | # open Lwt.Infix;; 33 | 34 | # let l = [1;2;3;4];; 35 | val l : int list = [1; 2; 3; 4] 36 | 37 | # Lwt_pipe.of_list l 38 | |> Lwt_pipe.Reader.map ~f:(fun x->x+1) 39 | |> Lwt_pipe.to_list;; 40 | - : int list = [2; 3; 4; 5] 41 | ``` 42 | 43 | But also as a streaming queue (here with two producers `push_ints` that will 44 | put `1, 2, … 5` into the pipe, and one reader that consumes the whole pipe): 45 | 46 | ```ocaml 47 | # let rec push_ints p i : unit Lwt.t = 48 | if i <= 0 then Lwt.return () 49 | else Lwt_pipe.write_exn p i >>= fun () -> push_ints p (i-1) ;; 50 | val push_ints : (int, [< `r | `w > `w ]) Lwt_pipe.t -> int -> unit Lwt.t = 51 | 52 | 53 | # let reader = 54 | let p = Lwt_pipe.create ~max_size:3 () in 55 | let t1 = push_ints p 5 56 | and t2 = push_ints p 5 57 | and t_read = Lwt_pipe.to_list p in 58 | Lwt.join [t1;t2] >>= fun () -> 59 | Lwt_pipe.close p >>= fun () -> 60 | t_read 61 | in 62 | List.sort compare @@ Lwt_main.run reader 63 | ;; 64 | - : int list = [1; 1; 2; 2; 3; 3; 4; 4; 5; 5] 65 | ``` 66 | 67 | This can be expressed with higher level constructs: 68 | 69 | 70 | ```ocaml 71 | # let rec list_range i = if i<=0 then [] else i :: list_range (i-1);; 72 | val list_range : int -> int list = 73 | # let int_range n = Lwt_pipe.of_list @@ list_range n ;; 74 | val int_range : int -> int Lwt_pipe.Reader.t = 75 | 76 | # Lwt_main.run @@ Lwt_pipe.to_list (int_range 5);; 77 | - : int list = [5; 4; 3; 2; 1] 78 | 79 | # let reader = 80 | let p1 = int_range 6 81 | and p2 = int_range 6 82 | and p3 = int_range 6 in 83 | Lwt_pipe.to_list (Lwt_pipe.Reader.merge_all [p1;p2;p3]) 84 | in 85 | List.sort compare @@ Lwt_main.run reader 86 | ;; 87 | - : int list = [1; 1; 1; 2; 2; 2; 3; 3; 3; 4; 4; 4; 5; 5; 5; 6; 6; 6] 88 | ``` 89 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | 2 | (rule 3 | (alias runtest) 4 | (deps (:readme README.md)) 5 | (action (progn 6 | (run ocaml-mdx test %{readme}) 7 | (diff? %{readme} %{readme}.corrected)))) 8 | 9 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | -------------------------------------------------------------------------------- /lwt-pipe.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "lwt-pipe" 3 | version: "0.1" 4 | author: "Simon Cruanes" 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | synopsis: "An alternative to `Lwt_stream` with interfaces for producers and consumers and a bounded internal buffer" 7 | build: [ 8 | ["dune" "build" "@install" "-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" {>= "2.0"} 14 | "lwt" 15 | "ocaml" { >= "4.03.0" } 16 | "mdx" {with-test} 17 | "qcheck" {with-test} 18 | "qtest" {with-test} 19 | "odoc" {with-doc} 20 | ] 21 | tags: [ "lwt" "pipe" "stream" "blocking" ] 22 | homepage: "https://github.com/c-cube/lwt-pipe/" 23 | dev-repo: "git+https://github.com/c-cube/lwt-pipe.git" 24 | bug-reports: "https://github.com/c-cube/lwt-pipe/issues/" 25 | 26 | -------------------------------------------------------------------------------- /qtest/Makefile: -------------------------------------------------------------------------------- 1 | 2 | DONTTEST= 3 | QTESTABLE=$(filter-out $(DONTTEST), \ 4 | $(wildcard ../src/*.ml) \ 5 | $(wildcard ../src/*.mli) \ 6 | ) 7 | 8 | qtest-gen: 9 | @rm run_qtest.ml 2>/dev/null || true 10 | @if which qtest > /dev/null ; then \ 11 | qtest extract \ 12 | -o run_qtest.ml \ 13 | $(QTESTABLE) 2> /dev/null ; \ 14 | else touch run_qtest.ml ; \ 15 | fi 16 | 17 | .PHONY: qtest-gen 18 | -------------------------------------------------------------------------------- /qtest/dune: -------------------------------------------------------------------------------- 1 | 2 | (rule 3 | (targets run_qtest.ml) 4 | (deps Makefile (source_tree ../src)) ; (glob_files ../src/**/*.ml{,i}))) 5 | (mode fallback) 6 | (action (run make qtest-gen))) 7 | 8 | (executable 9 | (name run_qtest) 10 | (flags :standard -warn-error -a+8 -safe-string -w -33) 11 | (libraries lwt-pipe qcheck)) 12 | 13 | (rule 14 | (alias runtest) 15 | (deps (:bin run_qtest.exe)) 16 | (action (run %{bin}))) 17 | 18 | -------------------------------------------------------------------------------- /src/Lwt_pipe.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | open Lwt.Infix 5 | 6 | exception Closed 7 | 8 | type 'a read_timeout_result = 9 | | Pipe_closed 10 | | Nothing_available 11 | | Timeout 12 | | Data_available of 'a 13 | 14 | type 'a reader = { 15 | r_wakeup: 'a read_timeout_result Lwt.u; 16 | mutable r_timeout: bool; 17 | } 18 | 19 | type ('a, +'perm) t = { 20 | close : unit Lwt.u; 21 | closed : unit Lwt.t; 22 | mutable stopped: bool; (* if true, no more input will come *) 23 | readers : 'a reader Queue.t; (* blocked readers *) 24 | buf : 'a Queue.t; (* internal buffers of written values *) 25 | blocked_writers : ('a * bool Lwt.u) Queue.t; (* blocked writers *) 26 | max_size : int; 27 | mutable keep : unit Lwt.t list; (* do not GC, and wait for completion *) 28 | } constraint 'perm = [< `r | `w] 29 | 30 | type ('a, 'perm) pipe = ('a, 'perm) t 31 | 32 | let create ?on_close ?(max_size=0) () = 33 | let closed, close = Lwt.wait () in 34 | begin match on_close with 35 | | None -> () 36 | | Some f -> Lwt.on_success closed f 37 | end; 38 | { 39 | close; 40 | closed; 41 | stopped=false; 42 | readers = Queue.create (); 43 | buf = Queue.create (); 44 | blocked_writers = Queue.create (); 45 | max_size; 46 | keep=[]; 47 | } 48 | 49 | let keep p fut = p.keep <- fut :: p.keep 50 | let wait p = p.closed 51 | let is_closed p = not (Lwt.is_sleeping p.closed) 52 | 53 | let close_ p = 54 | if not p.stopped then ( 55 | assert (not (is_closed p)); 56 | p.stopped <- true; 57 | assert (Queue.is_empty p.readers || Queue.is_empty p.buf); 58 | Queue.iter 59 | (fun {r_wakeup;_} -> Lwt.wakeup r_wakeup Pipe_closed) 60 | p.readers; 61 | Queue.iter (fun (_,r) -> Lwt.wakeup r false) p.blocked_writers; 62 | if Queue.length p.buf = 0 then ( 63 | Lwt.wakeup p.close (); (* close immediately *) 64 | ); 65 | ) 66 | 67 | let close_nonblock p = 68 | if not p.stopped then ( 69 | close_ p 70 | ) 71 | 72 | let close p = 73 | if not p.stopped then ( 74 | close_nonblock p; 75 | p.closed >>= fun () -> 76 | Lwt.join p.keep 77 | ) else ( 78 | p.closed 79 | ) 80 | 81 | (*$T is_closed; create 82 | create () |> is_closed |> not 83 | *) 84 | 85 | (*$T close; is_closed; create 86 | let p = create () in \ 87 | Lwt_main.run (close p); \ 88 | is_closed p 89 | *) 90 | 91 | (*$T close_nonblock; is_closed; create 92 | let p = create () in \ 93 | close_nonblock p; \ 94 | is_closed p 95 | *) 96 | 97 | let opt_of_available = function 98 | | Data_available x -> Some x 99 | | _ -> None 100 | 101 | let read_ t ~timeout : 'a read_timeout_result Lwt.t = 102 | let timeout_function s (r:_ reader) = 103 | Lwt_unix.sleep s >>= fun () -> 104 | r.r_timeout <- true; 105 | Lwt.return Timeout 106 | in 107 | if not (Queue.is_empty t.buf) then ( 108 | let x = Queue.pop t.buf in 109 | (* some writer may unblock *) 110 | if not (Queue.is_empty t.blocked_writers) && Queue.length t.buf < t.max_size then ( 111 | let y, signal_done = Queue.pop t.blocked_writers in 112 | Queue.push y t.buf; 113 | Lwt.wakeup signal_done true; 114 | ); 115 | Lwt.return (Data_available x) 116 | ) else if t.stopped then ( 117 | (* empty buf + stopped *) 118 | close_nonblock t; 119 | Lwt.return Pipe_closed 120 | ) else if Queue.is_empty t.blocked_writers then ( 121 | let fut, r_wakeup = Lwt.wait () in 122 | let r = {r_wakeup; r_timeout=false} in 123 | Queue.push r t.readers; 124 | match timeout with 125 | | None -> fut 126 | | Some s -> Lwt.pick [fut; timeout_function s r] 127 | ) else ( 128 | assert (t.max_size = 0); 129 | let x, signal_done = Queue.pop t.blocked_writers in 130 | Lwt.wakeup signal_done true; 131 | Lwt.return (Data_available x) 132 | ) 133 | 134 | let read_with_timeout t ~timeout = 135 | read_ t ~timeout 136 | 137 | (*$= read_with_timeout 138 | (read_with_timeout ~timeout:(Some 0.001) (create ()) |> Lwt_main.run) (Timeout) 139 | (read_with_timeout ~timeout:(Some 0.001) (of_list [1]) |> Lwt_main.run) (Data_available 1) 140 | (read_with_timeout ~timeout:(Some 0.001) (of_list []) |> Lwt_main.run) (Pipe_closed) 141 | *) 142 | 143 | (*$Q read_with_timeout 144 | Q.(small_list int) (fun l -> \ 145 | let result = match l with \ 146 | | [] -> Pipe_closed \ 147 | | h::_ -> Data_available h \ 148 | in \ 149 | of_list l |> read_with_timeout ~timeout:(Some 0.001) |> Lwt_main.run = result) 150 | *) 151 | 152 | let read t = 153 | read_ t ~timeout:None >|= opt_of_available 154 | 155 | let enqueue_into_writers t x = 156 | if Queue.length t.buf < t.max_size then ( 157 | Queue.push x t.buf; 158 | Lwt.return true (* into buffer, do not wait *) 159 | ) else ( 160 | (* block until the queue isn't full anymore *) 161 | let is_done, signal_done = Lwt.wait () in 162 | Queue.push (x, signal_done) t.blocked_writers; 163 | is_done 164 | ) 165 | 166 | (* write a value *) 167 | let rec write_rec_ (t:('a,_) pipe) (x:'a) = 168 | if t.stopped then ( 169 | Lwt.return_false 170 | ) else if Queue.length t.readers > 0 then ( 171 | (* some reader waits, synchronize now *) 172 | let r = Queue.pop t.readers in 173 | if r.r_timeout then ( 174 | (* if timeout occurred the corresponding reader has already received 175 | a Timeout value and shoud be discarded. The value [x] is processed 176 | again by [write_step] *) 177 | write_rec_ t x 178 | ) else ( 179 | (* timeout = false *) 180 | Lwt.wakeup r.r_wakeup (Data_available x); 181 | Lwt.return true 182 | ) 183 | ) else ( 184 | enqueue_into_writers t x 185 | ) 186 | 187 | let rec connect_rec r w = 188 | read_with_timeout ~timeout:None r >>= function 189 | | Data_available x -> 190 | write_rec_ w x >>= fun ok -> 191 | if ok then connect_rec r w else Lwt.return_unit 192 | | _ -> Lwt.return_unit 193 | 194 | (* close a when b closes *) 195 | let link_close p ~after = 196 | Lwt.on_termination after.closed 197 | (fun _ -> close_nonblock p) 198 | 199 | let connect ?(ownership=`None) a b = 200 | let fut = connect_rec a b in 201 | keep b fut; 202 | match ownership with 203 | | `None -> () 204 | | `InOwnsOut -> Lwt.on_termination fut (fun () -> close_nonblock b) 205 | | `OutOwnsIn -> Lwt.on_termination fut (fun () -> close_nonblock a) 206 | 207 | (*$Q connect 208 | Q.(small_list int) (fun l -> \ 209 | let p1 = of_list l in \ 210 | let p2 = create () in \ 211 | connect ~ownership:`InOwnsOut p1 p2; \ 212 | Lwt_main.run (to_list p2) = l) 213 | *) 214 | 215 | let write_exn t x = 216 | write_rec_ t x >>= fun ok -> 217 | if ok then Lwt.return_unit 218 | else Lwt.fail Closed 219 | 220 | let write = write_rec_ 221 | 222 | (*$QR read; write 223 | Q.(int) (fun i -> 224 | let p = create () in 225 | let w = write p i in 226 | let r = read p in 227 | Lwt.bind w (fun b -> 228 | Lwt.bind r (fun r -> 229 | match r with 230 | | None -> Lwt.return false 231 | | Some r -> Lwt.return (b && r = i))) 232 | |> Lwt_main.run) 233 | *) 234 | (*$QR read; write 235 | Q.(small_list int) (fun l -> 236 | let p = create () in 237 | let w = write p l in 238 | let r = read p in 239 | Lwt.bind w (fun b -> 240 | Lwt.bind r (fun r -> 241 | match r with 242 | | None -> Lwt.return false 243 | | Some r -> Lwt.return (b && r = l))) 244 | |> Lwt_main.run) 245 | *) 246 | 247 | let rec write_list t l = match l with 248 | | [] -> Lwt.return true 249 | | x :: tail -> 250 | let fut = write t x in 251 | fut >>= fun b -> 252 | if b then write_list t tail else fut 253 | 254 | let write_list_exn t l = 255 | write_list t l >>= fun ok -> 256 | if ok then Lwt.return_unit 257 | else Lwt.fail Closed 258 | 259 | let to_stream p = 260 | Lwt_stream.from (fun () -> read p) 261 | 262 | let of_stream s = 263 | let p = create () in 264 | let rec send s = Lwt_stream.get s >>= fun result -> 265 | match result with 266 | | None -> Lwt.return_unit 267 | | Some elt -> write p elt >>= fun ok -> 268 | if ok then send s else Lwt.return_unit 269 | in 270 | let fut = send s in 271 | keep p fut; 272 | Lwt.on_termination fut (fun () -> close_nonblock p); 273 | p 274 | 275 | module Writer = struct 276 | type 'a t = ('a, [`w]) pipe 277 | 278 | let map ~f a = 279 | let b = create() in 280 | let rec fwd_rec () = 281 | read b >>= function 282 | | Some x -> 283 | write a (f x) >>= fun ok -> 284 | if ok then fwd_rec () else Lwt.return_unit 285 | | None -> Lwt.return_unit 286 | in 287 | let fwd = fwd_rec() in 288 | keep b fwd; 289 | (* when [fwd_rec] stops because a gets closed, close b too *) 290 | Lwt.on_termination fwd (fun () -> close_nonblock b); 291 | b 292 | 293 | let send_all l = 294 | if l = [] then invalid_arg "send_all"; 295 | let res = create () in 296 | let rec fwd () = 297 | read res >>= function 298 | | None -> Lwt.return_unit 299 | | Some x -> Lwt_list.iter_p (fun p -> write_exn p x) l >>= fwd 300 | in 301 | (* do not GC before res dies; close res when any outputx is closed *) 302 | keep res (fwd ()); 303 | List.iter (fun out -> link_close res ~after:out) l; 304 | res 305 | 306 | let send_both a b = send_all [a; b] 307 | end 308 | 309 | module Reader = struct 310 | type 'a t = ('a, [`r]) pipe 311 | 312 | let map ~f a = 313 | let b = create () in 314 | let rec fwd_rec () = 315 | read a >>= function 316 | | Some x -> 317 | write b (f x) >>= fun ok -> 318 | if ok then fwd_rec () else Lwt.return_unit 319 | | None -> Lwt.return_unit 320 | in 321 | let fwd = fwd_rec() in 322 | keep b fwd; 323 | Lwt.on_termination fwd (fun () -> close_nonblock b); 324 | b 325 | 326 | (*$Q 327 | Q.(pair (fun1 Observable.string int) (small_list small_string)) (fun (f,l) -> \ 328 | let pipe = of_list l in \ 329 | Lwt_main.run (to_list (Reader.map ~f:(Q.Fn.apply f) pipe)) = \ 330 | List.map (Q.Fn.apply f) l) 331 | *) 332 | 333 | let map_s ~f a = 334 | let b = create () in 335 | let rec fwd_rec () = 336 | read a >>= function 337 | | Some x -> 338 | f x >>= fun y -> 339 | write b y >>= fun ok -> 340 | if ok then fwd_rec () else Lwt.return_unit 341 | | None -> Lwt.return_unit 342 | in 343 | let fwd = fwd_rec() in 344 | keep b fwd; 345 | Lwt.on_termination fwd (fun () -> close_nonblock b); 346 | b 347 | 348 | (*$Q 349 | Q.(pair (fun1 Observable.string int) (small_list small_string)) (fun (f,l) -> \ 350 | let pipe = of_list l in \ 351 | Lwt_main.run (to_list (Reader.map_s ~f:(fun e -> Lwt.return (Q.Fn.apply f e)) pipe)) = \ 352 | List.map (Q.Fn.apply f) l) 353 | *) 354 | 355 | let filter ~f a = 356 | let b = create () in 357 | let rec fwd_rec () = 358 | read a >>= function 359 | | Some x -> 360 | if f x then ( 361 | write b x >>= fun ok -> 362 | if ok then fwd_rec () else Lwt.return_unit 363 | ) else fwd_rec() 364 | | None -> Lwt.return_unit 365 | in 366 | let fwd = fwd_rec() in 367 | keep b fwd; 368 | Lwt.on_termination fwd (fun () -> close_nonblock b); 369 | b 370 | 371 | (*$Q 372 | Q.(pair (fun1 Observable.int bool) (small_list int)) (fun (f,l) -> \ 373 | let pipe = of_list l in \ 374 | Lwt_main.run (to_list (Reader.filter ~f:(Q.Fn.apply f) pipe)) = \ 375 | List.filter (Q.Fn.apply f) l) 376 | *) 377 | 378 | let filter_map ~f a = 379 | let b = create () in 380 | let rec fwd_rec () = 381 | read a >>= function 382 | | Some x -> 383 | begin match f x with 384 | | None -> fwd_rec() 385 | | Some y -> 386 | write b y >>= fun ok -> 387 | if ok then fwd_rec () else Lwt.return_unit 388 | end 389 | | None -> close b 390 | in 391 | let fwd = fwd_rec() in 392 | keep b fwd; 393 | Lwt.on_termination fwd (fun () -> close_nonblock b); 394 | b 395 | 396 | (*$Q 397 | Q.(pair (fun1 Observable.string (option int)) (small_list small_string)) (fun (f,l) -> \ 398 | let pipe = of_list l in \ 399 | Lwt_main.run (to_list (Reader.filter_map ~f:(Q.Fn.apply f) pipe)) = \ 400 | (List.map (Q.Fn.apply f) l \ 401 | |> List.filter (fun x -> x != None) \ 402 | |> List.map (fun x -> match x with Some x -> x | None -> failwith "Impossible"))) 403 | *) 404 | 405 | let filter_map_s ~f a = 406 | let b = create () in 407 | let rec fwd_rec () = 408 | read a >>= function 409 | | Some x -> 410 | f x >>= (function 411 | | None -> fwd_rec() 412 | | Some y -> 413 | write b y >>= fun ok -> 414 | if ok then fwd_rec () else Lwt.return_unit 415 | ) 416 | | None -> Lwt.return_unit 417 | in 418 | let fwd = fwd_rec() in 419 | keep b fwd; 420 | Lwt.on_termination fwd (fun () -> close_nonblock b); 421 | b 422 | 423 | (*$Q 424 | Q.(pair (fun1 Observable.string (option int)) (small_list small_string)) (fun (f,l) -> \ 425 | let pipe = of_list l in \ 426 | Lwt_main.run (to_list (Reader.filter_map_s ~f:(fun e -> Lwt.return (Q.Fn.apply f e)) pipe)) = \ 427 | (List.map (Q.Fn.apply f) l \ 428 | |> List.filter (fun x -> x != None) \ 429 | |> List.map (fun x -> match x with Some x -> x | None -> failwith "Impossible"))) 430 | *) 431 | 432 | let flat_map ~f a = 433 | let b = create () in 434 | let rec fwd_rec () = 435 | read a >>= function 436 | | Some x -> 437 | let l = f x in 438 | write_list b l >>= fun ok -> 439 | if ok then fwd_rec () else Lwt.return_unit 440 | | None -> Lwt.return_unit 441 | in 442 | let fwd = fwd_rec() in 443 | keep b fwd; 444 | Lwt.on_termination fwd (fun () -> close_nonblock b); 445 | b 446 | 447 | (*$Q 448 | Q.(pair (fun1 Observable.string (small_list int)) (small_list small_string)) (fun (f,l) -> \ 449 | let pipe = of_list l in \ 450 | Lwt_main.run (to_list (Reader.flat_map ~f:(Q.Fn.apply f) pipe)) = \ 451 | List.flatten (List.map (Q.Fn.apply f) l)) 452 | *) 453 | 454 | let flat_map_s ~f a = 455 | let b = create () in 456 | let rec fwd_rec () = 457 | read a >>= function 458 | | Some x -> 459 | f x >>= fun l -> 460 | write_list b l >>= fun ok -> 461 | if ok then fwd_rec () else Lwt.return_unit 462 | | None -> Lwt.return_unit 463 | in 464 | let fwd = fwd_rec() in 465 | keep b fwd; 466 | Lwt.on_termination fwd (fun () -> close_nonblock b); 467 | b 468 | 469 | (*$Q 470 | Q.(pair (fun1 Observable.string (small_list int)) (small_list small_string)) (fun (f,l) -> \ 471 | let pipe = of_list l in \ 472 | Lwt_main.run (to_list (Reader.flat_map_s ~f:(fun e -> Lwt.return (Q.Fn.apply f e)) pipe)) = \ 473 | List.flatten (List.map (Q.Fn.apply f) l)) 474 | *) 475 | 476 | let rec fold ~f ~x t = 477 | read t 478 | >>= function 479 | | None -> Lwt.return x 480 | | Some y -> fold ~f ~x:(f x y) t 481 | 482 | (*$Q 483 | Q.(triple (fun2 Observable.int Observable.string int) (small_list small_string) int) (fun (f,l,x) -> \ 484 | let pipe = of_list l in \ 485 | Lwt_main.run (Reader.fold ~f:(Q.Fn.apply f) ~x pipe) = \ 486 | List.fold_left (Q.Fn.apply f) x l) 487 | *) 488 | 489 | let rec fold_s ~f ~x t = 490 | read t >>= function 491 | | None -> Lwt.return x 492 | | Some y -> 493 | f x y >>= fun x -> fold_s ~f ~x t 494 | 495 | (*$Q 496 | Q.(triple (fun2 Observable.int Observable.string int) (small_list small_string) int) (fun (f,l,x) -> \ 497 | let pipe = of_list l in \ 498 | Lwt_main.run (Reader.fold_s ~f:(fun x e -> Lwt.return (Q.Fn.apply f x e)) ~x pipe) = \ 499 | List.fold_left (Q.Fn.apply f) x l) 500 | *) 501 | 502 | let rec iter ~f t = 503 | read t >>= function 504 | | None -> Lwt.return_unit 505 | | Some x -> f x; iter ~f t 506 | 507 | let rec iter_s ~f t = 508 | read t >>= function 509 | | None -> Lwt.return_unit 510 | | Some x -> f x >>= fun () -> iter_s ~f t 511 | 512 | (* util to find in lists *) 513 | let find_map_l f l = 514 | let rec aux f = function 515 | | [] -> None 516 | | x::l' -> 517 | match f x with 518 | | Some _ as res -> res 519 | | None -> aux f l' 520 | in aux f l 521 | 522 | let iter_p ~f t = 523 | let rec iter acc = 524 | read t >>= function 525 | | None -> Lwt.join acc 526 | | Some x -> 527 | (* did any computation fail? *) 528 | let maybe_err = 529 | find_map_l 530 | (fun t -> match Lwt.state t with 531 | | Lwt.Fail e -> Some e | _ -> None) 532 | acc 533 | in 534 | begin match maybe_err with 535 | | None -> 536 | (* continue, removing from [acc] the already terminated functions *) 537 | let acc = List.filter (fun t -> Lwt.state t <> Lwt.Sleep) acc in 538 | iter (f x :: acc) 539 | | Some e -> Lwt.fail e 540 | end 541 | in iter [] 542 | 543 | let merge_all l = 544 | if l = [] then invalid_arg "merge_all"; 545 | let res = create () in 546 | let conns = List.map (fun p -> connect_rec p res) l in 547 | (* when [conns] all done, close [res] *) 548 | res.keep <- conns; 549 | Lwt.async 550 | (fun () -> Lwt.join conns >>= fun () -> close res); 551 | res 552 | 553 | let merge_both a b = merge_all [a; b] 554 | 555 | let append a b = 556 | let c = create () in 557 | connect a c; 558 | Lwt.on_success (wait a) 559 | (fun () -> 560 | let fut = connect_rec b c in 561 | keep c fut; 562 | Lwt.on_termination fut (fun () -> close_nonblock c); 563 | ); 564 | c 565 | end 566 | 567 | (** {2 Conversions} *) 568 | 569 | type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t 570 | 571 | let of_list l : _ Reader.t = 572 | let p = create ~max_size:0 () in 573 | let rec send = function 574 | | [] -> Lwt.return_unit 575 | | h::t -> write p h >>= fun ok -> 576 | if ok then send t else Lwt.return_unit 577 | in 578 | let fut = send l in 579 | keep p fut; 580 | Lwt.on_termination fut (fun () -> close_nonblock p); 581 | p 582 | 583 | let of_array a = 584 | let p = create ~max_size:0 () in 585 | let rec send i = 586 | if i < Array.length a then ( 587 | write p a.(i) >>= fun ok -> 588 | if ok then send (i+1) else Lwt.return_unit 589 | ) else Lwt.return_unit 590 | in 591 | let fut = send 0 in 592 | keep p fut; 593 | Lwt.on_termination fut (fun () -> close_nonblock p); 594 | p 595 | 596 | (*$Q of_array; to_list 597 | Q.(array int) (fun a -> \ 598 | let pipe = of_array a in \ 599 | Lwt_main.run (to_list pipe) = Array.to_list a) 600 | *) 601 | 602 | let of_string a = 603 | let p = create ~max_size:0 () in 604 | let rec send i = 605 | if i < String.length a then ( 606 | write p (String.get a i) >>= fun ok -> 607 | if ok then send (i+1) else Lwt.return_unit 608 | ) else Lwt.return_unit 609 | in 610 | let fut = send 0 in 611 | keep p fut; 612 | Lwt.on_termination fut (fun () -> close_nonblock p); 613 | p 614 | 615 | let of_lwt_klist l = 616 | let p = create ~max_size:0 () in 617 | let rec next l = 618 | l >>= function 619 | | `Nil -> Lwt.return_unit 620 | | `Cons (x, tl) -> 621 | write p x >>= fun ok -> 622 | if ok then next tl else Lwt.return_unit 623 | in 624 | let fut = next l in 625 | keep p fut; 626 | Lwt.on_termination fut (fun () -> close_nonblock p); 627 | p 628 | 629 | let to_list_rev r = 630 | Reader.fold ~f:(fun acc x -> x :: acc) ~x:[] r 631 | 632 | (*$Q of_list; to_list_rev 633 | Q.(small_list int) (fun l -> \ 634 | let pipe = of_list l in \ 635 | Lwt_main.run (to_list_rev pipe) = List.rev l) 636 | *) 637 | 638 | let to_list r = to_list_rev r >|= List.rev 639 | 640 | (*$= to_list; of_list & ~printer:(fun l -> List.map string_of_int l |> String.concat " ") 641 | (of_list [1;2;3] |> to_list |> Lwt_main.run) ([1;2;3]) 642 | *) 643 | 644 | (*$Q of_list; to_list 645 | Q.(small_list int) (fun l -> \ 646 | let pipe = of_list l in \ 647 | Lwt_main.run (to_list pipe) = l) 648 | *) 649 | 650 | let to_buffer buf r = 651 | Reader.iter ~f:(fun c -> Buffer.add_char buf c) r 652 | 653 | let to_buffer_str ?(sep="") buf r = 654 | let first = ref true in 655 | Reader.iter r 656 | ~f:(fun s -> 657 | if !first then first:= false else Buffer.add_string buf sep; 658 | Buffer.add_string buf s) 659 | 660 | let to_string r = 661 | let buf = Buffer.create 128 in 662 | to_buffer buf r >>= fun () -> Lwt.return (Buffer.contents buf) 663 | 664 | (*$Q of_string; to_string 665 | Q.(small_string) (fun s -> \ 666 | let pipe = of_string s in \ 667 | Lwt_main.run (to_string pipe) = s) 668 | *) 669 | 670 | let join_strings ?sep r = 671 | let buf = Buffer.create 128 in 672 | to_buffer_str ?sep buf r >>= fun () -> Lwt.return (Buffer.contents buf) 673 | 674 | (*$Q join_strings 675 | Q.(small_list small_string) (fun l -> \ 676 | let pipe = of_list l in \ 677 | Lwt_main.run (join_strings pipe) = String.concat "" l) 678 | Q.(list string) (fun l -> \ 679 | let pipe = of_list l in \ 680 | Lwt_main.run (join_strings ~sep:" " pipe) = String.concat " " l) 681 | *) 682 | 683 | let to_lwt_klist r = 684 | let rec next () = 685 | read r >>= function 686 | | None -> Lwt.return `Nil 687 | | Some x -> Lwt.return (`Cons (x, next ())) 688 | in 689 | next () 690 | 691 | (** {2 Basic IO wrappers} *) 692 | 693 | module IO = struct 694 | let read ?(bufsize=4096) ic : _ Reader.t = 695 | let buf = Bytes.make bufsize ' ' in 696 | let p = create ~max_size:0 () in 697 | let rec send() = 698 | Lwt_io.read_into ic buf 0 bufsize >>= fun n -> 699 | if n = 0 then ( 700 | Lwt.return_unit 701 | ) else ( 702 | write p (Bytes.sub_string buf 0 n) >>= fun ok -> 703 | if ok then send () else Lwt.return_unit 704 | ) 705 | in 706 | let fut = send () in 707 | keep p fut; 708 | Lwt.on_termination fut (fun () -> close_nonblock p); 709 | p 710 | 711 | let read_lines ic = 712 | let p = create () in 713 | let rec send () = 714 | Lwt_io.read_line_opt ic >>= function 715 | | None -> Lwt.return_unit 716 | | Some line -> 717 | write p line >>= fun ok -> 718 | if ok then send() else Lwt.return_unit 719 | in 720 | let fut = send () in 721 | keep p fut; 722 | Lwt.on_termination fut (fun () -> close_nonblock p); 723 | p 724 | 725 | let write oc = 726 | let p = create () in 727 | let fut = 728 | Reader.iter_s ~f:(Lwt_io.write oc) p >>= fun _ -> 729 | Lwt_io.flush oc 730 | in 731 | keep p fut; 732 | Lwt.on_termination fut (fun () -> close_nonblock p); 733 | p 734 | 735 | let write_lines oc = 736 | let p = create () in 737 | let fut = 738 | Reader.iter_s ~f:(Lwt_io.write_line oc) p >>= fun _ -> 739 | Lwt_io.flush oc >>= fun () -> 740 | close p 741 | in 742 | keep p fut; 743 | Lwt.on_termination fut (fun () -> close_nonblock p); 744 | p 745 | end 746 | -------------------------------------------------------------------------------- /src/Lwt_pipe.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Pipes, Readers, Writers} 5 | 6 | Stream processing using: 7 | 8 | - Pipe: a possibly buffered channel that can act as a reader or as a writer 9 | - Reader: accepts values, produces effects 10 | - Writer: yield values 11 | 12 | Examples: 13 | {[ 14 | #require "lwt";; 15 | 16 | module P = Lwt_pipe;; 17 | 18 | let p1 = 19 | P.of_list CCList.(1 -- 100) 20 | |> P.Reader.map ~f:string_of_int;; 21 | 22 | Lwt_io.with_file ~mode:Lwt_io.output "/tmp/foo" 23 | (fun oc -> 24 | let p2 = P.IO.write_lines oc in 25 | P.connect ~ownership:`InOwnsOut p1 p2; 26 | P.wait p2 27 | );; 28 | ]} 29 | 30 | {b status: experimental} 31 | *) 32 | 33 | exception Closed 34 | 35 | type ('a, +'perm) t constraint 'perm = [< `r | `w] 36 | (** A pipe between producers of values of type 'a, and consumers of values 37 | of type 'a. *) 38 | 39 | type ('a, 'perm) pipe = ('a, 'perm) t 40 | 41 | type 'a read_timeout_result = 42 | | Pipe_closed 43 | | Nothing_available 44 | | Timeout 45 | | Data_available of 'a 46 | (** Return type for the [read_with_timeout] function *) 47 | 48 | val keep : (_,_) t -> unit Lwt.t -> unit 49 | (** [keep p fut] adds a pointer from [p] to [fut] so that [fut] is not 50 | garbage-collected before [p] *) 51 | 52 | val is_closed : (_,_) t -> bool 53 | 54 | val close : (_,_) t -> unit Lwt.t 55 | (** [close p] closes [p], which will not accept input anymore. 56 | This sends [End] to all readers connected to [p] *) 57 | 58 | val close_nonblock : _ t -> unit 59 | (** Same as {!close} but does not wait for completion of dependent tasks *) 60 | 61 | val wait : (_,_) t -> unit Lwt.t 62 | (** Evaluates once the pipe closes *) 63 | 64 | val create : ?on_close:(unit -> unit) -> ?max_size:int -> unit -> ('a, 'perm) t 65 | (** Create a new pipe. 66 | @param on_close called when the pipe is closed 67 | @param max_size size of internal buffer. Default 0. *) 68 | 69 | val connect : ?ownership:[`None | `InOwnsOut | `OutOwnsIn] -> 70 | ('a, [>`r]) t -> ('a, [>`w]) t -> unit 71 | (** [connect p1 p2] forwards every item output by [p1] into [p2]'s input 72 | until [p1] is closed. 73 | @param own determines which pipes owns which (the owner, when it 74 | closes, also closes the ownee) *) 75 | 76 | val link_close : (_,_) t -> after:(_,_) t -> unit 77 | (** [link_close p ~after] will close [p] when [after] closes. 78 | if [after] is closed already, closes [p] immediately *) 79 | 80 | val read : ('a, [>`r]) t -> 'a option Lwt.t 81 | (** Read the next value from a Pipe *) 82 | 83 | val read_with_timeout : 84 | ('a, [>`r]) t -> 85 | timeout:float option -> 'a read_timeout_result Lwt.t 86 | (** [read_with_timeout p ~timeout] read the next value from a Pipe, 87 | optionally waiting for at most a number of seconds passed with the 88 | [timeout] parameter. *) 89 | 90 | val write : ('a, [>`w]) t -> 'a -> bool Lwt.t 91 | (** Returns [false] if the pipe is closed *) 92 | 93 | val write_exn : ('a, [>`w]) t -> 'a -> unit Lwt.t 94 | (** @raise Closed if the writer is closed *) 95 | 96 | val write_list : ('a, [>`w]) t -> 'a list -> bool Lwt.t 97 | (** Returns [false] if the pipe is closed *) 98 | 99 | val write_list_exn : ('a, [>`w]) t -> 'a list -> unit Lwt.t 100 | (** @raise Closed if the writer is closed *) 101 | 102 | val to_stream : ('a, [>`r]) t -> 'a Lwt_stream.t 103 | (** [to_stream p] returns a stream with the content from [p]. The 104 | stream will close when [p] closes. *) 105 | 106 | val of_stream : 'a Lwt_stream.t -> ('a, [>`r]) t 107 | (** [of_stream s] reads from [s]. The returned pipe will close when 108 | [s] closes. *) 109 | 110 | (** {2 Write-only Interface and Combinators} *) 111 | 112 | module Writer : sig 113 | type 'a t = ('a, [`w]) pipe 114 | 115 | val map : f:('a -> 'b) -> ('b, [>`w]) pipe -> 'a t 116 | (** Map values before writing them *) 117 | 118 | val send_both : ('a, [>`w] as 'kind) pipe -> ('a, [>`w] as 'kind) pipe -> 'a t 119 | (** [send_both a b] returns a writer [c] such that writing to [c] 120 | writes to [a] and [b], and waits for those writes to succeed 121 | before returning *) 122 | 123 | val send_all : ('a, [>`w]) pipe list -> 'a t 124 | (** Generalized version of {!send_both} 125 | @raise Invalid_argument if the list is empty *) 126 | end 127 | 128 | (** {2 Read-only Interface and Combinators} *) 129 | 130 | module Reader : sig 131 | type 'a t = ('a, [`r]) pipe 132 | 133 | val map : f:('a -> 'b) -> ('a, [>`r]) pipe -> 'b t 134 | 135 | val map_s : f:('a -> 'b Lwt.t) -> ('a, [>`r]) pipe -> 'b t 136 | 137 | val filter : f:('a -> bool) -> ('a, [>`r]) pipe -> 'a t 138 | 139 | val filter_map : f:('a -> 'b option) -> ('a, [>`r]) pipe -> 'b t 140 | 141 | val filter_map_s : f:('a -> 'b option Lwt.t) -> ('a, [>`r]) pipe -> 'b t 142 | 143 | val flat_map : f:('a -> 'b list) -> ('a, [>`r]) pipe -> 'b t 144 | 145 | val flat_map_s : f:('a -> 'b list Lwt.t) -> ('a, [>`r]) pipe -> 'b t 146 | 147 | val fold : f:('acc -> 'a -> 'acc) -> x:'acc -> ('a, [>`r]) pipe -> 'acc Lwt.t 148 | 149 | val fold_s : f:('acc -> 'a -> 'acc Lwt.t) -> x:'acc -> ('a, [>`r]) pipe -> 'acc Lwt.t 150 | 151 | val iter : f:('a -> unit) -> ('a, [>`r]) pipe -> unit Lwt.t 152 | 153 | val iter_s : f:('a -> unit Lwt.t) -> ('a, [>`r]) pipe -> unit Lwt.t 154 | 155 | val iter_p : f:('a -> unit Lwt.t) -> ('a, [>`r]) pipe -> unit Lwt.t 156 | 157 | val merge_both : ('a, [>`r] as 'kind) pipe -> ('a, [>`r] as 'kind) pipe -> 'a t 158 | (** Merge the two input streams in a non-specified order *) 159 | 160 | val merge_all : ('a, [>`r]) pipe list -> 'a t 161 | (** Merge all the input streams 162 | @raise Invalid_argument if the list is empty *) 163 | 164 | val append : ('a, [>`r]) pipe -> ('a, [>`r]) pipe -> 'a t 165 | (** [append a b] reads from [a] until [a] closes, then reads from [b] 166 | and closes when [b] closes *) 167 | end 168 | 169 | (** {2 Conversions} *) 170 | 171 | type 'a lwt_klist = [ `Nil | `Cons of 'a * 'a lwt_klist ] Lwt.t 172 | 173 | val of_list : 'a list -> 'a Reader.t 174 | 175 | val of_array : 'a array -> 'a Reader.t 176 | 177 | val of_string : string -> char Reader.t 178 | 179 | val of_lwt_klist : 'a lwt_klist -> 'a Reader.t 180 | 181 | val to_list_rev : ('a,[>`r]) t -> 'a list Lwt.t 182 | 183 | val to_list : ('a,[>`r]) t -> 'a list Lwt.t 184 | 185 | val to_buffer : Buffer.t -> (char ,[>`r]) t -> unit Lwt.t 186 | 187 | val to_buffer_str : ?sep:string -> Buffer.t -> (string, [>`r]) t -> unit Lwt.t 188 | 189 | val to_string : (char, [>`r]) t -> string Lwt.t 190 | 191 | val join_strings : ?sep:string -> (string, [>`r]) t -> string Lwt.t 192 | 193 | val to_lwt_klist : 'a Reader.t -> 'a lwt_klist 194 | (** Iterates on the reader. Errors are ignored (but stop the list). *) 195 | 196 | (** {2 Basic IO wrappers} *) 197 | 198 | module IO : sig 199 | val read : ?bufsize:int -> Lwt_io.input_channel -> string Reader.t 200 | 201 | val read_lines : Lwt_io.input_channel -> string Reader.t 202 | 203 | val write : Lwt_io.output_channel -> string Writer.t 204 | 205 | val write_lines : Lwt_io.output_channel -> string Writer.t 206 | end 207 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name lwt_pipe) 4 | (public_name lwt-pipe) 5 | (wrapped false) 6 | (libraries lwt lwt.unix) 7 | (flags :standard -w +a-4 -warn-error -a+8 -safe-string)) 8 | --------------------------------------------------------------------------------