From 33f33b3858cee6e06e486241352d8fb489b8d4d9 Mon Sep 17 00:00:00 2001 From: "Petter A. Urkedal" Date: Thu, 26 Oct 2017 21:44:53 +0200 Subject: [PATCH] Remove ppx.lwt usage for cross-compatibility between lwt 2 and 3. This may be reverted when Eliom can be linked with lwt 3. --- bin/jbuild | 1 - bin/query.ml | 35 ++++++----- lib-lwt/caqti_lwt.ml | 10 ++- lib-lwt/jbuild | 1 - tests/bikereg.ml | 28 ++++----- tests/jbuild | 4 -- tests/test_parallel_lwt.ml | 10 +-- tests/test_pool_lwt.ml | 16 ++--- tests/test_sql_lwt.ml | 124 ++++++++++++++++++------------------- 9 files changed, 117 insertions(+), 112 deletions(-) diff --git a/bin/jbuild b/bin/jbuild index 728ee6bf..f7914a9b 100644 --- a/bin/jbuild +++ b/bin/jbuild @@ -3,7 +3,6 @@ (executable ((name query) (modules (query)) - (preprocess (pps (lwt.ppx))) (libraries (caqti caqti-lwt)))) (install diff --git a/bin/query.ml b/bin/query.ml index 5aa47463..827e6b32 100644 --- a/bin/query.ml +++ b/bin/query.ml @@ -16,6 +16,7 @@ open Caqti_describe open Caqti_lwt +open Lwt.Infix module Cal = CalendarLib let field_separator = ref "," @@ -45,30 +46,36 @@ end let main do_describe uri qs = let q = Caqti_query.prepare_any qs in - let%lwt connection = Caqti_lwt.connect uri in + Caqti_lwt.connect uri >>= fun connection -> let module C = (val connection) in let module U = Connection_utils (C) in let describe = (match C.describe with | None -> failwith "The database does not support describe." | Some describe -> describe) in - let%lwt qd = describe q in + describe q >>= fun qd -> + let n = Array.length qd.querydesc_fields in + + let print_description () = + let rec loop i = + if i = n then Lwt.return_unit else + let name, tdesc = qd.querydesc_fields.(i) in + Lwt_io.printf "%s : %s\n" name (string_of_typedesc tdesc) >>= fun () -> + loop (i + 1) in + loop 0 in + let print_tuple r = assert (n > 0); - Lwt_io.print (U.show_field qd 0 r) >> - for%lwt i = 1 to n - 1 do - Lwt_io.print !field_separator >> - Lwt_io.print (U.show_field qd i r) - done >> + let rec loop i = + Lwt_io.print (U.show_field qd i r) >>= fun () -> + if i = n then Lwt.return_unit else + Lwt_io.print !field_separator >>= fun () -> + loop (i + 1) in + loop 0 >>= fun () -> Lwt_io.print "\n" in - if do_describe then - for%lwt i = 0 to n - 1 do - let name, tdesc = qd.querydesc_fields.(i) in - Lwt_io.printf "%s : %s\n" name (string_of_typedesc tdesc) - done - else - C.iter_s q print_tuple [||] + + if do_describe then print_description () else C.iter_s q print_tuple [||] let () = let arg_desc = ref false in diff --git a/lib-lwt/caqti_lwt.ml b/lib-lwt/caqti_lwt.ml index f424793e..ffc1b925 100644 --- a/lib-lwt/caqti_lwt.ml +++ b/lib-lwt/caqti_lwt.ml @@ -85,9 +85,13 @@ include Caqti_connect.Make (struct if choices = [] then Lwt.fail_invalid_arg "Caqti_lwt.Unix.poll: No operation specified." else - let%lwt timed_out = - try%lwt Lwt.choose choices >|= fun _ -> false - with Lwt_unix.Timeout -> Lwt.return_true in + begin + Lwt.catch + (fun () -> Lwt.choose choices >|= fun _ -> false) + (function + | Lwt_unix.Timeout -> Lwt.return_true + | exn -> Lwt.fail exn) + end >>= fun timed_out -> Lwt.return (Lwt_unix.readable fd, Lwt_unix.writable fd, timed_out) end diff --git a/lib-lwt/jbuild b/lib-lwt/jbuild index e15f3134..76368825 100644 --- a/lib-lwt/jbuild +++ b/lib-lwt/jbuild @@ -4,7 +4,6 @@ ((name caqti_lwt) (public_name caqti-lwt) (wrapped false) - (flags (-ppx ppx_lwt)) (modules (Caqti_lwt Caqti_lwt_sql_io)) diff --git a/tests/bikereg.ml b/tests/bikereg.ml index ff453678..d27763dd 100644 --- a/tests/bikereg.ml +++ b/tests/bikereg.ml @@ -104,25 +104,25 @@ let iter_s_stolen (module Db : Caqti_lwt.CONNECTION) f = let test db = (* Examples of statement execution: Create and populate the register. *) - create_bikereg db >> - reg_bike db "BIKE-0000" "Arthur Dent" >> - reg_bike db "BIKE-0001" "Ford Perfect" >> - reg_bike db "BIKE-0002" "Zaphod Beeblebrox" >> - reg_bike db "BIKE-0003" "Trillian" >> - reg_bike db "BIKE-0004" "Marvin" >> - report_stolen db "BIKE-0000" >> - report_stolen db "BIKE-0004" >> + create_bikereg db >>= fun () -> + reg_bike db "BIKE-0000" "Arthur Dent" >>= fun () -> + reg_bike db "BIKE-0001" "Ford Perfect" >>= fun () -> + reg_bike db "BIKE-0002" "Zaphod Beeblebrox" >>= fun () -> + reg_bike db "BIKE-0003" "Trillian" >>= fun () -> + reg_bike db "BIKE-0004" "Marvin" >>= fun () -> + report_stolen db "BIKE-0000" >>= fun () -> + report_stolen db "BIKE-0004" >>= fun () -> (* Examples of single-row queries. *) let show_owner frameno = - match%lwt find_bike_owner frameno db with - | Some owner -> Lwt_io.printf "%s is owned by %s.\n" frameno owner - | None -> Lwt_io.printf "%s is not registered.\n" frameno in - show_owner "BIKE-0003" >> - show_owner "BIKE-0042" >> + find_bike_owner frameno db >>= function + | Some owner -> Lwt_io.printf "%s is owned by %s.\n" frameno owner + | None -> Lwt_io.printf "%s is not registered.\n" frameno in + show_owner "BIKE-0003" >>= fun () -> + show_owner "BIKE-0042" >>= fun () -> (* An example multi-row query. *) - Lwt_io.printf "Stolen:" >> + Lwt_io.printf "Stolen:" >>= fun () -> iter_s_stolen db (fun ~frameno ~owner ?stolen () -> let stolen = match stolen with Some x -> x | None -> assert false in diff --git a/tests/jbuild b/tests/jbuild index bb3920c3..3bb5c4de 100644 --- a/tests/jbuild +++ b/tests/jbuild @@ -22,7 +22,6 @@ (executable ((name test_pool_lwt) (modules (Test_pool_lwt)) - (preprocess (pps (lwt.ppx))) (libraries (caqti_lwt testkit)))) ; Tests Using DBs @@ -35,7 +34,6 @@ (executable ((name bikereg) (modules (Bikereg)) - (preprocess (pps (lwt.ppx))) (libraries (caqti caqti_lwt testkit)))) (alias @@ -56,7 +54,6 @@ (executable ((name test_parallel_lwt) (modules (Test_parallel_lwt)) - (preprocess (pps (lwt.ppx))) (libraries (caqti caqti_lwt testkit)))) (alias @@ -67,7 +64,6 @@ (executable ((name test_sql_lwt) (modules (Test_sql_lwt)) - (preprocess (pps (lwt.ppx))) (libraries (caqti caqti_lwt testkit)))) ; Fake META Files diff --git a/tests/test_parallel_lwt.ml b/tests/test_parallel_lwt.ml index 84ffbef8..2a5be5f3 100644 --- a/tests/test_parallel_lwt.ml +++ b/tests/test_parallel_lwt.ml @@ -34,10 +34,10 @@ let do_query = Caqti_lwt.Pool.use @@ fun (module C : Caqti_lwt.CONNECTION) -> (match Random.int 4 with | 0 -> - C.exec insert_q C.Param.[|int (random_int ()); int (random_int ())|] >> + C.exec insert_q C.Param.[|int (random_int ()); int (random_int ())|] >>= fun () -> Lwt.return 0 | 1 -> - C.exec delete_q C.Param.[|int (random_int ())|] >> + C.exec delete_q C.Param.[|int (random_int ())|] >>= fun () -> Lwt.return 0 | 2 -> C.fold select_1_q C.Tuple.(fun t -> (+) (int 0 t)) @@ -84,10 +84,10 @@ let () = let pool = Caqti_lwt.connect_pool ~max_size uri in Caqti_lwt.Pool.use (fun (module C : Caqti_lwt.CONNECTION) -> - C.exec drop_q [||] >> + C.exec drop_q [||] >>= fun () -> C.exec create_q [||]) - pool >> - (test2 pool !n_r >|= ignore) >> + pool >>= fun () -> + (test2 pool !n_r >|= ignore) >>= fun () -> Caqti_lwt.Pool.use (fun (module C : Caqti_lwt.CONNECTION) -> C.exec drop_q [||]) diff --git a/tests/test_pool_lwt.ml b/tests/test_pool_lwt.ml index 7c2be22b..c5fd8fc7 100644 --- a/tests/test_pool_lwt.ml +++ b/tests/test_pool_lwt.ml @@ -58,13 +58,13 @@ let test n = let () = Lwt_main.run begin - test 0 >> - test 1 >> - test 3 >> - test 8 >> - test 12 >> - test 16 >> - test 64 >> - test 128 >> + test 0 >>= fun () -> + test 1 >>= fun () -> + test 3 >>= fun () -> + test 8 >>= fun () -> + test 12 >>= fun () -> + test 16 >>= fun () -> + test 64 >>= fun () -> + test 128 >>= fun () -> test 1024 end diff --git a/tests/test_sql_lwt.ml b/tests/test_sql_lwt.ml index 83e0bb33..e9f698bb 100644 --- a/tests/test_sql_lwt.ml +++ b/tests/test_sql_lwt.ml @@ -88,98 +88,98 @@ module Q = struct | _ -> raise Caqti_query.Missing_query_string end +let repeat n f = + let rec loop i = + if i = n then Lwt.return_unit else + f i >>= fun () -> loop (i + 1) in + loop 0 + let test_expr (module Db : Caqti_lwt.CONNECTION) = (* Non-prepared. *) - for%lwt i = 0 to 199 do + repeat 200 (fun i -> let qs = sprintf "SELECT %d, '%s'" i (string_of_int i) in - let%lwt j, s = - Db.find (oneshot_sql qs) Db.Tuple.(fun u -> int 0 u, string 1 u) [||] in + Db.find (oneshot_sql qs) Db.Tuple.(fun u -> int 0 u, string 1 u) [||] >>= + fun (j, s) -> assert (i = j); assert (i = int_of_string s); Lwt.return_unit - done >> + ) >>= fun () -> (* Prepared: null *) - for%lwt i = 0 to 3 do - let%lwt c1, c2 = - Db.find Q.select_null_etc Db.Tuple.(fun u -> bool 0 u, is_null 1 u) - Db.Param.([|null; null|]) in + repeat 3 (fun _ -> + Db.find Q.select_null_etc Db.Tuple.(fun u -> bool 0 u, is_null 1 u) + Db.Param.([|null; null|]) >>= fun (c1, c2) -> assert (c1 && c2); Lwt.return_unit - done >> + ) >>= fun () -> (* Prepared: bool *) let ck_and a b = - let%lwt c = - Db.find Q.select_and - Db.Tuple.(fun u -> bool 0 u) Db.Param.([|bool a; bool b|]) in + Db.find Q.select_and + Db.Tuple.(fun u -> bool 0 u) Db.Param.([|bool a; bool b|]) + >>= fun c -> assert (c = (a && b)); Lwt.return_unit in - ck_and false false >> ck_and false true >> - ck_and true false >> ck_and true true >> + ck_and false false >>= fun () -> ck_and false true >>= fun () -> + ck_and true false >>= fun () -> ck_and true true >>= fun () -> (* Prepared: int *) let ck_plus_int i j = - let%lwt k = - Db.find Q.select_plus_int - Db.Tuple.(fun u -> int 0 u) Db.Param.([|int i; int j|]) in + Db.find Q.select_plus_int + Db.Tuple.(fun u -> int 0 u) Db.Param.([|int i; int j|]) >>= fun k -> assert (k = (i + j)); Lwt.return_unit in - for%lwt m = 0 to 199 do + repeat 200 (fun _ -> let i, j = Random.int (1 lsl 29), Random.int (1 lsl 29) in ck_plus_int i j - done >> + ) >>= fun () -> (* Prepared: int64 *) let ck_plus_int64 i j = - let%lwt k = - Db.find Q.select_plus_int - Db.Tuple.(fun u -> int64 0 u) Db.Param.([|int64 i; int64 j|]) in + Db.find Q.select_plus_int + Db.Tuple.(fun u -> int64 0 u) Db.Param.([|int64 i; int64 j|]) + >>= fun k -> assert (k = Int64.add i j); Lwt.return_unit in - for%lwt m = 0 to 199 do + repeat 200 (fun _ -> let i = Random.int64 Int64.(shift_left one 29) in let j = Random.int64 Int64.(shift_left one 29) in ck_plus_int64 i j - done >> + ) >>= fun () -> (* Prepared: float *) let ck_plus_float x y = - let%lwt z = - Db.find Q.select_plus_float - Db.Tuple.(fun u -> float 0 u) Db.Param.([|float x; float y|]) in + Db.find Q.select_plus_float + Db.Tuple.(fun u -> float 0 u) Db.Param.([|float x; float y|]) + >>= fun z -> assert (abs_float (z -. (x +. y)) < 1e-6 *. (x +. y)); Lwt.return_unit in - for%lwt m = 0 to 199 do + repeat 200 (fun _ -> let i, j = Random.float 1e8, Random.float 1e8 in ck_plus_float i j - done >> + ) >>= fun () -> (* Prepared: string *) let ck_string x y = - let%lwt s = - Db.find Q.select_cat - Db.Tuple.(fun u -> string 0 u) - Db.Param.([|string x; string y|]) in + Db.find Q.select_cat + Db.Tuple.(fun u -> string 0 u) + Db.Param.([|string x; string y|]) >>= fun s -> assert (s = x ^ y); Lwt.return_unit in - for%lwt m = 0 to 199 do + repeat 200 (fun _ -> let x = sprintf "%x" (Random.int (1 lsl 29)) in let y = sprintf "%x" (Random.int (1 lsl 29)) in ck_string x y - done >> + ) >>= fun () -> (* Prepared: date *) begin let t0 = Unix.time () in - let%lwt t = - Db.find Q.select_current_time Db.Tuple.(utc_float 0) [||] in + Db.find Q.select_current_time Db.Tuple.(utc_float 0) [||] >>= fun t -> let t1 = Unix.time () in - Lwt.return (assert (t0 -. 1.1 <= t && t <= t1 +. 1.1)) >> - let%lwt t' = - Db.find Q.select_given_time - Db.Tuple.(utc_float 0) Db.Param.[|utc_float t|] in - Lwt.return (assert (abs_float (t' -. t) < 1.1)) >> - let%lwt r = - Db.find Q.compare_to_known_time Db.Tuple.(bool 0) - Db.Param.[|utc_float 1485691200.0|] in + Lwt.return (assert (t0 -. 1.1 <= t && t <= t1 +. 1.1)) >>= fun () -> + Db.find Q.select_given_time + Db.Tuple.(utc_float 0) Db.Param.[|utc_float t|] >>= fun t' -> + Lwt.return (assert (abs_float (t' -. t) < 1.1)) >>= fun () -> + Db.find Q.compare_to_known_time Db.Tuple.(bool 0) + Db.Param.[|utc_float 1485691200.0|] >>= fun r -> Lwt.return (assert r) end @@ -194,23 +194,23 @@ let dump_querydesc qn qd = let test_table (module Db : Caqti_lwt.CONNECTION) = (* Create, insert, select *) - Db.exec Q.create_tmp [||] >> + Db.exec Q.create_tmp [||] >>= fun () -> begin if Db.backend_info.Caqti_metadata.bi_has_transactions then - Db.start () >> - Db.exec Q.insert_into_tmp Db.Param.([|int 1; string "one"|]) >> + Db.start () >>= fun () -> + Db.exec Q.insert_into_tmp Db.Param.([|int 1; string "one"|]) >>= fun () -> Db.rollback () else Lwt.return_unit - end >> - Db.start () >> - Db.exec Q.insert_into_tmp Db.Param.([|int 2; string "two"|]) >> - Db.exec Q.insert_into_tmp Db.Param.([|int 3; string "three"|]) >> - Db.exec Q.insert_into_tmp Db.Param.([|int 5; string "five"|]) >> - Db.commit () >> - let%lwt (i_acc, s_acc) = Db.fold Q.select_from_tmp + end >>= fun () -> + Db.start () >>= fun () -> + Db.exec Q.insert_into_tmp Db.Param.([|int 2; string "two"|]) >>= fun () -> + Db.exec Q.insert_into_tmp Db.Param.([|int 3; string "three"|]) >>= fun () -> + Db.exec Q.insert_into_tmp Db.Param.([|int 5; string "five"|]) >>= fun () -> + Db.commit () >>= fun () -> + Db.fold Q.select_from_tmp Db.Tuple.(fun t (i_acc, s_acc) -> i_acc + int 0 t, s_acc ^ "+" ^ string 1 t) - [||] (0, "zero") in + [||] (0, "zero") >>= fun (i_acc, s_acc) -> assert (i_acc = 10); assert (s_acc = "zero+two+three+five"); @@ -218,7 +218,7 @@ let test_table (module Db : Caqti_lwt.CONNECTION) = (match Db.describe with | None -> Lwt.return_unit | Some describe -> - let%lwt qd = describe Q.select_from_tmp_where_i_lt in + describe Q.select_from_tmp_where_i_lt >>= fun qd -> dump_querydesc "select_from_tmp_where_i_lt" qd >>= fun () -> if Db.backend_info.bi_describe_has_typed_parameters then assert (qd.querydesc_params = [|`Int|]); @@ -227,17 +227,17 @@ let test_table (module Db : Caqti_lwt.CONNECTION) = Lwt.return_unit) let test (module Db : Caqti_lwt.CONNECTION) = - test_expr (module Db) >> - test_table (module Db) >> + test_expr (module Db) >>= fun () -> + test_table (module Db) >>= fun () -> Db.disconnect () let test_pool pool = Caqti_lwt.Pool.use begin fun (module Db : Caqti_lwt.CONNECTION) -> - test_expr (module Db) >> + test_expr (module Db) >>= fun () -> test_table (module Db) end - pool >> + pool >>= fun () -> Caqti_lwt.Pool.drain pool let () = @@ -247,6 +247,6 @@ let () = Sys.argv.(0); let uri = common_uri () in Lwt_main.run begin - Caqti_lwt.connect uri >>= test >> + Caqti_lwt.connect uri >>= test >>= fun () -> test_pool (Caqti_lwt.connect_pool uri) end