mte/unikernel/duniverse/lwt/test/ppx/main.ml

open Test
open Lwt

(* Used for the "structure let" test, below. This is wrapped up by the PPX in a
   call to Lwt_main.run, which is executed at module load time. We can't use a
   local module inside the tester function, because that function is run inside
   an outer call to Lwt_main.run, and nested calls to Lwt_main.run are not
   allowed. *)
[@@@ocaml.warning "-22"]
let%lwt structure_let_result = Lwt.return_true
[@@@ocaml.warning "+22"]

let suite = suite "ppx" [
  test "let"
    (fun () ->
       let%lwt x = return 3 in
       return (x + 1 = 4)
    ) ;

  test "nested let"
    (fun () ->
       let%lwt x = return 3 in
       let%lwt y = return 4 in
       return (x + y = 7)
    ) ;

  test "and let"
    (fun () ->
       let%lwt x = return 3
       and y = return 4 in
       return (x + y = 7)
    ) ;

  test "match"
    (fun () ->
       let x = Lwt.return (Some 3) in
       match%lwt x with
       | Some x -> return (x + 1 = 4)
       | None -> return false
    ) ;

  test "match-exn"
    (fun () ->
       let x = Lwt.return (Some 3) in
       let x' = Lwt.fail Not_found in
       let%lwt a =
         match%lwt x with
         | exception Not_found -> return false
         | Some x -> return (x = 3)
         | None -> return false
       and b =
         match%lwt x' with
         | exception Not_found -> return true
         | _ -> return false
       in
       Lwt.return (a && b)
    ) ;

  test "if"
    (fun () ->
       let x = Lwt.return_true in
       let%lwt a =
         if%lwt x then Lwt.return_true else Lwt.return_false
       in
       let%lwt b =
         if%lwt x>|= not then Lwt.return_false else Lwt.return_true
       in
       (if%lwt x >|= not then Lwt.return_unit) >>= fun () ->
       Lwt.return (a && b)
    ) ;

  test "for" (* Test for proper sequencing *)
    (fun () ->
       let r = ref [] in
       let f x =
         let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r)
       in
       let%lwt () =
         for%lwt x = 3 to 5 do f x done
       in return (!r = [5 ; 4 ; 3])
    ) ;

  test "while" (* Test for proper sequencing *)
    (fun () ->
       let r = ref [] in
       let f x =
         let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r)
       in
       let%lwt () =
         let c = ref 2 in
         while%lwt !c < 5 do incr c ; f !c done
       in return (!r = [5 ; 4 ; 3])
    ) ;

  test "assert"
    (fun () ->
       let%lwt () = assert%lwt true
       in return true
    ) ;

  test "try"
    (fun () ->
       try%lwt
         Lwt.fail Not_found
       with _ -> return true
    ) [@warning("@8@11")] ;

  test "try raise"
    (fun () ->
       try%lwt
         raise Not_found
       with _ -> return true
    ) [@warning("@8@11")] ;

  test "try fallback"
    (fun () ->
       try%lwt
         try%lwt
           Lwt.fail Not_found
         with Failure _ -> return false
       with Not_found -> return true
    ) [@warning("@8@11")] ;

  test "finally body"
    (fun () ->
       let x = ref false in
       begin
         (try%lwt
           return_unit
         with
         | _ -> return_unit
         ) [%finally x := true; return_unit]
       end >>= fun () ->
       return !x
    ) ;

  test "finally exn"
    (fun () ->
       let x = ref false in
       begin
         (try%lwt
           raise Not_found
         with
         | _ -> return_unit
         ) [%finally x := true; return_unit]
       end >>= fun () ->
       return !x
    ) ;

  test "finally exn default"
    (fun () ->
       let x = ref false in
       try%lwt
         ( raise Not_found )[%finally x := true; return_unit]
         >>= fun () ->
         return false
       with Not_found ->
         return !x
    ) ;

  test "structure let"
    (fun () ->
       Lwt.return structure_let_result
    ) ;
]

let _ = Test.run "ppx" [ suite ]