Simplification and type-safety of Pcoq thanks to GADTs in Genarg.

3 files changed, 8 insertions, 17 deletions

diff --git a/lib/genarg.ml b/lib/genarg.ml
index 030797da9..6c10dee2a 100644
--- a/lib/genarg.ml
+++ b/lib/genarg.ml
@@ -194,16 +194,6 @@ type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type
 type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type
 type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type
 
-let arg_list : type l. (_, l) abstract_argument_type -> (_, l) abstract_argument_type = function
-| Rawwit t -> Rawwit (ListArg t)
-| Glbwit t -> Glbwit (ListArg t)
-| Topwit t -> Topwit (ListArg t)
-
-let arg_opt : type l. (_, l) abstract_argument_type -> (_, l) abstract_argument_type = function
-| Rawwit t -> Rawwit (OptArg t)
-| Glbwit t -> Glbwit (OptArg t)
-| Topwit t -> Topwit (OptArg t)
-
 type ('a, 'b, 'c, 'l) cast =
 | Rcast : 'a -> ('a, 'b, 'c, rlevel) cast
 | Gcast : 'b -> ('a, 'b, 'c, glevel) cast
diff --git a/lib/genarg.mli b/lib/genarg.mli
index 38dc0c684..a1b74c674 100644
--- a/lib/genarg.mli
+++ b/lib/genarg.mli
@@ -291,9 +291,6 @@ val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) gena
 val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
   ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type
 
-val arg_list : ('a, 'l) abstract_argument_type -> ('a list, 'l) abstract_argument_type
-val arg_opt : ('a, 'l) abstract_argument_type -> ('a option, 'l) abstract_argument_type
-
 (** {5 Magic used by the parser} *)
 
 val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option
diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml
index d5acf59f6..c87084f2c 100644
--- a/parsing/pcoq.ml
+++ b/parsing/pcoq.ml
@@ -237,14 +237,15 @@ let new_entry etyp u s =
   let e = Gram.entry_create ename in
   Hashtbl.add utab s (TypedEntry (etyp, e)); e
 
-let create_entry u s etyp =
+let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry =
   let utab = get_utable u in
   try
     let TypedEntry (typ, e) = Hashtbl.find utab s in
-    let u = Entry.univ_name u in
-    if not (argument_type_eq (unquote typ) (unquote etyp)) then
+    match abstract_argument_type_eq typ etyp with
+    | None ->
+      let u = Entry.univ_name u in
       failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
-    Obj.magic e
+    | Some Refl -> e
   with Not_found ->
     new_entry etyp u s
 
@@ -809,6 +810,9 @@ let rec parse_user_entry s sep =
     let s = match s with "hyp" -> "var" | _ -> s in
     Uentry s
 
+let arg_list = function Rawwit t -> Rawwit (ListArg t)
+let arg_opt = function Rawwit t -> Rawwit (OptArg t)
+
 let rec interp_entry_name up_level s sep =
   let rec eval = function
   | Ulist1 e ->