diff --git a/_tags b/_tags index d5306af3a2..4b731511a3 100644 --- a/_tags +++ b/_tags @@ -1,6 +1,12 @@ # -*- conf -*- not : safe_string +# Warnings. The order is important. This is not fully legitimate as it appears +# to depend on how Ocamlbuild internally handles lists of warn() tags. + or : warn(-4) +: warn(-3) +<**/*>: warn(+A-29-58) + # Syntax extension : syntax(camlp4o) diff --git a/doc/examples/unix/parallelize.ml b/doc/examples/unix/parallelize.ml index 4a6cd5f97e..8f0dec9125 100644 --- a/doc/examples/unix/parallelize.ml +++ b/doc/examples/unix/parallelize.ml @@ -32,7 +32,7 @@ let rec launch () = | None -> Lwt.return_unit | Some line -> - let%lwt exit_status = Lwt_process.exec (Lwt_process.shell line) in + let%lwt _ = Lwt_process.exec (Lwt_process.shell line) in launch () (* Creates the initial threads, where is the number of diff --git a/doc/examples/unix/relay.ml b/doc/examples/unix/relay.ml index 47917ca79c..d7f6ac111b 100644 --- a/doc/examples/unix/relay.ml +++ b/doc/examples/unix/relay.ml @@ -22,8 +22,6 @@ (* Relay data from an address to another. *) -open Lwt.Infix - (* +-----------------------------------------------------------------+ | Relaying | +-----------------------------------------------------------------+ *) diff --git a/src/camlp4/pa_lwt.ml b/src/camlp4/pa_lwt.ml index c3410280b2..2fbe0dc669 100644 --- a/src/camlp4/pa_lwt.ml +++ b/src/camlp4/pa_lwt.ml @@ -20,9 +20,8 @@ * 02111-1307, USA. *) -open Camlp4 open Camlp4.PreCast -open Syntax +open! Syntax (* Generate the catching function from a macth-case. @@ -54,9 +53,9 @@ let gen_binding l = let rec aux n = function | [] -> assert false - | [(_loc, p, e)] -> + | [(_loc, _p, e)] -> <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ >> - | (_loc, p, e) :: l -> + | (_loc, _p, e) :: l -> <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ and $aux (n + 1) l$ >> in aux 0 l @@ -65,7 +64,7 @@ let gen_bind l e = let rec aux n = function | [] -> e - | (_loc, p, e) :: l -> + | (_loc, p, _e) :: l -> if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> else @@ -77,7 +76,7 @@ let gen_top_bind _loc l = let rec aux n vars = function | [] -> <:expr< Lwt.return ($tup:Ast.exCom_of_list (List.rev vars)$) >> - | (_loc, p, e) :: l -> + | (_loc, _p, _e) :: l -> let id = "__pa_lwt_" ^ string_of_int n in if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> @@ -209,7 +208,7 @@ EXTEND Gram >> | _ -> <:str_item< - let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, e) -> p) l)$ = + let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, _e) -> p) l)$ = Lwt_main.run begin let $gen_binding l$ in $gen_top_bind _loc l$ @@ -225,7 +224,7 @@ END y] if the strict sequence flag is used. *) let map_anonymous_bind = object inherit Ast.map as super - method expr e = match super#expr e with + method! expr e = match super#expr e with | <:expr@_loc< $lid:f$ $a$ $b$ >> when f = ">>" -> if !Pa_lwt_options.strict_sequence then <:expr< Lwt.bind $a$ (fun () -> $b$) >> diff --git a/src/camlp4/pa_lwt_log.ml b/src/camlp4/pa_lwt_log.ml index 3105752cd6..f963d5f32e 100644 --- a/src/camlp4/pa_lwt_log.ml +++ b/src/camlp4/pa_lwt_log.ml @@ -31,16 +31,6 @@ let levels = [ "Debug"; ] -let module_name _loc = - let file_name = Loc.file_name _loc in - if file_name = "" then - "" - else - String.capitalize (Filename.basename (try - Filename.chop_extension file_name - with Invalid_argument _ -> - file_name)) - let rec apply e = function | [] -> e | x :: l -> let _loc = Ast.loc_of_expr x in apply <:expr< $e$ $x$ >> l @@ -69,7 +59,7 @@ let split e = `Log(ign, func, section, level, acc) else `Not_a_log - | <:expr@loc< $a$ $b$ >> -> begin + | <:expr@_loc< $a$ $b$ >> -> begin match b with | <:expr< ~section >> -> aux `Label (b :: acc) a @@ -94,7 +84,7 @@ let map = object inherit Ast.map as super - method expr e = + method! expr e = let _loc = Ast.loc_of_expr e in match split e with | `Delete false -> diff --git a/src/core/lwt.ml b/src/core/lwt.ml index d82d632b0b..8e55f35e16 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -173,7 +173,8 @@ let get key = let rec repr_rec t = match t.state with | Repr t' -> let t'' = repr_rec t' in if t'' != t' then t.state <- Repr t''; t'' - | _ -> t + | Return _ | Fail _ | Sleep _ -> t + let repr t = repr_rec (thread_repr t) let async_exception_hook = @@ -245,7 +246,7 @@ let unsafe_run_waiters sleeper state = (match state with | Fail Canceled -> run_cancel_handlers_rec sleeper.cancel_handlers [] - | _ -> + | Return _ | Fail _ | Sleep _ | Repr _ -> ()); (* Restart waiters. *) run_waiters_rec state sleeper.waiters [] @@ -329,7 +330,7 @@ let wakeup_result t result = | Fail Canceled -> (* Do not fail if the thread has been canceled: *) () - | _ -> + | Return _ | Fail _ | Repr _ -> invalid_arg "Lwt.wakeup_result" let wakeup t v = wakeup_result t (make_value v) @@ -354,7 +355,7 @@ let wakeup_later_result (type x) t result = safe_run_waiters sleeper state | Fail Canceled -> () - | _ -> + | Return _ | Fail _ | Repr _ -> invalid_arg "Lwt.wakeup_later_result" let wakeup_later t v = wakeup_later_result t (make_value v) @@ -371,14 +372,14 @@ let pack_sleeper (type x) sleeper = let module M = struct type a = x let sleeper = sleeper end in (module M : A_sleeper) -let cancel (type x) t = +let cancel t = let state = Fail Canceled in (* - collect all sleepers to restart - set the state of all threads to cancel to [Fail Canceled] *) let rec collect : 'a. a_sleeper list -> 'a t -> a_sleeper list = fun acc t -> let t = repr t in match t.state with - | Sleep ({ cancel } as sleeper) -> begin + | Sleep ({ cancel; _ } as sleeper) -> begin match cancel with | Cancel_no -> acc @@ -394,7 +395,7 @@ let cancel (type x) t = let module M = (val m : A_threads) in List.fold_left collect acc M.threads end - | _ -> + | Return _ | Fail _ | Repr _ -> acc in let sleepers = collect [] t in @@ -409,24 +410,26 @@ let cancel (type x) t = leave_wakeup ctx let append l1 l2 = - match l1, l2 with + (match l1, l2 with | Empty, _ -> l2 | _, Empty -> l1 - | _ -> Append (l1, l2) + | _ -> Append (l1, l2)) + [@ocaml.warning "-4"] let chs_append l1 l2 = - match l1, l2 with + (match l1, l2 with | Chs_empty, _ -> l2 | _, Chs_empty -> l1 - | _ -> Chs_append (l1, l2) + | _ -> Chs_append (l1, l2)) + [@ocaml.warning "-4"] -(* Remove all disbaled waiters of a waiter set: *) +(* Remove all disabled waiters of a waiter set: *) let rec cleanup = function | Removable { contents = None } -> Empty | Append (l1, l2) -> append (cleanup l1) (cleanup l2) - | ws -> + | Empty | Removable _ | Immutable _ as ws -> ws (* Make [t1] and [t2] behave the same way, where [t1] is a sleeping @@ -486,13 +489,13 @@ let connect t1 t2 = sleeper1.waiters <- waiters end; sleeper1.cancel_handlers <- chs_append sleeper1.cancel_handlers sleeper2.cancel_handlers - | state2 -> + | Return _ | Fail _ | Repr _ as state2 -> (* [t2] is already terminated, assing its state to [t1]: *) t1.state <- state2; (* and run all the waiters of [t1]: *) unsafe_run_waiters sleeper1 state2 end - | _ -> + | Return _ | Fail _ | Repr _ -> (* [t1] is not asleep: *) assert false @@ -504,7 +507,7 @@ let fast_connect t state = | Sleep sleeper -> t.state <- state; unsafe_run_waiters sleeper state - | _ -> + | Return _ | Fail _ | Repr _ -> assert false (* Same as [fast_connect] except that it does nothing if [t] has @@ -515,7 +518,7 @@ let fast_connect_if t state = | Sleep sleeper -> t.state <- state; unsafe_run_waiters sleeper state - | _ -> + | Return _ | Fail _ | Repr _ -> () (* +-----------------------------------------------------------------+ @@ -631,7 +634,8 @@ let wrap7 f x1 x2 x3 x4 x5 x6 x7 = try return (f x1 x2 x3 x4 x5 x6 x7) with exn let add_waiter sleeper waiter = sleeper.waiters <- (match sleeper.waiters with | Empty -> waiter - | ws -> Append (waiter, ws)) + | Immutable _ | Removable _ | Append _ as ws -> + Append (waiter, ws)) let add_immutable_waiter sleeper waiter = add_waiter sleeper (Immutable waiter) @@ -643,11 +647,12 @@ let on_cancel t f = sleeper.cancel_handlers <- ( match sleeper.cancel_handlers with | Chs_empty -> handler - | chs -> Chs_append (handler, chs) + | Chs_func _ | Chs_node _ | Chs_append _ as chs -> + Chs_append (handler, chs) ) | Fail Canceled -> call_unsafe f () - | _ -> + | Return _ | Fail _ | Repr _ -> () let bind t f = @@ -664,7 +669,7 @@ let bind t f = (function | Return v -> current_data := data; connect res (try f v with exn -> fail exn) | Fail _ as state -> fast_connect res state - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false @@ -686,7 +691,7 @@ let map f t = (function | Return v -> current_data := data; fast_connect res (try Return (f v) with exn -> Fail exn) | Fail _ as state -> fast_connect res state - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false @@ -708,7 +713,7 @@ let catch x f = (function | Return _ as state -> fast_connect res state | Fail exn -> current_data := data; connect res (try f exn with exn -> fail exn) - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false @@ -717,21 +722,21 @@ let on_success t f = match (repr t).state with | Return v -> call_unsafe f v - | Fail exn -> + | Fail _ -> () | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f v - | Fail exn -> () - | _ -> assert false) + | Fail _ -> () + | Sleep _ | Repr _ -> assert false) | Repr _ -> assert false let on_failure t f = match (repr t).state with - | Return v -> + | Return _ -> () | Fail exn -> call_unsafe f exn @@ -739,9 +744,9 @@ let on_failure t f = let data = !current_data in add_immutable_waiter sleeper (function - | Return v -> () + | Return _ -> () | Fail exn -> current_data := data; call_unsafe f exn - | _ -> assert false) + | Sleep _ | Repr _ -> assert false) | Repr _ -> assert false @@ -756,7 +761,7 @@ let on_termination t f = (function | Return _ | Fail _ -> current_data := data; call_unsafe f () - | _ -> assert false) + | Sleep _ | Repr _ -> assert false) | Repr _ -> assert false @@ -772,7 +777,7 @@ let on_any t f g = (function | Return v -> current_data := data; call_unsafe f v | Fail exn -> current_data := data; call_unsafe g exn - | _ -> assert false) + | Sleep _ | Repr _ -> assert false) | Repr _ -> assert false @@ -790,7 +795,7 @@ let try_bind x f g = (function | Return v -> current_data := data; connect res (try f v with exn -> fail exn) | Fail exn -> current_data := data; connect res (try g exn with exn -> fail exn) - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false @@ -814,7 +819,7 @@ let async f = (function | Return _ -> () | Fail exn -> !async_exception_hook exn - | _ -> assert false) + | Sleep _ | Repr _ -> assert false) | Repr _ -> assert false @@ -829,7 +834,7 @@ let ignore_result t = (function | Return _ -> () | Fail exn -> !async_exception_hook exn - | _ -> assert false) + | Sleep _ | Repr _ -> assert false) | Repr _ -> assert false @@ -852,30 +857,33 @@ let rec nth_ready l n = match (repr t).state with | Sleep _ -> nth_ready l n - | _ -> + | Return _ | Fail _ | Repr _ -> if n > 0 then nth_ready l (n - 1) else t let ready_count l = - List.fold_left (fun acc x -> match (repr x).state with Sleep _ -> acc | _ -> acc + 1) 0 l + List.fold_left (fun acc x -> + match (repr x).state with + | Sleep _ -> acc + | Return _ | Fail _ | Repr _ -> acc + 1) 0 l let remove_waiters l = List.iter (fun t -> match (repr t).state with - | Sleep ({ waiters = Removable _ } as sleeper) -> + | Sleep ({ waiters = Removable _; _ } as sleeper) -> (* There is only one waiter, it is the removed one. *) sleeper.waiters <- Empty - | Sleep sleeper -> + | Sleep ({waiters = Empty | Immutable _ | Append _; _} as sleeper) -> let removed = sleeper.removed + 1 in if removed > max_removed then begin sleeper.removed <- 0; sleeper.waiters <- cleanup sleeper.waiters end else sleeper.removed <- removed - | _ -> + | Return _ | Fail _ | Repr _ -> ()) l @@ -886,7 +894,7 @@ let add_removable_waiter threads waiter = match (repr t).state with | Sleep sleeper -> add_waiter sleeper node - | _ -> + | Return _ | Fail _ | Repr _ -> assert false) threads @@ -927,13 +935,13 @@ let rec nchoose_terminate res acc = function nchoose_terminate res (x :: acc) l | Fail _ as state -> fast_connect res state - | _ -> + | Sleep _ | Repr _ -> nchoose_terminate res acc l let nchoose_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) - and handle_result state = + and handle_result _state = waiter := None; remove_waiters l; nchoose_terminate res [] l @@ -951,7 +959,7 @@ let nchoose l = collect [x] l | Fail _ as state -> thread { state } - | _ -> + | Sleep _ | Repr _ -> init l and collect acc = function | [] -> @@ -962,7 +970,7 @@ let nchoose l = collect (x :: acc) l | Fail _ as state -> thread { state } - | _ -> + | Sleep _ | Repr _ -> collect acc l in init l @@ -976,13 +984,13 @@ let rec nchoose_split_terminate res acc_terminated acc_sleeping = function nchoose_split_terminate res (x :: acc_terminated) acc_sleeping l | Fail _ as state -> fast_connect res state - | _ -> + | Sleep _ | Repr _ -> nchoose_split_terminate res acc_terminated (t :: acc_sleeping) l let nchoose_split_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) - and handle_result state = + and handle_result _state = waiter := None; remove_waiters l; nchoose_split_terminate res [] [] l @@ -1000,7 +1008,7 @@ let nchoose_split l = collect [x] acc_sleeping l | Fail _ as state -> thread { state } - | _ -> + | Sleep _ | Repr _ -> init (t :: acc_sleeping) l and collect acc_terminated acc_sleeping = function | [] -> @@ -1011,7 +1019,7 @@ let nchoose_split l = collect (x :: acc_terminated) acc_sleeping l | Fail _ as state -> thread { state } - | _ -> + | Sleep _ | Repr _ -> collect acc_terminated (t :: acc_sleeping) l in init [] l @@ -1026,7 +1034,7 @@ let rec cancel_and_nth_ready l n = | Sleep _ -> cancel t; cancel_and_nth_ready l n - | _ -> + | Return _ | Fail _ | Repr _ -> if n > 0 then cancel_and_nth_ready l (n - 1) else begin @@ -1059,7 +1067,7 @@ let pick l = let npick_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) - and handle_result state = + and handle_result _state = waiter := None; remove_waiters l; List.iter cancel l; @@ -1079,7 +1087,7 @@ let npick threads = | Fail _ as state -> List.iter cancel threads; thread { state } - | _ -> + | Sleep _ | Repr _ -> init l and collect acc = function | [] -> @@ -1092,14 +1100,14 @@ let npick threads = | Fail _ as state -> List.iter cancel threads; thread { state } - | _ -> + | Sleep _ | Repr _ -> collect acc l in init threads let protected t = match (repr t).state with - | Sleep sleeper -> + | Sleep _ -> let res = thread (task_aux ()) in (* We use [fact_connect_if] because when [res] is canceled, it will always terminate before [t]. *) @@ -1127,7 +1135,7 @@ let join l = match !return_state, state with | Return _, Fail _ -> return_state := state | _ -> () - end; + end [@ocaml.warning "-4"]; decr sleeping; (* All threads are terminated, we can wakeup the result: *) if !sleeping = 0 then fast_connect res !return_state @@ -1150,10 +1158,10 @@ let join l = | Return _ -> return_state := state; init rest - | _ -> + | Fail _ | Sleep _ | Repr _ -> init rest end - | _ -> + | Return _ | Repr _ -> init rest in init l @@ -1166,12 +1174,6 @@ let finalize f g = (fun x -> g () >>= fun () -> return x) (fun e -> g () >>= fun () -> fail e) -let update_data key = function - | Some _ as value -> - current_data := Int_map.add key.id (fun () -> key.store <- value) !current_data - | None -> - current_data := Int_map.remove key.id !current_data - let with_value key value f = let save = !current_data in let data = @@ -1237,7 +1239,7 @@ let backtrace_bind add_loc t f = (function | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) | Fail exn -> fast_connect res (Fail(add_loc exn)) - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false @@ -1256,7 +1258,7 @@ let backtrace_catch add_loc x f = (function | Return _ as state -> fast_connect res state | Fail exn -> current_data := data; connect res (try f exn with exn -> fail (add_loc exn)) - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false @@ -1275,7 +1277,7 @@ let backtrace_try_bind add_loc x f g = (function | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) | Fail exn -> current_data := data; connect res (try g exn with exn -> fail (add_loc exn)) - | _ -> assert false); + | Sleep _ | Repr _ -> assert false); res | Repr _ -> assert false diff --git a/src/core/lwt_condition.ml b/src/core/lwt_condition.ml index 56f87b6e8f..71d11467e6 100644 --- a/src/core/lwt_condition.ml +++ b/src/core/lwt_condition.ml @@ -29,8 +29,6 @@ * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) -open Lwt.Infix - type 'a t = 'a Lwt.u Lwt_sequence.t let create = Lwt_sequence.create diff --git a/src/core/lwt_mutex.ml b/src/core/lwt_mutex.ml index 29e3605de1..e2a21e133f 100644 --- a/src/core/lwt_mutex.ml +++ b/src/core/lwt_mutex.ml @@ -27,7 +27,7 @@ type t = { mutable locked : bool; mutable waiters : unit Lwt.u Lwt_sequence.t } let create () = { locked = false; waiters = Lwt_sequence.create () } -let rec lock m = +let lock m = if m.locked then Lwt.add_task_r m.waiters else begin diff --git a/src/core/lwt_mvar.ml b/src/core/lwt_mvar.ml index 5e19c895a2..185c293a4e 100644 --- a/src/core/lwt_mvar.ml +++ b/src/core/lwt_mvar.ml @@ -30,7 +30,7 @@ ******************************************************************************) type 'a t = { - mutable contents : 'a option; + mutable mvar_contents : 'a option; (* Current contents *) writers : ('a * unit Lwt.u) Lwt_sequence.t; @@ -41,21 +41,21 @@ type 'a t = { } let create_empty () = - { contents = None; + { mvar_contents = None; writers = Lwt_sequence.create (); readers = Lwt_sequence.create () } let create v = - { contents = Some v; + { mvar_contents = Some v; writers = Lwt_sequence.create (); readers = Lwt_sequence.create () } let put mvar v = - match mvar.contents with + match mvar.mvar_contents with | None -> begin match Lwt_sequence.take_opt_l mvar.readers with | None -> - mvar.contents <- Some v + mvar.mvar_contents <- Some v | Some w -> Lwt.wakeup_later w v end; @@ -67,14 +67,14 @@ let put mvar v = res let take mvar = - match mvar.contents with + match mvar.mvar_contents with | Some v -> begin match Lwt_sequence.take_opt_l mvar.writers with | Some(v', w) -> - mvar.contents <- Some v'; + mvar.mvar_contents <- Some v'; Lwt.wakeup_later w () | None -> - mvar.contents <- None + mvar.mvar_contents <- None end; Lwt.return v | None -> diff --git a/src/core/lwt_pqueue.ml b/src/core/lwt_pqueue.ml index c6a5cc7659..e1fc6cc054 100644 --- a/src/core/lwt_pqueue.ml +++ b/src/core/lwt_pqueue.ml @@ -99,10 +99,10 @@ module Make(Ord: OrderedType) : (S with type elt = Ord.t) = function [] -> raise Not_found | ts -> - let (Node (x, r, c), ts) = get_min ts in + let (Node (_, _, c), ts) = get_min ts in union (List.rev c) ts let rec size l = - let rec sizetree (Node (_,_,tl)) = 1 + size tl in + let sizetree (Node (_,_,tl)) = 1 + size tl in List.fold_left (fun s t -> s + sizetree t) 0 l end diff --git a/src/core/lwt_stream.ml b/src/core/lwt_stream.ml index cbef35c88d..e5f6e05473 100644 --- a/src/core/lwt_stream.ml +++ b/src/core/lwt_stream.ml @@ -126,7 +126,7 @@ end let clone s = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.clone" - | _ -> ()); + | From _ | From_direct _ | Push _ -> ()); { source = s.source; close = s.close; @@ -415,7 +415,7 @@ let consume s node = info.pushb_count <- info.pushb_count - 1 else notify_pusher info s.last - | _ -> + | From _ | From_direct _ | Push _ -> () end @@ -456,7 +456,9 @@ let rec get_exn_rec s node = Lwt.try_bind (fun () -> feed s) (fun () -> get_exn_rec s node) - (fun exn -> Lwt.return (Some (Error exn))) + (fun exn -> Lwt.return (Some (Error exn : _ result))) + (* TODO: Eliminate the above type constraint once the Lwt_stream.result + type is eliminated. *) else match node.data with | Some value -> @@ -555,7 +557,7 @@ let last_new s = match Lwt.state thread with | Lwt.Return x -> last_new_rec node x s - | _ -> + | Lwt.Fail _ | Lwt.Sleep -> thread else match node.data with @@ -975,7 +977,7 @@ let rec find_map_s_rec node f s = let find_map_s f s = find_map_s_rec s.node f s -let rec combine s1 s2 = +let combine s1 s2 = let next () = let t1 = get s1 and t2 = get s2 in t1 >>= fun n1 -> @@ -1045,7 +1047,7 @@ let choose streams = let parse s f = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.parse" - | _ -> ()); + | From _ | From_direct _ | Push _ -> ()); let node = s.node in Lwt.catch (fun () -> f s) diff --git a/src/core/lwt_switch.ml b/src/core/lwt_switch.ml index 1778fe7ef5..564269e773 100644 --- a/src/core/lwt_switch.ml +++ b/src/core/lwt_switch.ml @@ -41,7 +41,7 @@ let is_on switch = let check = function | Some{ state = St_off } -> raise Off - | _ -> () + | Some {state = St_on _} | None -> () let add_hook switch hook = match switch with diff --git a/src/glib/lwt_glib.ml b/src/glib/lwt_glib.ml index ffbb584ffb..1e78bb4f84 100644 --- a/src/glib/lwt_glib.ml +++ b/src/glib/lwt_glib.ml @@ -45,11 +45,13 @@ end | Glib --> Lwt based integration | +-----------------------------------------------------------------+ *) +[@@@ocaml.warning "-37"] type watch = | Watch_none | Watch_in | Watch_out | Watch_in_out +[@@@ocaml.warning "+37"] external glib_get_sources : unit -> Unix.file_descr array * watch array * float = "lwt_glib_get_sources" external glib_check : unit -> unit = "lwt_glib_check" diff --git a/src/logger/lwt_log_core.ml b/src/logger/lwt_log_core.ml index 9d625cdeda..7b94f89655 100644 --- a/src/logger/lwt_log_core.ml +++ b/src/logger/lwt_log_core.ml @@ -23,8 +23,6 @@ (* This code is an adaptation of [syslog-ocaml] *) -open Lwt.Infix - (* Errors happening in this module are always logged to [stderr]: *) let log_intern fmt = Printf.eprintf ("Lwt_log: " ^^ fmt ^^ "\n%!") @@ -53,7 +51,6 @@ let string_of_level = function | Patterns and rules | +-----------------------------------------------------------------+ *) -type pattern = string list (* A pattern is represented by a list of literals: For example ["foo*bar*"] is represented by ["foo"; "bar"; ""]. *) @@ -281,7 +278,7 @@ let render ~buffer ~template ~section ~level ~message = let null = make - ~output:(fun section level lines -> Lwt.return_unit) + ~output:(fun _section _level _lines -> Lwt.return_unit) ~close:Lwt.return let default = ref null diff --git a/src/ppx/ppx_lwt_ex.ml b/src/ppx/ppx_lwt_ex.ml index 8482f9052b..fc8132828d 100644 --- a/src/ppx/ppx_lwt_ex.ml +++ b/src/ppx/ppx_lwt_ex.ml @@ -7,8 +7,8 @@ open Ast_convenience (** {2 Convenient stuff} *) -let with_loc f { txt ; loc } = - (f txt) [@metaloc loc] +let with_loc f {txt ; loc = _loc} = + (f txt) [@metaloc _loc] let def_loc txt = { txt; loc = !default_loc } @@ -54,7 +54,7 @@ let gen_name i = lwt_prefix ^ string_of_int i let gen_bindings l = let aux i binding = { binding with - pvb_pat = (pvar @@ gen_name i) [@metaloc binding.pvb_expr.pexp_loc] + pvb_pat = (pvar (gen_name i)) [@metaloc binding.pvb_expr.pexp_loc] } in List.mapi aux l @@ -66,7 +66,7 @@ let gen_binds e_loc l e = | [] -> e | binding :: t -> let name = (* __ppx_lwt_$i, at the position of $x$ *) - (evar @@ gen_name i) [@metaloc binding.pvb_expr.pexp_loc] + (evar (gen_name i)) [@metaloc binding.pvb_expr.pexp_loc] in let fun_ = [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])] [@metaloc binding.pvb_loc] @@ -91,10 +91,10 @@ let gen_binds e_loc l e = let gen_top_binds vbs = let gen_exp vbs i = match vbs with - | { pvb_expr } :: rest -> + | {pvb_expr; _}::_rest -> if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) - [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp rest (i + 1))] + [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp _rest (i + 1))] else [%expr Lwt.bind [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp rest (i + 1))] | [] -> @@ -102,7 +102,7 @@ let gen_top_binds vbs = if i >= 0 then evar (gen_name i) :: names (i - 1) else [] in Exp.tuple (names i) in - [Vb.mk (Pat.tuple (vbs |> List.map (fun { pvb_pat } -> pvb_pat))) + [Vb.mk (Pat.tuple (vbs |> List.map (fun { pvb_pat; _ } -> pvb_pat))) [%expr Lwt_main.run [%e gen_exp vbs 0]]] (** For expressions only *) @@ -113,7 +113,7 @@ let lwt_expression mapper exp attributes = let pexp_attributes = attributes @ exp.pexp_attributes in match exp.pexp_desc with - (** [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) + (* [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) | Pexp_let (Nonrecursive, vbl , e) -> let new_exp = Exp.let_ @@ -122,20 +122,20 @@ let lwt_expression mapper exp attributes = (gen_binds exp.pexp_loc vbl e) in mapper.expr mapper { new_exp with pexp_attributes } - (** [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)] - [match%lwt $e$ with exception $x$ | $c$] ≡ - [Lwt.try_bind (fun () -> $e$) (function $c$) (function $x$)] *) + (* [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)] + [match%lwt $e$ with exception $x$ | $c$] ≡ + [Lwt.try_bind (fun () -> $e$) (function $c$) (function $x$)] *) | Pexp_match (e, cases) -> let exns, cases = cases |> List.partition ( function - | { pc_lhs = [%pat? exception [%p? _]]} -> true + | {pc_lhs = [%pat? exception [%p? _]]; _} -> true | _ -> false) in let exns = exns |> List.map ( function - | { pc_lhs = [%pat? exception [%p? pat]]} as case -> + | {pc_lhs = [%pat? exception [%p? pat]]; _} as case -> { case with pc_lhs = pat } | _ -> assert false) in @@ -148,18 +148,18 @@ let lwt_expression mapper exp attributes = in mapper.expr mapper { new_exp with pexp_attributes } - (** [assert%lwt $e$] ≡ - [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *) + (* [assert%lwt $e$] ≡ + [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *) | Pexp_assert e -> let new_exp = [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] in mapper.expr mapper { new_exp with pexp_attributes } - (** [while%lwt $cond$ do $body$ done] ≡ - [let rec __ppx_lwt_loop () = - if $cond$ then Lwt.bind $body$ __ppx_lwt_loop - else Lwt.return_unit - in __ppx_lwt_loop] + (* [while%lwt $cond$ do $body$ done] ≡ + [let rec __ppx_lwt_loop () = + if $cond$ then Lwt.bind $body$ __ppx_lwt_loop + else Lwt.return_unit + in __ppx_lwt_loop] *) | Pexp_while (cond, body) -> let new_exp = @@ -171,19 +171,19 @@ let lwt_expression mapper exp attributes = ] in mapper.expr mapper { new_exp with pexp_attributes } - (** [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡ - [let __ppx_lwt_bound = $end$ in - let rec __ppx_lwt_loop $p$ = - if $p$ COMP __ppx_lwt_bound then Lwt.return_unit - else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) - in __ppx_lwt_loop $start$] + (* [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡ + [let __ppx_lwt_bound = $end$ in + let rec __ppx_lwt_loop $p$ = + if $p$ COMP __ppx_lwt_bound then Lwt.return_unit + else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) + in __ppx_lwt_loop $start$] *) - | Pexp_for (({ ppat_desc = Ppat_var p_var} as p), start, bound, dir, body) -> + | Pexp_for ({ppat_desc = Ppat_var p_var; _} as p, start, bound, dir, body) -> let comp, op = match dir with | Upto -> evar ">", evar "+" | Downto -> evar "<", evar "-" in - let p' = with_loc evar p_var in + let p' = with_loc (fun s -> evar s) p_var in let exp_bound = [%expr __ppx_lwt_bound] [@metaloc bound.pexp_loc] in let pat_bound = [%pat? __ppx_lwt_bound] [@metaloc bound.pexp_loc] in @@ -199,8 +199,8 @@ let lwt_expression mapper exp attributes = in mapper.expr mapper { new_exp with pexp_attributes } - (** [try%lwt $e$ with $c$] ≡ - [Lwt.catch (fun () -> $e$) (function $c$)] + (* [try%lwt $e$ with $c$] ≡ + [Lwt.catch (fun () -> $e$) (function $c$)] *) | Pexp_try (expr, cases) -> let cases = add_wildcard_case cases in @@ -213,10 +213,10 @@ let lwt_expression mapper exp attributes = in mapper.expr mapper { new_exp with pexp_attributes } - (** [if%lwt $c$ then $e1$ else $e2$] ≡ - [match%lwt $c$ with true -> $e1$ | false -> $e2$] - [if%lwt $c$ then $e1$] ≡ - [match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit] + (* [if%lwt $c$ then $e1$ else $e2$] ≡ + [match%lwt $c$ with true -> $e1$ | false -> $e2$] + [if%lwt $c$ then $e1$] ≡ + [match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit] *) | Pexp_ifthenelse (cond, e1, e2) -> let e2 = match e2 with None -> [%expr Lwt.return_unit] | Some e -> e in @@ -229,7 +229,7 @@ let lwt_expression mapper exp attributes = let new_exp = [%expr Lwt.bind [%e cond] [%e Exp.function_ cases]] in mapper.expr mapper { new_exp with pexp_attributes } - (** [[%lwt $e$]] ≡ [Lwt.catch (fun () -> $e$) Lwt.fail] *) + (* [[%lwt $e$]] ≡ [Lwt.catch (fun () -> $e$) Lwt.fail] *) | _ -> let exp = match exp with @@ -247,7 +247,7 @@ let lwt_expression mapper exp attributes = in mapper.expr mapper { new_exp with pexp_attributes } -let make_loc { Location.loc_start } = +let make_loc {Location.loc_start; _} = let (file, line, char) = Location.get_pos_info loc_start in [%expr ([%e str file], [%e int line], [%e int char])] @@ -263,7 +263,7 @@ let make_loc { Location.loc_start } = let lwt_log mapper fn args attrs loc = let open Longident in match fn with - | { pexp_desc = Pexp_ident { txt = Ldot (Lident "Lwt_log", func) } } -> + | {pexp_desc = Pexp_ident {txt = Ldot (Lident "Lwt_log", func); _}; _} -> let len = String.length func in let fmt = len >= 2 && func.[len - 2] = '_' && func.[len - 1] = 'f' and ign = len >= 4 && func.[0] = 'i' && func.[1] = 'g' && func.[2] = 'n' && func.[3] = '_' in @@ -315,8 +315,8 @@ let lwt_mapper args = lwt_expression mapper exp expr.pexp_attributes - (** [($e$)[%finally $f$]] ≡ - [Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *) + (* [($e$)[%finally $f$]] ≡ + [Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *) | [%expr [%e? exp ] [%finally [%e? finally]] ] | [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] -> let new_exp = @@ -360,12 +360,12 @@ let lwt_mapper args = match stri with | [%stri let%lwt [%p? var] = [%e? exp]] -> [%stri let [%p var] = Lwt_main.run [%e mapper.expr mapper exp]] - | { pstr_desc = Pstr_extension (({ txt = "lwt" }, PStr [ - { pstr_desc = Pstr_value (Recursive, vbs) }]) as content, attrs); pstr_loc } -> - { stri with pstr_desc = - Pstr_extension (content, warn_let_lwt_rec pstr_loc attrs) } - | { pstr_desc = Pstr_extension (({ txt = "lwt" }, PStr [ - { pstr_desc = Pstr_value (Nonrecursive, vbs) }]), _) } -> + | {pstr_desc = Pstr_extension (({txt = "lwt"; _}, PStr [ + {pstr_desc = Pstr_value (Recursive, _); _}]) as content, attrs); pstr_loc} -> + {stri with pstr_desc = + Pstr_extension (content, warn_let_lwt_rec pstr_loc attrs)} + | {pstr_desc = Pstr_extension (({txt = "lwt"; _}, PStr [ + {pstr_desc = Pstr_value (Nonrecursive, vbs); _}]), _); _} -> mapper.structure_item mapper (Str.value Nonrecursive (gen_top_binds vbs)) | x -> default_mapper.structure_item mapper x); } diff --git a/src/preemptive/lwt_preemptive.ml b/src/preemptive/lwt_preemptive.ml index f66871dfd4..79192f0475 100644 --- a/src/preemptive/lwt_preemptive.ml +++ b/src/preemptive/lwt_preemptive.ml @@ -143,7 +143,7 @@ let add_worker worker = Lwt.wakeup w worker (* Wait for worker to be available, then return it: *) -let rec get_worker () = +let get_worker () = if not (Queue.is_empty workers) then Lwt.return (Queue.take workers) else if !threads_count < !max_threads then @@ -163,7 +163,7 @@ let set_bounds (min, max) = min_threads := min; max_threads := max; (* Launch new workers: *) - for i = 1 to diff do + for _i = 1 to diff do add_worker (make_worker ()) done @@ -259,7 +259,9 @@ let run_in_main f = (* Execute [f] and wait for its result. *) Lwt.try_bind f (fun ret -> Lwt.return (Value ret)) - (fun exn -> Lwt.return (Error exn)) >>= fun result -> + (fun exn -> Lwt.return (Error exn : _ result)) >>= fun result -> + (* TODO: Eliminate above type constraint after getting rid of result + type. *) (* Send the result. *) CELL.set cell result; Lwt.return_unit diff --git a/src/react/lwt_react.ml b/src/react/lwt_react.ml index 8f99cea18e..b9f32a74e9 100644 --- a/src/react/lwt_react.ml +++ b/src/react/lwt_react.ml @@ -90,7 +90,8 @@ module E = struct let of_stream stream = let event, push = create () in - let t = Lwt.pause () >>= fun () -> Lwt_stream.iter push stream in + let t = + Lwt.pause () >>= fun () -> Lwt_stream.iter (fun v -> push v) stream in with_finaliser (cancel_thread t) event let delay thread = @@ -113,35 +114,63 @@ module E = struct let run_p e = let event, push = create () in - let iter = fmap (fun t -> Lwt.on_success t push; None) e in + let iter = fmap (fun t -> Lwt.on_success t (fun v -> push v); None) e in select [iter; event] let run_s e = let event, push = create () in let mutex = Lwt_mutex.create () in - let iter = fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) e in + let iter = + fmap + (fun t -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> t)) + (fun v -> push v); + None) e + in select [iter; event] let map_p f e = let event, push = create () in - let iter = fmap (fun x -> Lwt.on_success (f x) push; None) e in + let iter = fmap (fun x -> Lwt.on_success (f x) (fun v -> push v); None) e in select [iter; event] let map_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in - let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) e in + let iter = + fmap + (fun x -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) e + in select [iter; event] let app_p ef e = let event, push = create () in - let iter = fmap (fun (f, x) -> Lwt.on_success (f x) push; None) (app (map (fun f x -> (f, x)) ef) e) in + let iter = + fmap + (fun (f, x) -> + Lwt.on_success (f x) (fun v -> push v); + None) + (app (map (fun f x -> (f, x)) ef) e) + in select [iter; event] let app_s ef e = let event, push = create () in let mutex = Lwt_mutex.create () in - let iter = fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (app (map (fun f x -> (f, x)) ef) e) in + let iter = + fmap + (fun (f, x) -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) + (app (map (fun f x -> (f, x)) ef) e) + in select [iter; event] let filter_p f e = @@ -179,7 +208,9 @@ module E = struct None | Some y -> previous := Some x; - Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x y)) + (fun v -> push v); None) e in @@ -209,7 +240,15 @@ module E = struct let merge_s f acc el = let event, push = create () in let mutex = Lwt_mutex.create () in - let iter = fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (merge (fun acc x -> x :: acc) [] el) in + let iter = + fmap + (fun l -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) + (fun v -> push v); + None) + (merge (fun acc x -> x :: acc) [] el) + in select [iter; event] end @@ -277,21 +316,44 @@ module S = struct let run_s ?eq s = let event, push = E.create () in let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in + let iter = + E.fmap + (fun t -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> t)) + (fun v -> push v); + None) + (changes s) + in Lwt_mutex.with_lock mutex (fun () -> value s) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let map_s ?eq f s = let event, push = E.create () in let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in + let iter = + E.fmap + (fun x -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); + None) + (changes s) + in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let app_s ?eq sf s = let event, push = E.create () in let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in + let iter = + E.fmap + (fun (f, x) -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) + (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) + in Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) @@ -325,7 +387,9 @@ module S = struct (fun x -> let y = !previous in previous := x; - Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x y)) + (fun v -> push v); None) (changes s) in @@ -351,7 +415,15 @@ module S = struct let s = merge (fun acc x -> x :: acc) [] sl in let event, push = E.create () in let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in + let iter = + E.fmap + (fun l -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) + (fun v -> push v); + None) + (changes s) + in Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) @@ -383,7 +455,15 @@ module S = struct let bind_s ?eq s f = let event, push = E.create () in let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in + let iter = + E.fmap + (fun x -> + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) + (changes s) + in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (switch ?eq (hold ~eq:( == ) x (E.select [iter; event]))) end diff --git a/src/ssl/lwt_ssl.ml b/src/ssl/lwt_ssl.ml index a574f8eb02..c0f5f1f877 100644 --- a/src/ssl/lwt_ssl.ml +++ b/src/ssl/lwt_ssl.ml @@ -31,17 +31,17 @@ type socket = Lwt_unix.file_descr * t type uninitialized_socket = Lwt_unix.file_descr * Ssl.socket -let ssl_socket (fd, kind) = +let ssl_socket (_fd, kind) = match kind with | Plain -> None | SSL socket -> Some socket -let ssl_socket_of_uninitialized_socket (fd, socket) = socket +let ssl_socket_of_uninitialized_socket (_fd, socket) = socket let is_ssl s = match snd s with Plain -> false - | _ -> true + | SSL _ -> true let wrap_call f () = try @@ -49,13 +49,13 @@ let wrap_call f () = with (Ssl.Connection_error err | Ssl.Accept_error err | Ssl.Read_error err | Ssl.Write_error err) as e -> - match err with + (match err with Ssl.Error_want_read -> raise Lwt_unix.Retry_read | Ssl.Error_want_write -> raise Lwt_unix.Retry_write | _ -> - raise e + raise e) [@ocaml.warning "-4"] let repeat_call fd f = try @@ -191,7 +191,7 @@ let in_channel_of_descr ?buffer s = ~close:(fun () -> shutdown_and_close s) (fun buf pos len -> read_bytes s buf pos len) -let get_fd (fd,socket) = fd +let get_fd (fd, _socket) = fd let get_unix_fd (fd,socket) = match socket with diff --git a/src/unix/lwt_bytes.ml b/src/unix/lwt_bytes.ml index 041ca4f2f2..551e0ab4c7 100644 --- a/src/unix/lwt_bytes.ml +++ b/src/unix/lwt_bytes.ml @@ -169,15 +169,15 @@ type io_vector = { iov_length : int; } -let io_vector ~buffer ~offset ~length = { +let io_vector ~buffer ~offset ~length = ({ iov_buffer = buffer; iov_offset = offset; iov_length = length; -} +} : io_vector) let check_io_vectors func_name iovs = List.iter - (fun iov -> + (fun (iov : io_vector) -> if iov.iov_offset < 0 || iov.iov_length < 0 || iov.iov_offset > length iov.iov_buffer - iov.iov_length then diff --git a/src/unix/lwt_engine.ml b/src/unix/lwt_engine.ml index dfb6786599..0631b1542b 100644 --- a/src/unix/lwt_engine.ml +++ b/src/unix/lwt_engine.ml @@ -70,19 +70,25 @@ class virtual abstract = object(self) (* Sequence of timers. *) method destroy = - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) readables; - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) writables; - Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev) timers; + Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) readables; + Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) writables; + Lwt_sequence.iter_l (fun (_delay, _repeat, _f, _g, ev) -> stop_event ev) + timers; self#cleanup method transfer (engine : abstract) = - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_readable fd f)) readables; - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_writable fd f)) writables; - Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev; ev := !(engine#on_timer delay repeat f)) timers + Lwt_sequence.iter_l (fun (fd, f, _g, ev) -> + stop_event ev; ev := !(engine#on_readable fd f)) readables; + Lwt_sequence.iter_l (fun (fd, f, _g, ev) -> + stop_event ev; ev := !(engine#on_writable fd f)) writables; + Lwt_sequence.iter_l (fun (delay, repeat, f, _g, ev) -> + stop_event ev; ev := !(engine#on_timer delay repeat f)) timers method fake_io fd = - Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) readables; - Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) writables + Lwt_sequence.iter_l (fun (fd', _f, g, _stop) -> + if fd = fd' then g ()) readables; + Lwt_sequence.iter_l (fun (fd', _f, g, _stop) -> + if fd = fd' then g ()) writables method on_readable fd f = let ev = ref _fake_event in @@ -218,16 +224,16 @@ type sleeper = { module Sleep_queue = Lwt_pqueue.Make(struct type t = sleeper - let compare { time = t1 } { time = t2 } = compare t1 t2 + let compare {time = t1; _} {time = t2; _} = compare t1 t2 end) module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) let rec restart_actions sleep_queue now = match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true } -> + | Some{ stopped = true; _ } -> restart_actions (Sleep_queue.remove_min sleep_queue) now - | Some{ time = time; action = action } when time <= now -> + | Some{ time = time; action = action; _ } when time <= now -> (* We have to remove the sleeper to the queue before performing the action. The action can change the sleeper's time, and this might break the priority queue invariant if the sleeper is @@ -240,9 +246,9 @@ let rec restart_actions sleep_queue now = let rec get_next_timeout sleep_queue = match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true } -> + | Some{ stopped = true; _ } -> get_next_timeout (Sleep_queue.remove_min sleep_queue) - | Some{ time = time } -> + | Some{ time = time; _ } -> max 0. (time -. Unix.gettimeofday ()) | None -> -1. @@ -259,7 +265,7 @@ let invoke_actions fd map = | Some actions -> Lwt_sequence.iter_l (fun f -> f ()) actions | None -> () -class virtual select_or_poll_based = object(self) +class virtual select_or_poll_based = object inherit abstract val mutable sleep_queue = Sleep_queue.empty diff --git a/src/unix/lwt_io.ml b/src/unix/lwt_io.ml index 826c74733f..bc522e785d 100644 --- a/src/unix/lwt_io.ml +++ b/src/unix/lwt_io.ml @@ -200,7 +200,7 @@ let is_busy ch = let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main.state with | Busy_primitive | Busy_atomic _ -> begin match ch.typ with - | Type_normal(perform_io, seek) -> + | Type_normal(perform_io, _) -> let ptr, len = match ch.mode with | Input -> (* Size of data in the buffer *) @@ -220,7 +220,7 @@ let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main (function | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return 0 - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] else perform_io ch.buffer ptr len ] >>= fun n -> @@ -282,7 +282,7 @@ let deepest_wrapper ch = match wrapper.state with | Busy_atomic wrapper -> loop wrapper - | _ -> + | Busy_primitive | Waiting_for_busy | Idle | Closed | Invalid -> wrapper in loop ch.main @@ -472,7 +472,7 @@ let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> let is_closed wrapper = match wrapper.state with | Closed -> true - | _ -> false + | Busy_primitive | Busy_atomic _ | Waiting_for_busy | Idle | Invalid -> false let flush_all () = let wrappers = Outputs.fold (fun x l -> x :: l) outputs [] in @@ -487,7 +487,7 @@ let () = (* Flush all opened ouput channels on exit: *) Lwt_main.at_exit flush_all -let no_seek pos cmd = +let no_seek _pos _cmd = Lwt.fail (Failure "Lwt_io.seek: seek not supported on this channel") let make : @@ -820,7 +820,7 @@ struct refill ic >>= function | 0 -> Lwt.return (rev_concat (len + total_len) (str :: acc)) - | n -> + | _ -> read_all ic (len + total_len) (str :: acc) let read count ic = @@ -1148,12 +1148,12 @@ struct Lwt.return_unit let set_position : type m. m _channel -> int64 -> unit Lwt.t = fun ch pos -> match ch.typ, ch.mode with - | Type_normal(perform_io, seek), Output -> + | Type_normal(_, seek), Output -> flush_total ch >>= fun () -> do_seek seek pos >>= fun () -> ch.offset <- pos; Lwt.return_unit - | Type_normal(perform_io, seek), Input -> + | Type_normal(_, seek), Input -> let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in if pos >= current && pos <= ch.offset then begin ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); @@ -1174,7 +1174,7 @@ struct end let length ch = match ch.typ with - | Type_normal(perform_io, seek) -> + | Type_normal(_, seek) -> seek 0L Unix.SEEK_END >>= fun len -> do_seek seek ch.offset >>= fun () -> Lwt.return len @@ -1308,7 +1308,7 @@ let null = make ~mode:output ~buffer:(Lwt_bytes.create min_buffer_size) - (fun str ofs len -> Lwt.return len) + (fun _str _ofs len -> Lwt.return len) (* Do not close standard ios on close, otherwise uncaught exceptions will not be printed *) @@ -1375,7 +1375,7 @@ let close_socket fd = (function (* Occurs if the peer closes the connection first. *) | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit - | exn -> Lwt.fail exn)) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"]) (fun () -> Lwt_unix.close fd) @@ -1433,7 +1433,7 @@ let establish_server ?fd ?(buffer_size = !default_buffer_size) ?(backlog=5) sock let closed_waiter, closed_wakener = Lwt.wait () in let rec loop () = Lwt.pick [Lwt_unix.accept sock >|= (fun x -> `Accept x); abort_waiter] >>= function - | `Accept(fd, addr) -> + | `Accept(fd, _addr) -> (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); let close = lazy (close_socket fd) in f (of_fd ~buffer:(Lwt_bytes.create buffer_size) ~mode:input @@ -1448,7 +1448,7 @@ let establish_server ?fd ?(buffer_size = !default_buffer_size) ?(backlog=5) sock Unix.unlink path; Lwt.return_unit | _ -> - Lwt.return_unit) >>= fun () -> + Lwt.return_unit) [@ocaml.warning "-4"] >>= fun () -> Lwt.wakeup closed_wakener (); Lwt.return_unit in diff --git a/src/unix/lwt_log.ml b/src/unix/lwt_log.ml index e9b903e175..28ce13da59 100644 --- a/src/unix/lwt_log.ml +++ b/src/unix/lwt_log.ml @@ -177,7 +177,7 @@ let syslog_connect paths = | Unix.Unix_error(error, _, _) -> log_intern "can not stat \"%s\": %s" path (Unix.error_message error); Lwt.return_none - end >>= function + end >>= (function | None -> loop paths | Some Unix.S_SOCK -> begin @@ -209,11 +209,11 @@ let syslog_connect paths = Lwt_unix.close fd >>= fun () -> log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); loop paths - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] end | Some _ -> log_intern "\"%s\" is not a socket" path; - loop paths + loop paths) [@ocaml.warning "-4"] in loop paths @@ -287,5 +287,5 @@ let syslog ?(template="$(date) $(name)[$(pid)]: $(section): $(message)") ?(paths match !syslog_socket with | None -> Lwt.return_unit - | Some(socket_type, fd) -> + | Some(_socket_type, fd) -> shutdown fd) diff --git a/src/unix/lwt_process.ml b/src/unix/lwt_process.ml index f7afb25dab..9ffa830b1b 100644 --- a/src/unix/lwt_process.ml +++ b/src/unix/lwt_process.ml @@ -186,8 +186,8 @@ type state = | Running | Exited of Unix.process_status -let status (pid, status, rusage) = status -let rusage (pid, status, rusage) = rusage +let status (_pid, status, _rusage) = status +let rusage (_pid, _status, rusage) = rusage external cast_chan : 'a Lwt_io.channel -> unit Lwt_io.channel = "%identity" (* Transform a channel into a channel that only support closing. *) @@ -204,7 +204,7 @@ object(self) method state = match Lwt.poll wait with | None -> Running - | Some (pid, status, rusage) -> Exited status + | Some (_pid, status, _rusage) -> Exited status method kill signum = if Lwt.state wait = Lwt.Sleep then @@ -245,7 +245,7 @@ object(self) | false -> self#terminate; self#close >>= fun _ -> Lwt.return_unit) - (fun exn -> + (fun _ -> (* The exception is dropped because it can be obtained with self#close. *) Lwt.return_unit) @@ -338,7 +338,7 @@ let read_opt read ic = (function | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] let recv_chars pr = let ic = pr#stdout in diff --git a/src/unix/lwt_unix.ml b/src/unix/lwt_unix.ml index 9079974235..cdd883984e 100644 --- a/src/unix/lwt_unix.ml +++ b/src/unix/lwt_unix.ml @@ -174,13 +174,13 @@ let jobs = Lwt_sequence.create () let rec abort_jobs exn = match Lwt_sequence.take_opt_l jobs with - | Some (w, f) -> f exn; abort_jobs exn + | Some (_, f) -> f exn; abort_jobs exn | None -> () let cancel_jobs () = abort_jobs Lwt.Canceled let wait_for_jobs () = - Lwt.join (Lwt_sequence.fold_l (fun (w, f) l -> w :: l) jobs []) + Lwt.join (Lwt_sequence.fold_l (fun (w, _) l -> w :: l) jobs []) let wrap_result f x = try @@ -770,7 +770,7 @@ let file_exists name = (fun e -> match e with | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_false - | _ -> Lwt.fail e) + | _ -> Lwt.fail e) [@ocaml.warning "-4"] external utimes_job : string -> float -> float -> unit job = "lwt_unix_utimes_job" @@ -866,7 +866,7 @@ struct (fun e -> match e with | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_false - | _ -> Lwt.fail e) + | _ -> Lwt.fail e) [@ocaml.warning "-4"] end @@ -1394,7 +1394,7 @@ let accept_n ch n = wrap_syscall Read ch begin fun () -> begin try - for i = 1 to n do + for _i = 1 to n do if blocking && not (unix_readable ch.fd) then raise Retry; let fd, addr = Unix.accept ch.fd in l := (mk_ch ~blocking:false fd, addr) :: !l @@ -1676,7 +1676,8 @@ let getprotobynumber number = Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getprotobynumber_job number)) -let servent_mutex = +(* TODO: Not used anywhere, and that might be a bug. *) +let _servent_mutex = if Sys.win32 || Lwt_config._HAVE_NETDB_REENTRANT then hostent_mutex else @@ -1871,14 +1872,11 @@ let tcflow ch act = | Reading notifications | +-----------------------------------------------------------------+ *) -(* Buffer used to receive notifications: *) -let notification_buffer = Bytes.create 4 - external init_notification : unit -> Unix.file_descr = "lwt_unix_init_notification" external send_notification : int -> unit = "lwt_unix_send_notification_stub" external recv_notifications : unit -> int array = "lwt_unix_recv_notifications" -let rec handle_notifications ev = +let handle_notifications _ = (* Process available notifications. *) Array.iter call_notification (recv_notifications ()) @@ -1906,13 +1904,13 @@ and signal_handler_id = signal_handler option ref let signals = ref Signal_map.empty let signal_count () = Signal_map.fold - (fun signum (id, actions) len -> len + Lwt_sequence.length actions) + (fun _signum (_id, actions) len -> len + Lwt_sequence.length actions) !signals 0 let on_signal_full signum handler = let id = ref None in - let notification, actions = + let _, actions = try Signal_map.find signum !signals with Not_found -> @@ -1936,7 +1934,7 @@ let on_signal_full signum handler = id := Some { sh_num = signum; sh_node = node }; id -let on_signal signum f = on_signal_full signum (fun id num -> f num) +let on_signal signum f = on_signal_full signum (fun _id num -> f num) let disable_signal_handler id = match !id with @@ -1954,7 +1952,7 @@ let disable_signal_handler id = let reinstall_signal_handler signum = match try Some (Signal_map.find signum !signals) with Not_found -> None with - | Some (notification, actions) -> + | Some (notification, _) -> set_signal signum notification | None -> () @@ -1975,7 +1973,7 @@ let fork () = (* Reinitialise the notification system. *) event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; (* Collect all pending jobs. *) - let l = Lwt_sequence.fold_l (fun (w, f) l -> f :: l) jobs [] in + let l = Lwt_sequence.fold_l (fun (_, f) l -> f :: l) jobs [] in (* Remove them all. *) Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; (* And cancel them all. We yield first so that if the program diff --git a/tests/core/test_lwt.ml b/tests/core/test_lwt.ml index 5a529c440c..6c1cbaf735 100644 --- a/tests/core/test_lwt.ml +++ b/tests/core/test_lwt.ml @@ -63,15 +63,15 @@ let suite = suite "lwt" [ test "1" (fun () -> - catch return (fun e -> return ()) <=> Return (); - catch (fun () -> fail Exn) (function Exn -> return ()| e -> assert false) <=> Return (); + catch return (fun _ -> return ()) <=> Return (); + catch (fun () -> fail Exn) (function Exn -> return () | _ -> assert false) <=> Return (); catch (fun () -> fail Exn) (fun e -> fail e) <=> Fail Exn; return true); test "2" (fun () -> - try_bind return return ( fun e -> assert false ) <=> Return (); - try_bind (fun () -> fail Exn) return (function Exn -> return ()| e -> assert false) <=> Return (); + try_bind return return (fun _ -> assert false) <=> Return (); + try_bind (fun () -> fail Exn) return (function Exn -> return () | _ -> assert false) <=> Return (); return true); test "3" @@ -141,7 +141,7 @@ let suite = suite "lwt" [ test "12" (fun () -> let t,w = wait () in - let t',w' = wait () in + let t', _ = wait () in let r1 = join [return ();t] in let r2 = join [t;t'] in wakeup_exn w Exn; @@ -166,7 +166,7 @@ let suite = suite "lwt" [ (fun () -> assert ( poll (return ()) = Some () ); test_exn poll (fail Exn) Exn; - let t,w = wait () in + let t, _ = wait () in assert ( poll t = None ); return true); @@ -189,8 +189,8 @@ let suite = suite "lwt" [ test "16" (fun () -> let t,w = wait () in - let r1 = catch (fun () -> t) (fun e -> return ()) in r1 <=> Sleep; - let r2 = try_bind (fun () -> t) return ( fun e -> assert false ) in r2 <=> Sleep; + let r1 = catch (fun () -> t) (fun _ -> return ()) in r1 <=> Sleep; + let r2 = try_bind (fun () -> t) return (fun _ -> assert false) in r2 <=> Sleep; wakeup w (); r1 <=> Return (); r2 <=> Return (); @@ -200,8 +200,8 @@ let suite = suite "lwt" [ test "17" (fun () -> - let t,w = task () in - let t',w' = wait () in + let t, _ = task () in + let t', _ = wait () in let t'' = return () in cancel t; cancel t'; @@ -213,7 +213,7 @@ let suite = suite "lwt" [ test "18" (fun () -> - let t,w = task () in + let t, _ = task () in let r = bind t return in cancel r; r <=> Fail Canceled; @@ -221,7 +221,7 @@ let suite = suite "lwt" [ test "19" (fun () -> - let t,w = task () in + let t, _ = task () in on_cancel t (fun () -> ()); on_cancel (return ()) (fun () -> assert false); cancel t; @@ -233,7 +233,7 @@ let suite = suite "lwt" [ test "20" (fun () -> - let t,w = task () in + let t, _ = task () in let t',w' = wait () in let r = pick [t;t'] in r <=> Sleep; wakeup w' (); @@ -248,8 +248,8 @@ let suite = suite "lwt" [ test "22" (fun () -> - let t,w = task () in - let t',w' = wait () in + let t, _ = task () in + let t', _ = wait () in let r = pick [t;t'] in cancel r; r <=> Fail Canceled; @@ -258,7 +258,7 @@ let suite = suite "lwt" [ test "23" (fun () -> - let t,w = task () in + let t, _ = task () in let r = join [t] in cancel r; r <=> Fail Canceled; @@ -267,7 +267,7 @@ let suite = suite "lwt" [ test "24" (fun () -> - let t,w = task () in + let t, _ = task () in let r = choose [t] in cancel r; r <=> Fail Canceled; @@ -276,7 +276,7 @@ let suite = suite "lwt" [ test "25" (fun () -> - let t,w = task () in + let t, _ = task () in let r = catch (fun () -> t) (function Canceled -> return ()| _ -> assert false) in cancel r; r <=> Return (); @@ -285,7 +285,7 @@ let suite = suite "lwt" [ test "26" (fun () -> - let t,w = task () in + let t, _ = task () in let r = try_bind (fun () -> t) (fun _ -> assert false) (function Canceled -> return ()| _ -> assert false) in cancel r; r <=> Return (); @@ -294,7 +294,7 @@ let suite = suite "lwt" [ test "27" (fun () -> - let t,w = wait () in + let _, w = wait () in wakeup w (); test_exn (wakeup w) () (Invalid_argument "Lwt.wakeup_result"); return true); @@ -348,7 +348,7 @@ let suite = suite "lwt" [ test "choose" (fun () -> let t1,w1 = wait () in - let t2,w2 = wait () in + let t2, _ = wait () in let rec f = function | 0 -> [] | i -> (choose [t1;t2])::(f (i-1)) @@ -391,7 +391,7 @@ let suite = suite "lwt" [ test "protected task 3" (fun () -> - let t,w = task () in + let t, _ = task () in let t' = protected t in cancel t'; return ((state t' = Fail Canceled) && (state t = Sleep))); @@ -430,7 +430,7 @@ let suite = suite "lwt" [ test "protected task: cancel task" (fun () -> - let t,w = task () in + let t, _ = task () in let t' = protected t in cancel t; return ((state t' = Fail Canceled) && (state t = Fail Canceled))); @@ -451,7 +451,7 @@ let suite = suite "lwt" [ test "join 3" (fun () -> let t1 = fail Exn in - let t2,w2 = wait () in + let t2, _ = wait () in let t3 = fail Not_found in let t4 = join [t2;t1;t3] in return ((state t1 = Fail Exn) && (state t2 = Sleep) && @@ -460,7 +460,7 @@ let suite = suite "lwt" [ test "join 4" (fun () -> let t1 = fail Exn in - let t2,w2 = wait () in + let t2, _ = wait () in let t3 = return () in let rec f = function | 0 -> return true @@ -509,7 +509,7 @@ let suite = suite "lwt" [ let waiter, wakener = wait () in let t = waiter >>= fun () -> - let waiter, wakener = task () in + let waiter, _ = task () in waiter in wakeup wakener (); @@ -521,7 +521,7 @@ let suite = suite "lwt" [ let waiter, wakener = wait () in let t = waiter >>= fun () -> - let waiter, wakener = task () in + let waiter, _ = task () in waiter in let t = t >>= return in @@ -613,10 +613,10 @@ let suite = suite "lwt" [ test "re-cancel" (fun () -> - let waiter1, wakener1 = task () in - let waiter2, wakener2 = task () in + let waiter1, _ = task () in + let waiter2, _ = task () in let waiter3, wakener3 = task () in - let t1 = catch (fun () -> waiter1) (fun exn -> waiter2) in + let t1 = catch (fun () -> waiter1) (fun _ -> waiter2) in let t2 = bind t1 return in let t3 = bind waiter3 (fun () -> t1) in wakeup wakener3 (); @@ -626,9 +626,9 @@ let suite = suite "lwt" [ test "re-cancel choose" (fun () -> - let waiter1, wakener1 = task () in - let waiter2, wakener2 = task () in - let t1 = catch (fun () -> waiter1) (fun exn -> waiter2) in + let waiter1, _ = task () in + let waiter2, _ = task () in + let t1 = catch (fun () -> waiter1) (fun _ -> waiter2) in let t2 = choose [t1] in cancel t2; cancel t2; diff --git a/tests/core/test_lwt_list.ml b/tests/core/test_lwt_list.ml index 757d214453..0947c5841a 100644 --- a/tests/core/test_lwt_list.ml +++ b/tests/core/test_lwt_list.ml @@ -77,7 +77,7 @@ let test_exception f = let test_map f test_list = let t,w = wait () in - let t',w' = task () in + let t', _ = task () in let get = let r = ref 0 in let c = ref 0 in diff --git a/tests/core/test_lwt_stream.ml b/tests/core/test_lwt_stream.ml index 8e6ac4701f..fc8db987ac 100644 --- a/tests/core/test_lwt_stream.ml +++ b/tests/core/test_lwt_stream.ml @@ -202,7 +202,7 @@ let suite = suite "lwt_stream" [ test "cancel push stream 1" (fun () -> - let stream, push = Lwt_stream.create () in + let stream, _ = Lwt_stream.create () in let t = Lwt_stream.next stream in cancel t; return (state t = Fail Canceled)); @@ -238,7 +238,7 @@ let suite = suite "lwt_stream" [ else match Weak.get w idx with | None -> loop acc (idx + 1) - | Some v -> loop (acc + 1) (idx + 1) + | Some _ -> loop (acc + 1) (idx + 1) in loop 0 0 in @@ -273,7 +273,9 @@ let suite = suite "lwt_stream" [ test "map_exn" (fun () -> - let open Lwt_stream in + (* TODO: This will no longer be a shadowing open once Lwt_stream.error + is removed. *) + let open! Lwt_stream in let l = [Value 1; Error Exit; Error (Failure "plop"); Value 42; Error End_of_file] in let q = ref l in let stream = @@ -352,5 +354,6 @@ let suite = suite "lwt_stream" [ test "choose_exhausted" (fun () -> - Lwt_stream.(to_list (choose [of_list []])) >|= fun _ -> true); + let open! Lwt_stream in + to_list (choose [of_list []]) >|= fun _ -> true); ] diff --git a/tests/core/test_lwt_switch.ml b/tests/core/test_lwt_switch.ml index 17df684ba0..015bfbd99c 100644 --- a/tests/core/test_lwt_switch.ml +++ b/tests/core/test_lwt_switch.ml @@ -29,14 +29,14 @@ let suite = suite "lwt_switch" [ let hook_1_calls = ref 0 in let hook_2_calls = ref 0 in - let hook call_counter ?switch () = + let hook call_counter () = call_counter := !call_counter + 1; Lwt.return_unit in let switch = Lwt_switch.create () in - Lwt_switch.add_hook (Some switch) (hook hook_1_calls ~switch); - Lwt_switch.add_hook (Some switch) (hook hook_2_calls ~switch); + Lwt_switch.add_hook (Some switch) (hook hook_1_calls); + Lwt_switch.add_hook (Some switch) (hook hook_2_calls); let check_1 = !hook_1_calls = 0 in let check_2 = !hook_2_calls = 0 in diff --git a/tests/test.ml b/tests/test.ml index 871258dcbe..35442939ad 100644 --- a/tests/test.ml +++ b/tests/test.ml @@ -20,9 +20,6 @@ * 02111-1307, USA. *) -open Lwt -open Lwt_io - type t = { name : string; only_if : unit -> bool; @@ -39,11 +36,14 @@ let test_direct name ?(only_if = fun () -> true) run = {name; only_if; run} let test name ?(only_if = fun () -> true) run = {name; only_if; run = fun () -> Lwt_main.run (run ())} -let suite ~name ~tests = { suite_name = name; suite_tests = tests } +let suite name tests = { suite_name = name; suite_tests = tests } -let run ~name ~suites = +let run name suites = (* Count the number of tests in [suites] *) - let total = List.fold_left (fun n { suite_tests = l } -> n + List.length l) 0 suites in + let total = + List.fold_left (fun n {suite_tests = l; _} -> + n + List.length l) 0 suites + in Printf.printf "Running %d tests for library %S.\n%!" total name; diff --git a/tests/test.mli b/tests/test.mli index 6e6368542a..d7b3173f8f 100644 --- a/tests/test.mli +++ b/tests/test.mli @@ -36,10 +36,10 @@ val test_direct : string -> ?only_if:(unit -> bool) -> (unit -> bool) -> t val test : string -> ?only_if:(unit -> bool) -> (unit -> bool Lwt.t) -> t (** Like [test_direct], but defines a test which runs a thread. *) -val suite : name : string -> tests : t list -> suite +val suite : string -> t list -> suite (** Defines a suite of tests *) -val run : name : string -> suites : suite list -> unit +val run : string -> suite list -> unit (** Run all the given tests and exit the program with an exit code of [0] if all tests succeeded and with [1] otherwise. *) diff --git a/tests/unix/test_lwt_io.ml b/tests/unix/test_lwt_io.ml index e9cb8b1bc1..3bb599f621 100644 --- a/tests/unix/test_lwt_io.ml +++ b/tests/unix/test_lwt_io.ml @@ -20,9 +20,8 @@ * 02111-1307, USA. *) -open Lwt -open Lwt_io open Test +open Lwt.Infix let with_async_exception_hook hook f = let old_hook = !Lwt.async_exception_hook in @@ -129,36 +128,36 @@ let suite = suite "lwt_io" [ test "auto-flush" (fun () -> let sent = ref [] in - let oc = Lwt_io.make ~mode:output (fun buf ofs len -> + let oc = Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; - return len) in - write oc "foo" >>= fun () -> - write oc "bar" >>= fun () -> + Lwt.return len) in + Lwt_io.write oc "foo" >>= fun () -> + Lwt_io.write oc "bar" >>= fun () -> if !sent <> [] then - return false + Lwt.return false else Lwt_unix.yield () >>= fun () -> - return (!sent = [Bytes.of_string "foobar"])); + Lwt.return (!sent = [Bytes.of_string "foobar"])); test "auto-flush in atomic" (fun () -> let sent = ref [] in - let oc = make ~mode:output (fun buf ofs len -> + let oc = Lwt_io.make ~mode:Lwt_io.output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; - return len) in - atomic + Lwt.return len) in + Lwt_io.atomic (fun oc -> - write oc "foo" >>= fun () -> - write oc "bar" >>= fun () -> + Lwt_io.write oc "foo" >>= fun () -> + Lwt_io.write oc "bar" >>= fun () -> if !sent <> [] then - return false + Lwt.return false else Lwt_unix.yield () >>= fun () -> - return (!sent = [Bytes.of_string "foobar"])) + Lwt.return (!sent = [Bytes.of_string "foobar"])) oc); (* Without the corresponding bugfix, which is to handle ENOTCONN from @@ -182,7 +181,7 @@ let suite = suite "lwt_io" [ local (fun channels -> Lwt.wakeup run_handler channels) in - with_connection local (fun _ -> Lwt.return_unit) >>= fun () -> + Lwt_io.with_connection local (fun _ -> Lwt.return_unit) >>= fun () -> Lwt.wakeup client_finished (); Lwt_io.Versioned.shutdown_server_2 server >>= fun () -> handler); @@ -202,7 +201,7 @@ let suite = suite "lwt_io" [ Lwt.wakeup server_finished ())) in - with_connection local (fun _ -> + Lwt_io.with_connection local (fun _ -> wait_for_server >>= fun () -> Lwt.return_true) @@ -319,7 +318,7 @@ let suite = suite "lwt_io" [ | Unix.Unix_error (Unix.EBADF, _, _) -> exceptions_observed := !exceptions_observed + 1; Lwt.return_unit - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] in let run = @@ -345,15 +344,15 @@ let suite = suite "lwt_io" [ let correct_exceptions = ref true in let see_exception exn = exceptions_observed := !exceptions_observed + 1; - match !exceptions_observed, exn with + (match !exceptions_observed, exn with | 1, Exit | (2 | 3), Unix.Unix_error (Unix.EBADF, _, _) -> () - | _ -> correct_exceptions := false + | _ -> correct_exceptions := false) [@ocaml.warning "-4"] in let run () = Establish_server.with_client - (fun (in_channel, out_channel) -> + (fun (_in_channel, _out_channel) -> close_last_fd 1; raise Exit) in @@ -365,8 +364,8 @@ let suite = suite "lwt_io" [ (fun () -> let open Establish_server in - let in_channel' = ref stdin in - let out_channel' = ref stdout in + let in_channel' = ref Lwt_io.stdin in + let out_channel' = ref Lwt_io.stdout in let server = Lwt_io.Versioned.establish_server_2 local (fun _ -> Lwt.return_unit) in @@ -396,7 +395,7 @@ let suite = suite "lwt_io" [ | Unix.Unix_error (Unix.EBADF, _, _) -> exceptions_observed := !exceptions_observed + 1; Lwt.return_unit - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] in let handler_started, notify_handler_started = Lwt.wait () in diff --git a/tests/unix/test_lwt_io_non_block.ml b/tests/unix/test_lwt_io_non_block.ml index a1f34784b6..1f58bbdccc 100644 --- a/tests/unix/test_lwt_io_non_block.ml +++ b/tests/unix/test_lwt_io_non_block.ml @@ -20,19 +20,18 @@ * 02111-1307, USA. *) -open Lwt -open Lwt_io open Test +open Lwt.Infix let test_file = "Lwt_io_test" let file_contents = "test file content" let open_and_read_filename () = - open_file ~mode:input test_file >>= fun in_chan -> - read in_chan >>= fun s -> - close in_chan >>= fun () -> + Lwt_io.open_file ~mode:Lwt_io.input test_file >>= fun in_chan -> + Lwt_io.read in_chan >>= fun s -> + Lwt_io.close in_chan >>= fun () -> assert (s = file_contents); - return () + Lwt.return () let suite = suite "lwt_io non blocking io" [ test "file does not exist" @@ -40,26 +39,26 @@ let suite = suite "lwt_io non blocking io" [ test "create file" (fun () -> - open_file ~mode:output test_file >>= fun out_chan -> - write out_chan file_contents >>= fun () -> - close out_chan >>= fun () -> - return true); + Lwt_io.open_file ~mode:Lwt_io.output test_file >>= fun out_chan -> + Lwt_io.write out_chan file_contents >>= fun () -> + Lwt_io.close out_chan >>= fun () -> + Lwt.return_true); test "file exists" (fun () -> Lwt_unix.file_exists test_file); test "read file" (fun () -> - open_file ~mode:input test_file >>= fun in_chan -> - read in_chan >>= fun s -> - close in_chan >>= fun () -> - return (s = file_contents)); + Lwt_io.open_file ~mode:Lwt_io.input test_file >>= fun in_chan -> + Lwt_io.read in_chan >>= fun s -> + Lwt_io.close in_chan >>= fun () -> + Lwt.return (s = file_contents)); test "many read file" (fun () -> let rec loop i = open_and_read_filename () >>= fun () -> - if i > 10000 then return true + if i > 10000 then Lwt.return_true else loop (i + 1) in loop 0); @@ -67,6 +66,6 @@ let suite = suite "lwt_io non blocking io" [ test "remove file" (fun () -> Unix.unlink test_file; - return true); + Lwt.return_true); ] diff --git a/tests/unix/test_lwt_process.ml b/tests/unix/test_lwt_process.ml index 58f27575ab..b7beb45cca 100644 --- a/tests/unix/test_lwt_process.ml +++ b/tests/unix/test_lwt_process.ml @@ -1,7 +1,26 @@ +(* Lightweight thread library for OCaml + * http://www.ocsigen.org/lwt + * Copyright (C) 2016 Anton Bachin + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) -open Lwt -open Lwt_io open Test +open Lwt.Infix let suite = suite "lwt_process" [ (* The sleep command is not available on Win32. *) diff --git a/tests/unix/test_lwt_unix.ml b/tests/unix/test_lwt_unix.ml index 755a390723..f41a5ce7e8 100644 --- a/tests/unix/test_lwt_unix.ml +++ b/tests/unix/test_lwt_unix.ml @@ -58,7 +58,7 @@ let utimes_tests = [ (fun () -> Lwt_unix.utimes "non-existent-file" 0. 0.) (function | Unix.Unix_error (Unix.ENOENT, "utimes", _) -> Lwt.return_unit - | e -> Lwt.fail e) >>= fun () -> + | e -> Lwt.fail e) [@ocaml.warning "-4"] >>= fun () -> Lwt.return_true); ] @@ -179,7 +179,7 @@ let readdir_tests = (* Should make sure Win32 behaves in the same way as well. *) test "readdir: already closed" ~only_if:(fun () -> not Sys.win32) (fun () -> - let path, filenames = populate 0 in + let path, _ = populate 0 in Lwt_unix.opendir path >>= fun directory -> Lwt_unix.closedir directory >>= fun () -> @@ -193,7 +193,7 @@ let readdir_tests = (function | Unix.Unix_error (Unix.EBADF, tag', _) when tag' = tag -> Lwt.return_true - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] in Lwt_list.for_all_s (fun (tag, t) -> expect_ebadf tag t)