Type-safe Egramml.make_rule.

1 files changed, 50 insertions, 2 deletions

diff --git a/parsing/egramml.ml b/parsing/egramml.ml
index 77d60ff7d..96c1566c4 100644
--- a/parsing/egramml.ml
+++ b/parsing/egramml.ml
@@ -43,6 +43,54 @@ let make_rule mkact pt =
   let act = make_generic_action mkact ntl in
   (symbs, act)
 
+type 'a ty_arg = Id.t * ('a -> raw_generic_argument)
+
+type ('self, _, 'r) ty_rule =
+| TyStop : ('self, 'r, 'r) ty_rule
+| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option ->
+  ('self, 'b -> 'a, 'r) ty_rule
+
+type ('self, 'r) any_ty_rule =
+| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule
+
+let rec ty_rule_of_gram = function
+| [] -> AnyTyRule TyStop
+| GramTerminal s :: rem ->
+  let AnyTyRule rem = ty_rule_of_gram rem in
+  let tok = Atoken (Lexer.terminal s) in
+  let r = TyNext (rem, tok, None) in
+  AnyTyRule r
+| GramNonTerminal (_, t, tok, idopt) :: rem ->
+  let AnyTyRule rem = ty_rule_of_gram rem in
+  let inj = match idopt with
+  | None -> None
+  | Some id ->
+    (** FIXME *)
+    Some (id, fun obj -> Genarg.Unsafe.inj t (Obj.repr obj))
+  in
+  let r = TyNext (rem, tok, inj) in
+  AnyTyRule r
+
+let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function
+| TyStop -> Extend.Stop
+| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok)
+
+type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r
+
+let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function
+| TyStop -> fun f loc -> f loc []
+| TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f
+| TyNext (rem, tok, Some (id, inj)) -> fun f x ->
+  let f loc args = f loc ((id, inj x) :: args) in
+  ty_eval rem f
+
+let make_rule' f prod =
+  let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in
+  let symb = ty_erase ty_rule in
+  let f loc l = f loc (List.rev l) in
+  let act = ty_eval ty_rule f in
+  Extend.Rule (symb, act)
+
 (** Vernac grammar extensions *)
 
 let vernac_exts = ref []
@@ -59,5 +107,5 @@ let extend_vernac_command_grammar s nt gl =
   let nt = Option.default Vernac_.command nt in
   vernac_exts := (s,gl) :: !vernac_exts;
   let mkact loc l = VernacExtend (s,List.map snd l) in
-  let rules = [make_rule mkact gl] in
-  maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)])
+  let rules = [make_rule' mkact gl] in
+  grammar_extend nt None (None, [None, None, rules])