From 194cc52b73faae4f44ec5890b2e7e4fa5edd6788 Mon Sep 17 00:00:00 2001
From: Mathieu Barbin <mathieu.barbin@gmail.com>
Date: Thu, 31 Oct 2024 11:35:37 +0100
Subject: [PATCH] Check higher_kinded during tests as well

---
 test/dune                    |   1 +
 test/test__higher_kinded.ml  | 110 +++++++++++++++++++++++++++++++++++
 test/test__higher_kinded.mli |   0
 3 files changed, 111 insertions(+)
 create mode 100644 test/test__higher_kinded.ml
 create mode 100644 test/test__higher_kinded.mli

diff --git a/test/dune b/test/dune
index 150fb43..86f8a30 100644
--- a/test/dune
+++ b/test/dune
@@ -16,6 +16,7 @@
   base
   expect_test_helpers_core.expect_test_helpers_base
   provider
+  provider-tests.higher_kinded
   test_interfaces
   test_providers
   unix)
diff --git a/test/test__higher_kinded.ml b/test/test__higher_kinded.ml
new file mode 100644
index 0000000..175d7c0
--- /dev/null
+++ b/test/test__higher_kinded.ml
@@ -0,0 +1,110 @@
+(* In this test we check that the trait system allows to be used with module
+   interfaces that are parametrized.
+
+   There is also a tutorial for this, but we like to have both. Motivations are:
+
+   - here we get better error messages and development experience when working
+     on this (the tutorial is an mdx file, which has a slightly less advanced
+     editor integration).
+
+   - this test is checked by [more-ci] whereas the tutorial is not. *)
+
+module type Mappable = sig
+  type 'a t
+
+  val map : 'a t -> f:('a -> 'b) -> 'b t
+
+  type higher_kinded
+
+  val inject : 'a t -> ('a -> higher_kinded) Higher_kinded.t
+  val project : ('a -> higher_kinded) Higher_kinded.t -> 'a t
+end
+
+type mappable = [ `Mappable ]
+
+module Mappable : sig
+  val t
+    : ( ('a -> 'higher_kinded) Higher_kinded.t
+        , (module Mappable with type higher_kinded = 'higher_kinded)
+        , [> mappable ] )
+        Provider.Trait.t
+end = struct
+  type (_, _, _) Provider.Trait.t +=
+    | Mappable :
+        ( ('a -> 'higher_kinded) Higher_kinded.t
+          , (module Mappable with type higher_kinded = 'higher_kinded)
+          , [> mappable ] )
+          Provider.Trait.t
+
+  let t = Mappable
+end
+
+let map_n_times
+  : type a t.
+    ((a -> t) Higher_kinded.t, [> mappable ]) Provider.Handler.t
+    -> (a -> t) Higher_kinded.t
+    -> int
+    -> f:(a -> a)
+    -> (a -> t) Higher_kinded.t
+  =
+  fun handler t n ~f ->
+  let module M = (val Provider.Handler.lookup handler ~trait:Mappable.t) in
+  let at = M.project t in
+  let rec loop n at = if n = 0 then at else loop (n - 1) (M.map at ~f) in
+  M.inject (loop n at)
+;;
+
+module Higher_kinded_list = struct
+  include List
+  include Higher_kinded.Make (List)
+end
+
+module Higher_kinded_array = struct
+  include Array
+  include Higher_kinded.Make (Array)
+end
+
+module _ : Mappable with type 'a t = 'a list = Higher_kinded_list
+module _ : Mappable with type 'a t = 'a array = Higher_kinded_array
+
+let mappable_list ()
+  : ( ('a -> Higher_kinded_list.higher_kinded) Higher_kinded.t
+      , [> mappable ] )
+      Provider.Handler.t
+  =
+  Provider.Handler.make
+    [ Provider.Trait.implement Mappable.t ~impl:(module Higher_kinded_list) ]
+;;
+
+let mappable_array ()
+  : ( ('a -> Higher_kinded_array.higher_kinded) Higher_kinded.t
+      , [> mappable ] )
+      Provider.Handler.t
+  =
+  Provider.Handler.make
+    [ Provider.Trait.implement Mappable.t ~impl:(module Higher_kinded_array) ]
+;;
+
+let%expect_test "map_n_times" =
+  let r =
+    map_n_times
+      (mappable_list ())
+      (List.init 10 ~f:Fn.id |> Higher_kinded_list.inject)
+      3
+      ~f:(fun x -> x + 1)
+    |> Higher_kinded_list.project
+  in
+  print_s [%sexp (r : int list)];
+  [%expect {| (3 4 5 6 7 8 9 10 11 12) |}];
+  let r =
+    map_n_times
+      (mappable_array ())
+      ([| "a"; "b" |] |> Higher_kinded_array.inject)
+      4
+      ~f:(fun x -> x ^ x)
+    |> Higher_kinded_array.project
+  in
+  print_s [%sexp (r : string array)];
+  [%expect {| (aaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbb) |}];
+  ()
+;;
diff --git a/test/test__higher_kinded.mli b/test/test__higher_kinded.mli
new file mode 100644
index 0000000..e69de29