unikernel/duniverse/base/test/test_int_conversions.ml

@@ -0,0 +1,255 @@
+open! Import
+open! Int_conversions
+
+let%test_module "pretty" =
+  (module struct
+    let check input output =
+      List.for_all [ ""; "+"; "-" ] ~f:(fun prefix ->
+        let input = prefix ^ input in
+        let output = prefix ^ output in
+        [%compare.equal: string] output (insert_underscores input))
+    ;;
+
+    let%test _ = check "1" "1"
+    let%test _ = check "12" "12"
+    let%test _ = check "123" "123"
+    let%test _ = check "1234" "1_234"
+    let%test _ = check "12345" "12_345"
+    let%test _ = check "123456" "123_456"
+    let%test _ = check "1234567" "1_234_567"
+    let%test _ = check "12345678" "12_345_678"
+    let%test _ = check "123456789" "123_456_789"
+    let%test _ = check "1234567890" "1_234_567_890"
+  end)
+;;
+
+let%test_module "conversions" =
+  (module struct
+    module type S = sig
+      include Int.S
+
+      val module_name : string
+    end
+
+    let test_conversion (type a b) loc ma mb a_to_b_or_error a_to_b_trunc b_to_a_trunc =
+      let (module A : S with type t = a) = ma in
+      let (module B : S with type t = b) = mb in
+      let examples =
+        [ A.min_value
+        ; A.minus_one
+        ; A.zero
+        ; A.one
+        ; A.max_value
+        ; B.min_value |> b_to_a_trunc
+        ; B.max_value |> b_to_a_trunc
+        ]
+        |> List.concat_map ~f:(fun a -> [ A.pred a; a; A.succ a ])
+        |> List.dedup_and_sort ~compare:A.compare
+        |> List.sort ~compare:A.compare
+      in
+      List.iter examples ~f:(fun a ->
+        let b' = a_to_b_trunc a in
+        let a' = b_to_a_trunc b' in
+        match a_to_b_or_error a with
+        | Ok b ->
+          require
+            loc
+            (B.equal b b')
+            ~if_false_then_print_s:
+              (lazy
+                [%message
+                  "conversion produced wrong value"
+                    ~from:(A.module_name : string)
+                    ~to_:(B.module_name : string)
+                    ~input:(a : A.t)
+                    ~output:(b : B.t)
+                    ~expected:(b' : B.t)]);
+          require
+            loc
+            (A.equal a a')
+            ~if_false_then_print_s:
+              (lazy
+                [%message
+                  "conversion does not round-trip"
+                    ~from:(A.module_name : string)
+                    ~to_:(B.module_name : string)
+                    ~input:(a : A.t)
+                    ~output:(b : B.t)
+                    ~round_trip:(a' : A.t)])
+        | Error error ->
+          require
+            loc
+            (not (A.equal a a'))
+            ~if_false_then_print_s:
+              (lazy
+                [%message
+                  "conversion failed"
+                    ~from:(A.module_name : string)
+                    ~to_:(B.module_name : string)
+                    ~input:(a : A.t)
+                    ~expected_output:(b' : B.t)
+                    ~error:(error : Error.t)]))
+    ;;
+
+    let test loc ma mb (a_to_b_trunc, a_to_b_or_error) (b_to_a_trunc, b_to_a_or_error) =
+      test_conversion loc ma mb a_to_b_or_error a_to_b_trunc b_to_a_trunc;
+      test_conversion loc mb ma b_to_a_or_error b_to_a_trunc a_to_b_trunc
+    ;;
+
+    module Int = struct
+      include Int
+
+      let module_name = "Int"
+    end
+
+    module Int32 = struct
+      include Int32
+
+      let module_name = "Int32"
+    end
+
+    module Int64 = struct
+      include Int64
+
+      let module_name = "Int64"
+    end
+
+    module Nativeint = struct
+      include Nativeint
+
+      let module_name = "Nativeint"
+    end
+
+    let with_exn f x = Or_error.try_with (fun () -> f x)
+    let optional f x = Or_error.try_with (fun () -> Option.value_exn (f x))
+    let alwaysok f x = Ok (f x)
+
+    let%expect_test "int <-> int32" =
+      test
+        [%here]
+        (module Int)
+        (module Int32)
+        (Stdlib.Int32.of_int, with_exn int_to_int32_exn)
+        (Stdlib.Int32.to_int, with_exn int32_to_int_exn);
+      [%expect {| |}];
+      test
+        [%here]
+        (module Int)
+        (module Int32)
+        (Stdlib.Int32.of_int, optional int_to_int32)
+        (Stdlib.Int32.to_int, optional int32_to_int);
+      [%expect {| |}]
+    ;;
+
+    let%expect_test "int <-> int64" =
+      test
+        [%here]
+        (module Int)
+        (module Int64)
+        (Stdlib.Int64.of_int, alwaysok int_to_int64)
+        (Stdlib.Int64.to_int, with_exn int64_to_int_exn);
+      [%expect {| |}];
+      test
+        [%here]
+        (module Int)
+        (module Int64)
+        (Stdlib.Int64.of_int, alwaysok int_to_int64)
+        (Stdlib.Int64.to_int, optional int64_to_int);
+      [%expect {| |}]
+    ;;
+
+    let%expect_test "int <-> nativeint" =
+      test
+        [%here]
+        (module Int)
+        (module Nativeint)
+        (Stdlib.Nativeint.of_int, alwaysok int_to_nativeint)
+        (Stdlib.Nativeint.to_int, with_exn nativeint_to_int_exn);
+      [%expect {| |}];
+      test
+        [%here]
+        (module Int)
+        (module Nativeint)
+        (Stdlib.Nativeint.of_int, alwaysok int_to_nativeint)
+        (Stdlib.Nativeint.to_int, optional nativeint_to_int);
+      [%expect {| |}]
+    ;;
+
+    let%expect_test "int32 <-> int64" =
+      test
+        [%here]
+        (module Int32)
+        (module Int64)
+        (Stdlib.Int64.of_int32, alwaysok int32_to_int64)
+        (Stdlib.Int64.to_int32, with_exn int64_to_int32_exn);
+      [%expect {| |}];
+      test
+        [%here]
+        (module Int32)
+        (module Int64)
+        (Stdlib.Int64.of_int32, alwaysok int32_to_int64)
+        (Stdlib.Int64.to_int32, optional int64_to_int32);
+      [%expect {| |}]
+    ;;
+
+    let%expect_test "int32 <-> nativeint" =
+      test
+        [%here]
+        (module Int32)
+        (module Nativeint)
+        (Stdlib.Nativeint.of_int32, alwaysok int32_to_nativeint)
+        (Stdlib.Nativeint.to_int32, with_exn nativeint_to_int32_exn);
+      [%expect {| |}];
+      test
+        [%here]
+        (module Int32)
+        (module Nativeint)
+        (Stdlib.Nativeint.of_int32, alwaysok int32_to_nativeint)
+        (Stdlib.Nativeint.to_int32, optional nativeint_to_int32);
+      [%expect {| |}]
+    ;;
+
+    let%expect_test "int64 <-> nativeint" =
+      test
+        [%here]
+        (module Int64)
+        (module Nativeint)
+        (Stdlib.Int64.to_nativeint, with_exn int64_to_nativeint_exn)
+        (Stdlib.Int64.of_nativeint, alwaysok nativeint_to_int64);
+      [%expect {| |}];
+      test
+        [%here]
+        (module Int64)
+        (module Nativeint)
+        (Stdlib.Int64.to_nativeint, optional int64_to_nativeint)
+        (Stdlib.Int64.of_nativeint, alwaysok nativeint_to_int64);
+      [%expect {| |}]
+    ;;
+  end)
+;;
+
+let%test_module "Make_hex" =
+  (module struct
+    module Hex_int = struct
+      type t = int [@@deriving quickcheck]
+
+      module M = Make_hex (struct
+        type nonrec t = int [@@deriving sexp, compare ~localize, hash, quickcheck]
+
+        let to_string = Int.Hex.to_string
+        let of_string = Int.Hex.of_string
+        let zero = 0
+        let ( < ) = ( < )
+        let neg = Int.neg
+        let module_name = "Hex_int"
+      end)
+
+      include (M.Hex : module type of M.Hex with type t := t)
+    end
+
+    let%expect_test "validate sexp grammar" =
+      require_ok [%here] (Sexp_grammar_validation.validate_grammar (module Hex_int));
+      [%expect {| String |}]
+    ;;
+  end)
+;;