Merge pull request #32 from mbarbin/custom-higher-kinded

Use a custom higher kinded mini-library

.vscode/settings.json

@@ -7,6 +7,8 @@
         "Doublable",
         "functors",
         "GADT",
+        "injective",
+        "injectivity",
         "janestreet",
         "kinded",
         "odoc",

CHANGES.md

@@ -4,7 +4,7 @@
 
 ### Changed
 
-- Register custom trait names instead of extensible variant names (PR, @mbarbin).
+- Register custom trait names instead of extensible variant names (#31, @mbarbin).
 
 ### Deprecated
 

doc/docs/tutorials/handler-explicit/dune

@@ -2,5 +2,6 @@
  (package provider-dev)
  (deps
   (package provider)
+  (package provider-tests)
   (glob_files *.txt))
  (preludes prelude.txt))

doc/docs/tutorials/handler-explicit/prelude.txt

@@ -1,2 +1,2 @@
 #require "provider" ;;
-#require "higher_kinded" ;;
+#require "provider-tests.higher_kinded" ;;

dune-project

@@ -106,10 +106,6 @@
    (and
     (>= v0.17)
     (< v0.18)))
-  (higher_kinded
-   (and
-    (>= v0.17)
-    (< v0.18)))
   (mdx
    (>= 2.4))
   (ppx_compare

provider-dev.opam

@@ -17,7 +17,6 @@ depends: [
   "eio" {>= "1.0"}
   "eio_main" {>= "1.0"}
   "expect_test_helpers_core" {>= "v0.17" & < "v0.18"}
-  "higher_kinded" {>= "v0.17" & < "v0.18"}
   "mdx" {>= "2.4"}
   "ppx_compare" {>= "v0.17" & < "v0.18"}
   "ppx_enumerate" {>= "v0.17" & < "v0.18"}

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)

test/higher_kinded/dune

@@ -0,0 +1,9 @@
+(library
+ (name higher_kinded)
+ (public_name provider-tests.higher_kinded)
+ (flags :standard -w +a-4-40-41-42-44-45-48-66 -warn-error +a)
+ (instrumentation
+  (backend bisect_ppx))
+ (lint
+  (pps ppx_js_style -check-doc-comments))
+ (preprocess no_preprocessing))

test/higher_kinded/higher_kinded.ml

@@ -0,0 +1,19 @@
+type !'a t
+type !'a hk = 'a t
+
+module type S = sig
+  type 'a t
+  type higher_kinded
+
+  val inject : 'a t -> ('a -> higher_kinded) hk
+  val project : ('a -> higher_kinded) hk -> 'a t
+end
+
+module Make (X : sig
+    type 'a t
+  end) : S with type 'a t := 'a X.t = struct
+  type higher_kinded
+
+  external inject : 'a X.t -> ('a -> higher_kinded) hk = "%identity"
+  external project : ('a -> higher_kinded) hk -> 'a X.t = "%identity"
+end

test/higher_kinded/higher_kinded.mli

@@ -0,0 +1,27 @@
+(** A minimal higher-kinded library for the purpose of tests and tutorials.
+
+    This is a reduced variation on https://github.com/janestreet/higher_kinded
+    that we use to explore ways the Provider library may be used with interfaces
+    containing parametrized types.
+
+    We use this small kernel rather than an upstream library because we needed
+    to add some injectivity annotations to the types, and the higher-kinded
+    libraries available do not have them at this time. Proposing this change
+    upstream would require more thoughts, and so far we didn't have actual usage
+    for this (outside of tests and tutorials), so we just went with this small
+    kernel instead. *)
+
+type !'a t
+type !'a hk := 'a t
+
+module type S = sig
+  type 'a t
+  type higher_kinded
+
+  val inject : 'a t -> ('a -> higher_kinded) hk
+  val project : ('a -> higher_kinded) hk -> 'a t
+end
+
+module Make (X : sig
+    type !'a t
+  end) : S with type 'a t := 'a X.t

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) |}];
+  ()
+;;

test/test__info.ml

@@ -1,9 +1,15 @@
-type (_, _, _) Provider.Trait.t +=
-  | T : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
+module T : sig
+  val t : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
+end = struct
+  type (_, _, _) Provider.Trait.t +=
+    | T : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
+
+  let t = T
+end
 
 let%expect_test "info" =
   (* By default, id are not shown, and trait do not have names. *)
-  let print_info () = print_s [%sexp (Provider.Trait.info T : Provider.Trait.Info.t)] in
+  let print_info () = print_s [%sexp (Provider.Trait.info T.t : Provider.Trait.Info.t)] in
   [%expect {||}];
   (* It is possible to show the id with custom functions. *)
   Ref.set_temporarily
@@ -15,14 +21,14 @@ let%expect_test "info" =
      (name <none>))
     |}];
   (* It is also possible to register a name for a trait. *)
-  let () = Provider.Trait.Info.register_name T ~name:"Hello Name!" in
+  let () = Provider.Trait.Info.register_name T.t ~name:"Hello Name!" in
   print_info ();
   [%expect {|
     ((id   #id)
      (name "Hello Name!"))
     |}];
   (* The name can be changed. Whether this is desirable is up to the user. *)
-  let () = Provider.Trait.Info.register_name T ~name:"Goodbye Name!" in
+  let () = Provider.Trait.Info.register_name T.t ~name:"Goodbye Name!" in
   print_info ();
   [%expect {|
     ((id   #id)