From bd0befffb80c3086e3b451456cec24f3a12ac1f0 Mon Sep 17 00:00:00 2001
From: Enrico Tassi <Enrico.Tassi@inria.fr>
Date: Fri, 13 May 2016 17:44:45 +0200
Subject: Dyn: simplify API introducing an Easy submodule

Now the casual Dyn user does not need to be a GADT guru
---
 lib/dyn.ml           | 44 +++++++++++++++++++++++++++++++++++++++++---
 lib/dyn.mli          | 13 ++++++++++++-
 lib/pp.ml            |  8 ++------
 library/libobject.ml | 13 +------------
 library/summary.ml   | 13 +------------
 5 files changed, 57 insertions(+), 34 deletions(-)

diff --git a/lib/dyn.ml b/lib/dyn.ml
index 676467e46..65d1442ac 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -11,7 +11,7 @@ sig
   type 'a t
 end
 
-module type S =
+module type PreS =
 sig
 type 'a tag
 type t = Dyn : 'a tag * 'a -> t
@@ -44,10 +44,23 @@ sig
 end
 
 val dump : unit -> (int * string) list
+
 end
 
-module Make(M : CSig.EmptyS) =
-struct
+module type S =
+sig
+  include PreS
+
+  module Easy : sig
+    val make_dyn : string -> ('a -> t) * (t -> 'a)
+    val inj : 'a -> 'a tag -> t
+    val prj : t -> 'a tag -> 'a option
+  end
+
+end
+
+module Make(M : CSig.EmptyS) = struct
+module Self : PreS = struct
 (* Dynamics, programmed with DANGER !!! *)
 
 type 'a tag = int
@@ -108,3 +121,28 @@ let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu
 end
 
 end
+include Self
+
+module Easy = struct
+(* now tags are opaque, we can do the trick *)
+let make_dyn (s : string) =
+ (fun (type a) (tag : a tag) ->
+  let infun : (a -> t) = fun x -> Dyn (tag, x) in
+  let outfun : (t -> a) = fun (Dyn (t, x)) ->
+    match eq tag t with
+    | None -> assert false
+    | Some CSig.Refl -> x
+  in
+  (infun, outfun))
+ (create s)
+
+let inj x tag = Dyn(tag,x)
+let prj : type a. t -> a tag -> a option =
+    fun (Dyn(tag',x)) tag ->
+    match eq tag tag' with
+    | None -> None
+    | Some CSig.Refl -> Some x
+end
+
+end
+
diff --git a/lib/dyn.mli b/lib/dyn.mli
index c94fa764b..448b11a18 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -6,7 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Dynamics. Use with extreme care. Not for kids. *)
+(** Dynamically typed values *)
+
 module type TParam =
 sig
   type 'a t
@@ -46,6 +47,16 @@ end
 
 val dump : unit -> (int * string) list
 
+module Easy : sig
+
+  (* To create a dynamic type on the fly *)
+  val make_dyn : string -> ('a -> t) * (t -> 'a)
+
+  (* For types declared with the [create] function above *)
+  val inj : 'a -> 'a tag -> t
+  val prj : t -> 'a tag -> 'a option
+end
+
 end
 
 (** FIXME: use OCaml 4.02 generative functors when available *)
diff --git a/lib/pp.ml b/lib/pp.ml
index c7cf9b8d0..e4c78ba73 100644
--- a/lib/pp.ml
+++ b/lib/pp.ml
@@ -57,12 +57,8 @@ module Dyn = Dyn.Make(struct end)
 type t = Dyn.t
 type 'a key = 'a Dyn.tag
 let create = Dyn.create
-let inj x k = Dyn.Dyn (k, x)
-let prj : type a. t -> a key -> a option = fun dyn k ->
-  let Dyn.Dyn (k', x) = dyn in
-  match Dyn.eq k k' with
-  | None -> None
-  | Some CSig.Refl -> Some x
+let inj = Dyn.Easy.inj
+let prj = Dyn.Easy.prj
 
 end
 
diff --git a/library/libobject.ml b/library/libobject.ml
index bbbb134df..c566840e4 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -78,20 +78,9 @@ let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t
 let cache_tab =
   (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
 
-let make_dyn (type a) (tag : a Dyn.tag) =
-  let infun x = Dyn.Dyn (tag, x) in
-  let outfun : (Dyn.t -> a) = fun dyn ->
-    let Dyn.Dyn (t, x) = dyn in
-    match Dyn.eq t tag with
-    | None -> assert false
-    | Some Refl -> x
-  in
-  (infun, outfun)
-
 let declare_object_full odecl =
   let na = odecl.object_name in
-  let tag = Dyn.create na in
-  let (infun, outfun) = make_dyn tag in
+  let (infun, outfun) = Dyn.Easy.make_dyn na in
   let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj)
   and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj)
   and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj)
diff --git a/library/summary.ml b/library/summary.ml
index 19e7e5fd9..edea7dbe5 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -22,19 +22,8 @@ let summaries = ref Int.Map.empty
 
 let mangle id = id ^ "-SUMMARY"
 
-let make_dyn (type a) (tag : a Dyn.tag) =
-  let infun x = Dyn.Dyn (tag, x) in
-  let outfun : (Dyn.t -> a) = fun dyn ->
-    let Dyn.Dyn (t, x) = dyn in
-    match Dyn.eq t tag with
-    | None -> assert false
-    | Some Refl -> x
-  in
-  (infun, outfun)
-
 let internal_declare_summary hash sumname sdecl =
-  let tag = Dyn.create (mangle sumname) in
-  let (infun, outfun) = make_dyn tag in
+  let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in
   let dyn_freeze b = infun (sdecl.freeze_function b)
   and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum)
   and dyn_init = sdecl.init_function in
-- 
cgit v1.2.3