diff --git a/.vscode/settings.json b/.vscode/settings.json index a0207a3..624bea3 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -7,6 +7,8 @@ "Doublable", "functors", "GADT", + "injective", + "injectivity", "janestreet", "kinded", "odoc", diff --git a/CHANGES.md b/CHANGES.md index e108aec..cfef096 100644 --- a/CHANGES.md +++ b/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 diff --git a/doc/docs/tutorials/handler-explicit/dune b/doc/docs/tutorials/handler-explicit/dune index 698f949..4027934 100644 --- a/doc/docs/tutorials/handler-explicit/dune +++ b/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)) diff --git a/doc/docs/tutorials/handler-explicit/prelude.txt b/doc/docs/tutorials/handler-explicit/prelude.txt index 7eefdf6..f4472ac 100644 --- a/doc/docs/tutorials/handler-explicit/prelude.txt +++ b/doc/docs/tutorials/handler-explicit/prelude.txt @@ -1,2 +1,2 @@ #require "provider" ;; -#require "higher_kinded" ;; +#require "provider-tests.higher_kinded" ;; diff --git a/dune-project b/dune-project index 3a7d73b..2181666 100644 --- a/dune-project +++ b/dune-project @@ -106,10 +106,6 @@ (and (>= v0.17) (< v0.18))) - (higher_kinded - (and - (>= v0.17) - (< v0.18))) (mdx (>= 2.4)) (ppx_compare diff --git a/provider-dev.opam b/provider-dev.opam index 23cf7f5..9dc1320 100644 --- a/provider-dev.opam +++ b/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"} 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/higher_kinded/dune b/test/higher_kinded/dune new file mode 100644 index 0000000..e893320 --- /dev/null +++ b/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)) diff --git a/test/higher_kinded/higher_kinded.ml b/test/higher_kinded/higher_kinded.ml new file mode 100644 index 0000000..23c1700 --- /dev/null +++ b/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 diff --git a/test/higher_kinded/higher_kinded.mli b/test/higher_kinded/higher_kinded.mli new file mode 100644 index 0000000..1e21af2 --- /dev/null +++ b/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 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 diff --git a/test/test__info.ml b/test/test__info.ml index d54b00a..0c98e22 100644 --- a/test/test__info.ml +++ b/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 )) |}]; (* 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)