From 94f4ade387013a2e3fe8d1042fbd152088ce1daa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 3 Oct 2016 14:46:58 +0200 Subject: Introduction of the Ltac2 plugin. For now, it is only a simple mini-ML whose effects are the proofview monad. There is no facility to manipulate terms nor any hardwired tactic. Pattern-matching is restricted to superficial constructors, the language is lacking a lot of user-friendly interfaces, the grammar is crappy, and much more. --- Ltac2.v | 42 +++ g_ltac2.ml4 | 206 ++++++++++++ ltac2_plugin.mlpack | 6 + tac2core.ml | 119 +++++++ tac2core.mli | 34 ++ tac2entries.ml | 321 ++++++++++++++++++ tac2entries.mli | 33 ++ tac2env.ml | 139 ++++++++ tac2env.mli | 58 ++++ tac2expr.mli | 136 ++++++++ tac2intern.ml | 921 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tac2intern.mli | 30 ++ tac2interp.ml | 108 ++++++ tac2interp.mli | 19 ++ vo.itarget | 1 + 15 files changed, 2173 insertions(+) create mode 100644 Ltac2.v create mode 100644 g_ltac2.ml4 create mode 100644 ltac2_plugin.mlpack create mode 100644 tac2core.ml create mode 100644 tac2core.mli create mode 100644 tac2entries.ml create mode 100644 tac2entries.mli create mode 100644 tac2env.ml create mode 100644 tac2env.mli create mode 100644 tac2expr.mli create mode 100644 tac2intern.ml create mode 100644 tac2intern.mli create mode 100644 tac2interp.ml create mode 100644 tac2interp.mli create mode 100644 vo.itarget diff --git a/Ltac2.v b/Ltac2.v new file mode 100644 index 0000000000..a952524e71 --- /dev/null +++ b/Ltac2.v @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit := "ltac2" "print". +Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". +Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". + +End Message. + +Module Array. + +Ltac2 @external make : int -> 'a -> ('a) array := "ltac2" "array_make". +Ltac2 @external length : ('a) array -> int := "ltac2" "array_length". +Ltac2 @external get : ('a) array -> int -> 'a := "ltac2" "array_get". +Ltac2 @external set : ('a) array -> int -> 'a -> unit := "ltac2" "array_set". + +End Array. diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 new file mode 100644 index 0000000000..349220f9de --- /dev/null +++ b/g_ltac2.ml4 @@ -0,0 +1,206 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CPatRef (!@loc, id, pl) + | id = Prim.qualid -> CPatRef (!@loc, id, []) ] + | "0" + [ "_" -> CPatAny (!@loc) + | "()" -> CPatTup (!@loc, []) + | id = Prim.qualid -> CPatRef (!@loc, id, []) + | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> CPatTup (!@loc, pl) ] + ] + ; + tac2expr: + [ "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "5" -> CTacFun (!@loc, it, body) + | "let"; isrec = rec_flag; + lc = LIST1 let_clause SEP "with"; "in"; + e = tac2expr LEVEL "5" -> CTacLet (!@loc, isrec, lc, e) + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches ;"end" -> + CTacCse (!@loc, e, bl) + ] + | "2" LEFTA + [ e1 = tac2expr; ";"; e2 = tac2expr -> CTacSeq (!@loc, e1, e2) ] + | "1" LEFTA + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) + | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "0" SEP "," -> CTacTup (!@loc, e0 :: el) ] + | "0" + [ "("; a = tac2expr LEVEL "5"; ")" -> a + | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) + | "()" -> CTacTup (!@loc, []) + | "("; ")" -> CTacTup (!@loc, []) + | "["; a = LIST0 tac2expr LEVEL "1" SEP ";"; "]" -> CTacLst (!@loc, a) + | a = tactic_atom -> a ] + ] + ; + branches: + [ [ -> [] + | "|"; bl = LIST1 branch SEP "|" -> bl + | bl = LIST1 branch SEP "|" -> bl ] + ] + ; + branch: + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "5" -> (pat, e) ] ] + ; + rec_flag: + [ [ IDENT "rec" -> true + | -> false ] ] + ; + typ_param: + [ [ "'"; id = Prim.ident -> id ] ] + ; + tactic_atom: + [ [ n = Prim.integer -> CTacAtm (!@loc, AtmInt n) + | s = Prim.string -> CTacAtm (!@loc, AtmStr s) + | id = Prim.qualid -> CTacRef id + ] ] + ; + let_clause: + [ [ id = binder; ":="; te = tac2expr -> + (id, None, te) + | id = binder; args = LIST1 input_fun; ":="; te = tac2expr -> + (id, None, CTacFun (!@loc, args, te)) ] ] + ; + tac2type: + [ "5" RIGHTA + [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] + | "2" + [ t = tac2type; "*"; tl = LIST1 tac2type SEP "*" -> CTypTuple (!@loc, t :: tl) ] + | "1" + [ "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> CTypRef (!@loc, qid, p) ] + | "0" + [ "("; t = tac2type; ")" -> t + | id = typ_param -> CTypVar (!@loc, Name id) + | "_" -> CTypVar (!@loc, Anonymous) + | qid = Prim.qualid -> CTypRef (!@loc, qid, []) ] + ]; + locident: + [ [ id = Prim.ident -> (!@loc, id) ] ] + ; + binder: + [ [ "_" -> (!@loc, Anonymous) + | l = Prim.ident -> (!@loc, Name l) ] ] + ; + input_fun: + [ [ b = binder -> (b, None) + | "("; b = binder; ":"; t = tac2type; ")" -> (b, Some t) ] ] + ; + tac2def_body: + [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + let e = if List.is_empty it then e else CTacFun (!@loc, it, e) in + (name, e) + ] ] + ; + tac2def_val: + [ [ isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + StrVal (isrec, l) + ] ] + ; + tac2typ_knd: + [ [ t = tac2type -> CTydDef (Some t) + | t = tac2alg_type -> CTydAlg t ] ] + ; + tac2alg_type: + [ [ -> [] + | "|"; bl = LIST1 tac2alg_constructor SEP "|" -> bl ] ] + ; + tac2alg_constructor: + [ [ c = Prim.ident -> (c, []) + | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> (c, args) ] ] + ; + tac2typ_prm: + [ [ -> [] + | id = typ_param -> [!@loc, id] + | "("; ids = LIST1 [ id = typ_param -> (!@loc, id) ] SEP "," ;")" -> ids + ] ] + ; + tac2typ_def: + [ [ prm = tac2typ_prm; id = locident; ":="; e = tac2typ_knd -> + (id, (prm, e)) + | prm = tac2typ_prm; id = locident -> (id, (prm, CTydDef None)) + ] ] + ; + tac2def_typ: + [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> + StrTyp (isrec, l) + ] ] + ; + tac2def_ext: + [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + plugin = Prim.string; name = Prim.string -> + let ml = { mltac_plugin = plugin; mltac_tactic = name } in + StrPrm (id, t, ml) + ] ] + ; +END + +let pr_ltac2entry _ = mt () (** FIXME *) +let pr_ltac2expr _ = mt () (** FIXME *) + +VERNAC ARGUMENT EXTEND ltac2_entry +PRINTED BY pr_ltac2entry +| [ tac2def_val(v) ] -> [ v ] +| [ tac2def_typ(t) ] -> [ t ] +| [ tac2def_ext(e) ] -> [ e ] +END + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition CLASSIFIED AS SIDEFF +| [ "Ltac2" ltac2_entry(e) ] -> [ + let local = Locality.LocalityFixme.consume () in + Tac2entries.register_struct ?local e + ] +END + +let _ = + let mode = { + Proof_global.name = "Ltac2"; + set = (fun () -> set_command_entry tac2mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY pr_ltac2expr +| [ tac2expr(e) ] -> [ e ] +END + +open G_ltac +open Vernac_classifier + +VERNAC tac2mode EXTEND VernacLtac2 +| [ - ltac2_expr(t) ltac_use_default(default) ] => + [ classify_as_proofstep ] -> [ +(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) + Tac2entries.call ~default t + ] +END + +open Stdarg + +VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF +| [ "Print" "Ltac2" reference(tac) ] -> [ Tac2entries.print_ltac tac ] +END diff --git a/ltac2_plugin.mlpack b/ltac2_plugin.mlpack new file mode 100644 index 0000000000..561bd0eb0a --- /dev/null +++ b/ltac2_plugin.mlpack @@ -0,0 +1,6 @@ +Tac2env +Tac2intern +Tac2interp +Tac2entries +Tac2core +G_ltac2 diff --git a/tac2core.ml b/tac2core.ml new file mode 100644 index 0000000000..af4124e647 --- /dev/null +++ b/tac2core.ml @@ -0,0 +1,119 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* () +| _ -> assert false + +let rec of_list = function +| [] -> v_nil +| x :: l -> v_cons x (of_list l) + +let rec to_list = function +| ValInt 0 -> [] +| ValBlk (0, [|v; vl|]) -> v :: to_list vl +| _ -> assert false + +end + +let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v + +let val_pp = Val.create "ltac2:pp" +let get_pp v = extract_val val_pp v + +(** Helper functions *) + +let return x = Proofview.tclUNIT x +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let wrap f = + return () >>= fun () -> return (f ()) + +let wrap_unit f = + return () >>= fun () -> f (); return v_unit + +(** Primitives *) + +let prm_print : ml_tactic = function +| [ValExt pp] -> wrap_unit (fun () -> Feedback.msg_notice (get_pp pp)) +| _ -> assert false + +let prm_message_of_int : ml_tactic = function +| [ValInt s] -> return (ValExt (Val.Dyn (val_pp, int s))) +| _ -> assert false + +let prm_message_of_string : ml_tactic = function +| [ValStr s] -> return (ValExt (Val.Dyn (val_pp, str s))) +| _ -> assert false + +let prm_array_make : ml_tactic = function +| [ValInt n; x] -> wrap (fun () -> ValBlk (0, Array.make n x)) +| _ -> assert false + +let prm_array_length : ml_tactic = function +| [ValBlk (_, v)] -> return (ValInt (Array.length v)) +| _ -> assert false + +let prm_array_set : ml_tactic = function +| [ValBlk (_, v); ValInt n; x] -> wrap_unit (fun () -> v.(n) <- x) +| _ -> assert false + +let prm_array_get : ml_tactic = function +| [ValBlk (_, v); ValInt n] -> wrap (fun () -> v.(n)) +| _ -> assert false + +(** Registering *) + +let () = Tac2env.define_primitive (pname "print") prm_print +let () = Tac2env.define_primitive (pname "message_of_string") prm_message_of_string +let () = Tac2env.define_primitive (pname "message_of_int") prm_message_of_int + +let () = Tac2env.define_primitive (pname "array_make") prm_array_make +let () = Tac2env.define_primitive (pname "array_length") prm_array_length +let () = Tac2env.define_primitive (pname "array_get") prm_array_get +let () = Tac2env.define_primitive (pname "array_set") prm_array_set diff --git a/tac2core.mli b/tac2core.mli new file mode 100644 index 0000000000..14bde483c1 --- /dev/null +++ b/tac2core.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr +val to_unit : valexpr -> unit + +val of_list : valexpr list -> valexpr +val to_list : valexpr -> valexpr list + +end diff --git a/tac2entries.ml b/tac2entries.ml new file mode 100644 index 0000000000..7572270ab3 --- /dev/null +++ b/tac2entries.ml @@ -0,0 +1,321 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object {(default_object "TAC2-DEFINITION") with + cache_function = cache_tacdef; + load_function = load_tacdef; + open_function = open_tacdef; + subst_function = subst_tacdef; + classify_function = classify_tacdef} + +type typdef = { + typdef_local : bool; + typdef_expr : glb_quant_typedef; +} + +let change_kn_label kn id = + let (mp, dp, _) = KerName.repr kn in + KerName.make mp dp (Label.of_id id) + +let change_sp_label sp id = + let (dp, _) = Libnames.repr_path sp in + Libnames.make_path dp id + +let push_typedef visibility sp kn (_, def) = match def with +| GTydDef _ -> + Tac2env.push_type visibility sp kn +| GTydAlg cstrs -> + (** Register constructors *) + let iter (c, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_ltac visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter cstrs +| GTydRec _ -> + assert false (** FIXME *) + +let next i = + let ans = !i in + let () = incr i in + ans + +let dummy_var i = Id.of_string (Printf.sprintf "_%i" i) + +let define_typedef kn (params, def as qdef) = match def with +| GTydDef _ -> + Tac2env.define_type kn qdef +| GTydAlg cstrs -> + (** Define constructors *) + let constant = ref 0 in + let nonconstant = ref 0 in + let iter (c, args) = + let knc = change_kn_label kn c in + let tag = if List.is_empty args then next constant else next nonconstant in + let ids = List.mapi (fun i _ -> dummy_var i) args in + let c = GTacCst (kn, tag, List.map (fun id -> GTacVar id) ids) in + let c = + if List.is_empty args then c + else GTacFun (List.map (fun id -> Name id) ids, c) + in + let fold arg tpe = GTypArrow (arg, tpe) in + let cT = GTypRef (kn, List.init params (fun i -> GTypVar i)) in + let cT = List.fold_right fold args cT in + let data = { + Tac2env.cdata_type = kn; + cdata_args = params, args; + cdata_indx = tag; + } in + Tac2env.define_constructor knc data; + Tac2env.define_global knc (c, (params, cT)) + in + Tac2env.define_type kn qdef; + List.iter iter cstrs +| GTydRec _ -> + assert false (** FIXME *) + +let perform_typdef vs ((sp, kn), def) = + let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let load_typdef i obj = perform_typdef (Until i) obj +let open_typdef i obj = perform_typdef (Exactly i) obj + +let cache_typdef ((sp, kn), def) = + let () = push_typedef (Until 1) sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let subst_typdef (subst, def) = + let expr' = subst_quant_typedef subst def.typdef_expr in + if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } + +let classify_typdef o = Substitute o + +let inTypDef : typdef -> obj = + declare_object {(default_object "TAC2-TYPE-DEFINITION") with + cache_function = cache_typdef; + load_function = load_typdef; + open_function = open_typdef; + subst_function = subst_typdef; + classify_function = classify_typdef} + +let register_ltac ?(local = false) isrec tactics = + if isrec then + let map (na, e) = (na, None, e) in + let bindings = List.map map tactics in + let map ((loc, na), e) = match na with + | Anonymous -> None + | Name id -> + let qid = Libnames.qualid_of_ident id in + let e = CTacLet (Loc.ghost, true, bindings, CTacRef (loc, qid)) in + let (e, t) = intern e in + let e = match e with + | GTacLet (true, _, e) -> assert false + | _ -> assert false + in + Some (e, t) + in + let tactics = List.map map tactics in + assert false (** FIXME *) + else + let map ((loc, na), e) = + let (e, t) = intern e in + let () = + if not (is_value e) then + user_err ~loc (str "Tactic definition must be a syntactical value") + in + let id = match na with + | Anonymous -> + user_err ~loc (str "Tactic definition must have a name") + | Name id -> id + in + let kn = Lib.make_kn id in + let exists = + try let _ = Tac2env.interp_global kn in true with Not_found -> false + in + let () = + if exists then + user_err ~loc (str "Tactic " ++ Nameops.pr_id id ++ str " already exists") + in + (id, e, t) + in + let defs = List.map map tactics in + let iter (id, e, t) = + let def = { + tacdef_local = local; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + in + List.iter iter defs + +let register_type ?(local = false) isrec types = + let same_name ((_, id1), _) ((_, id2), _) = Id.equal id1 id2 in + let () = match List.duplicates same_name types with + | [] -> () + | ((loc, id), _) :: _ -> + user_err ~loc (str "Multiple definition of the type name " ++ Id.print id) + in + let check ((loc, id), (params, def)) = + let same_name (_, id1) (_, id2) = Id.equal id1 id2 in + let () = match List.duplicates same_name params with + | [] -> () + | (loc, id) :: _ -> + user_err ~loc (str "The type parameter " ++ Id.print id ++ + str " occurs several times") + in + match def with + | CTydDef _ -> + if isrec then + user_err ~loc (str "The type abbreviation " ++ Id.print id ++ + str " cannot be recursive") + | CTydAlg _ -> () (** FIXME *) + | CTydRec _ -> assert false (** FIXME *) + in + let () = List.iter check types in + let self = + if isrec then + let fold accu ((_, id), (params, _)) = + Id.Map.add id (Lib.make_kn id, List.length params) accu + in + List.fold_left fold Id.Map.empty types + else Id.Map.empty + in + let map ((_, id), def) = + let typdef = { + typdef_local = local; + typdef_expr = intern_typedef self def; + } in + (id, typdef) + in + let types = List.map map types in + let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in + List.iter iter types + +let register_primitive ?(local = false) (loc, id) t ml = + let t = intern_open_type t in + let rec count_arrow = function + | GTypArrow (_, t) -> 1 + count_arrow t + | _ -> 0 + in + let arrows = count_arrow (snd t) in + let () = if Int.equal arrows 0 then + user_err ~loc (str "External tactic must have at least one argument") in + let () = + try let _ = Tac2env.interp_primitive ml in () with Not_found -> + user_err ~loc (str "Unregistered primitive " ++ + quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) + in + let init i = Id.of_string (Printf.sprintf "x%i" i) in + let names = List.init arrows init in + let bnd = List.map (fun id -> Name id) names in + let arg = List.map (fun id -> GTacVar id) names in + let e = GTacFun (bnd, GTacPrm (ml, arg)) in + let def = { + tacdef_local = local; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + +let register_struct ?local str = match str with +| StrVal (isrec, e) -> register_ltac ?local isrec e +| StrTyp (isrec, t) -> register_type ?local isrec t +| StrPrm (id, t, ml) -> register_primitive ?local id t ml + +(** Printing *) + +let print_ltac ref = + let (loc, qid) = qualid_of_reference ref in + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ~loc (str "Unknown tactic " ++ pr_qualid qid) + in + let (_, (_, t)) = Tac2env.interp_global kn in + Feedback.msg_notice (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype t) + +(** Calling tactics *) + +let solve default tac = + let status = Proof_global.with_current_proof begin fun etac p -> + let with_end_tac = if default then Some etac else None in + let (p, status) = Pfedit.solve SelectAll None tac ?with_end_tac p in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p, status + end in + if not status then Feedback.feedback Feedback.AddedAxiom + +let call ~default e = + let loc = loc_of_tacexpr e in + let (e, (_, t)) = intern e in + let () = check_unit ~loc t in + let tac = Tac2interp.interp Id.Map.empty e in + solve default (Proofview.tclIGNORE tac) + +(** Primitive algebraic types than can't be defined Coq-side *) + +let register_prim_alg name params def = + let id = Id.of_string name in + let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in + let def = (params, GTydAlg def) in + let def = { typdef_local = false; typdef_expr = def } in + ignore (Lib.add_leaf id (inTypDef def)) + +let coq_prefix = DirPath.make (List.map Id.of_string ["Ltac2"; "ltac2"; "Coq"]) +let coq_def n = KerName.make2 (MPfile coq_prefix) (Label.make n) + +let t_list = coq_def "list" + +let _ = Mltop.declare_cache_obj begin fun () -> + register_prim_alg "unit" 0 ["()", []]; + register_prim_alg "list" 1 [ + ("[]", []); + ("::", [GTypVar 0; GTypRef (t_list, [GTypVar 0])]); + ]; +end "ltac2_plugin" diff --git a/tac2entries.mli b/tac2entries.mli new file mode 100644 index 0000000000..9c5d0a15fd --- /dev/null +++ b/tac2entries.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* rec_flag -> + (Name.t located * raw_tacexpr) list -> unit + +val register_type : ?local:bool -> rec_flag -> + (Id.t located * raw_quant_typedef) list -> unit + +val register_primitive : ?local:bool -> + Id.t located -> raw_typexpr -> ml_tactic_name -> unit + +val register_struct : ?local:bool -> strexpr -> unit + +(** {5 Inspecting} *) + +val print_ltac : Libnames.reference -> unit + +(** {5 Eval loop} *) + +(** Evaluate a tactic expression in the current environment *) +val call : default:bool -> raw_tacexpr -> unit diff --git a/tac2env.ml b/tac2env.ml new file mode 100644 index 0000000000..d17e657516 --- /dev/null +++ b/tac2env.ml @@ -0,0 +1,139 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ValInt n +| GTacRef kn -> + let (e, _) = + try KNmap.find kn ltac_state.contents.ltac_tactics + with Not_found -> assert false + in + eval_pure e +| GTacFun (na, e) -> + ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e } +| GTacTup el -> ValBlk (0, Array.map_of_list eval_pure el) +| GTacCst (_, n, []) -> ValInt n +| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) +| GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ +| GTacApp _ | GTacCse _ | GTacPrm _ -> + anomaly (Pp.str "Term is not a syntactical value") + +let define_global kn e = + let state = !ltac_state in + ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } + +let interp_global kn = + let (e, t) = KNmap.find kn ltac_state.contents.ltac_tactics in + (eval_pure e, t) + +let define_constructor kn t = + let state = !ltac_state in + ltac_state := { state with ltac_constructors = KNmap.add kn t state.ltac_constructors } + +let interp_constructor kn = KNmap.find kn ltac_state.contents.ltac_constructors + +let define_type kn e = + let state = !ltac_state in + ltac_state := { state with ltac_types = KNmap.add kn e state.ltac_types } + +let interp_type kn = KNmap.find kn ltac_state.contents.ltac_types + +module ML = +struct + type t = ml_tactic_name + let compare n1 n2 = + let c = String.compare n1.mltac_plugin n2.mltac_plugin in + if Int.equal c 0 then String.compare n1.mltac_tactic n2.mltac_tactic + else c +end + +module MLMap = Map.Make(ML) + +let primitive_map = ref MLMap.empty + +let define_primitive name f = primitive_map := MLMap.add name f !primitive_map +let interp_primitive name = MLMap.find name !primitive_map + +(** Name management *) + +module FullPath = +struct + type t = full_path + let equal = eq_full_path + let to_string = string_of_path + let repr sp = + let dir,id = repr_path sp in + id, (DirPath.repr dir) +end + +module KnTab = Nametab.Make(FullPath)(KerName) + +type nametab = { + tab_ltac : KnTab.t; + tab_type : KnTab.t; +} + +let empty_nametab = { tab_ltac = KnTab.empty; tab_type = KnTab.empty } + +let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" + +let push_ltac vis sp kn = + let tab = !nametab in + nametab := { tab with tab_ltac = KnTab.push vis sp kn tab.tab_ltac } + +let locate_ltac qid = + let tab = !nametab in + KnTab.locate qid tab.tab_ltac + +let locate_extended_all_ltac qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_ltac + +let push_type vis sp kn = + let tab = !nametab in + nametab := { tab with tab_type = KnTab.push vis sp kn tab.tab_type } + +let locate_type qid = + let tab = !nametab in + KnTab.locate qid tab.tab_type + +let locate_extended_all_type qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_type diff --git a/tac2env.mli b/tac2env.mli new file mode 100644 index 0000000000..efabdb5466 --- /dev/null +++ b/tac2env.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (glb_tacexpr * type_scheme) -> unit +val interp_global : ltac_constant -> (valexpr * type_scheme) + +(** {5 Toplevel definition of types} *) + +val define_type : type_constant -> glb_quant_typedef -> unit +val interp_type : type_constant -> glb_quant_typedef + +(** {5 Toplevel definition of algebraic constructors} *) + +type constructor_data = { + cdata_type : type_constant; + cdata_args : int * int glb_typexpr list; + cdata_indx : int; +} + +val define_constructor : ltac_constructor -> constructor_data -> unit +val interp_constructor : ltac_constructor -> constructor_data + +(** {5 Name management} *) + +val push_ltac : visibility -> full_path -> ltac_constant -> unit +val locate_ltac : qualid -> ltac_constant +val locate_extended_all_ltac : qualid -> ltac_constant list + +val push_type : visibility -> full_path -> type_constant -> unit +val locate_type : qualid -> type_constant +val locate_extended_all_type : qualid -> type_constant list + +(** {5 Toplevel definitions of ML tactics} *) + +(** This state is not part of the summary, contrarily to the ones above. It is + intended to be used from ML plugins to register ML-side functions. *) + +val define_primitive : ml_tactic_name -> ml_tactic -> unit +val interp_primitive : ml_tactic_name -> ml_tactic diff --git a/tac2expr.mli b/tac2expr.mli new file mode 100644 index 0000000000..445c69aa23 --- /dev/null +++ b/tac2expr.mli @@ -0,0 +1,136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr Proofview.tactic diff --git a/tac2intern.ml b/tac2intern.ml new file mode 100644 index 0000000000..b1b35b0787 --- /dev/null +++ b/tac2intern.ml @@ -0,0 +1,921 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* elt -> bool +val create : unit -> 'a t +val fresh : 'a t -> elt +val size : 'a t -> int +val find : elt -> 'a t -> (elt * 'a option) +val union : elt -> elt -> 'a t -> unit +val set : elt -> 'a -> 'a t -> unit +module Map : +sig + type key = elt + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a +end +end += +struct +type elt = int +let equal = Int.equal +module Map = Int.Map + +type 'a node = +| Canon of int * 'a option +| Equiv of elt + +type 'a t = { + mutable uf_data : 'a node array; + mutable uf_size : int; +} + +let size p = p.uf_size + +let resize p = + if Int.equal (Array.length p.uf_data) p.uf_size then begin + let nsize = 2 * p.uf_size + 1 in + let v = Array.make nsize (Equiv 0) in + Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); + p.uf_data <- v; + end + +let create () = { uf_data = [||]; uf_size = 0 } + +let fresh p = + resize p; + let n = p.uf_size in + p.uf_data.(n) <- (Canon (1, None)); + p.uf_size <- n + 1; + n + +let rec lookup n p = + let node = Array.get p.uf_data n in + match node with + | Canon (size, v) -> n, size, v + | Equiv y -> + let ((z, _, _) as res) = lookup y p in + if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); + res + +let find n p = + let (x, _, v) = lookup n p in (x, v) + +let union x y p = + let ((x, size1, _) as xcan) = lookup x p in + let ((y, size2, _) as ycan) = lookup y p in + let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in + let x, _, xnode = xcan in + let y, _, ynode = ycan in + assert (Option.is_empty xnode); + assert (Option.is_empty ynode); + p.uf_data.(x) <- Equiv y; + p.uf_data.(y) <- Canon (size1 + size2, None) + +let set x v p = + let (x, s, v') = lookup x p in + assert (Option.is_empty v'); + p.uf_data.(x) <- Canon (s, Some v) + +end + +type mix_var = +| GVar of UF.elt +| LVar of int + +type mix_type_scheme = int * mix_var glb_typexpr + +type environment = { + env_var : mix_type_scheme Id.Map.t; + (** Type schemes of bound variables *) + env_cst : UF.elt glb_typexpr UF.t; + (** Unification state *) + env_als : UF.elt Id.Map.t ref; + (** Map user-facing type variables to unification variables *) + env_opn : bool; + (** Accept unbound type variables *) + env_rec : (KerName.t * int) Id.Map.t; + (** Recursive type definitions *) +} + +let empty_env () = { + env_var = Id.Map.empty; + env_cst = UF.create (); + env_als = ref Id.Map.empty; + env_opn = true; + env_rec = Id.Map.empty; +} + +let fresh_id env = UF.fresh env.env_cst + +let get_alias (loc, id) env = + try Id.Map.find id env.env_als.contents + with Not_found -> + if env.env_opn then + let n = fresh_id env in + let () = env.env_als := Id.Map.add id n env.env_als.contents in + n + else user_err ~loc (str "Unbound type parameter " ++ Id.print id) + +let push_name id t env = match id with +| Anonymous -> env +| Name id -> { env with env_var = Id.Map.add id t env.env_var } + +let loc_of_tacexpr = function +| CTacAtm (loc, _) -> loc +| CTacRef (loc, _) -> loc +| CTacFun (loc, _, _) -> loc +| CTacApp (loc, _, _) -> loc +| CTacLet (loc, _, _, _) -> loc +| CTacTup (loc, _) -> loc +| CTacArr (loc, _) -> loc +| CTacLst (loc, _) -> loc +| CTacCnv (loc, _, _) -> loc +| CTacSeq (loc, _, _) -> loc +| CTacCse (loc, _, _) -> loc + +let loc_of_patexpr = function +| CPatAny loc -> loc +| CPatRef (loc, _, _) -> loc +| CPatTup (loc, _) -> loc + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst id +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypTuple tl -> GTypTuple (List.map (fun t -> subst_type subst t) tl) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (loc, Name id) -> GTypVar (get_alias (loc, id) env) +| CTypVar (_, Anonymous) -> GTypVar (fresh_id env) +| CTypRef (_, (loc, qid), args) -> + let (dp, id) = repr_qualid qid in + let (kn, nparams) = + if DirPath.is_empty dp && Id.Map.mem id env.env_rec then + Id.Map.find id env.env_rec + else + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ~loc (str "Unbound type constructor " ++ pr_qualid qid) + in + let (nparams, _) = Tac2env.interp_type kn in + (kn, nparams) + in + let nargs = List.length args in + let () = + if not (Int.equal nparams nargs) then + user_err ~loc (strbrk "The type constructor " ++ pr_qualid qid ++ + strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ + applied to " ++ int nargs ++ strbrk "argument(s)") + in + GTypRef (kn, List.map (fun t -> intern_type env t) args) +| CTypArrow (loc, t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) +| CTypTuple (loc, tl) -> GTypTuple (List.map (fun t -> intern_type env t) tl) + +let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + subst_type substf t + +let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf = function + | LVar i -> GTypVar subst.(i) + | GVar n -> GTypVar n + in + subst_type substf t + +let fresh_reftype env (kn : KerName.t) = + let (n, _) = Tac2env.interp_type kn in + let subst = Array.init n (fun _ -> fresh_id env) in + let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in + (subst, t) + +(** First-order unification algorithm *) + +let is_unfoldable kn = match snd (Tac2env.interp_type kn) with +| GTydDef (Some _) -> true +| GTydDef None | GTydAlg _ | GTydRec _ -> false + +let unfold env kn args = + let (nparams, def) = Tac2env.interp_type kn in + let def = match def with + | GTydDef (Some t) -> t + | _ -> assert false + in + let args = Array.of_list args in + let subst n = args.(n) in + subst_type subst def + +(** View function, allows to ensure head normal forms *) +let rec kind env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> kind env t + end +| GTypRef (kn, tl) -> + if is_unfoldable kn then kind env (unfold env kn tl) else t +| GTypArrow _ | GTypTuple _ -> t + +exception Occur + +let rec occur_check env id t = match kind env t with +| GTypVar id' -> if UF.equal id id' then raise Occur +| GTypArrow (t1, t2) -> + let () = occur_check env id t1 in + occur_check env id t2 +| GTypTuple tl -> + List.iter (fun t -> occur_check env id t) tl +| GTypRef (kn, tl) -> + List.iter (fun t -> occur_check env id t) tl + +exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr + +let unify_var env id t = match kind env t with +| GTypVar id' -> + if not (UF.equal id id') then UF.union id id' env.env_cst +| GTypArrow _ | GTypRef _ | GTypTuple _ -> + try + let () = occur_check env id t in + UF.set id t env.env_cst + with Occur -> raise (CannotUnify (GTypVar id, t)) + +let rec unify env t1 t2 = match kind env t1, kind env t2 with +| GTypVar id, t | t, GTypVar id -> + unify_var env id t +| GTypArrow (t1, u1), GTypArrow (t2, u2) -> + let () = unify env t1 t2 in + unify env u1 u2 +| GTypTuple tl1, GTypTuple tl2 -> + if Int.equal (List.length tl1) (List.length tl2) then + List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> + if KerName.equal kn1 kn2 then + List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| _ -> raise (CannotUnify (t1, t2)) + +(** FIXME *) +let rec pr_glbtype = function +| GTypVar n -> str "?" +| GTypRef (kn, tl) -> + KerName.print kn ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_glbtype tl ++ str ")" +| GTypArrow (t1, t2) -> str "Arr(" ++ pr_glbtype t1 ++ str ", " ++ pr_glbtype t2 ++ str ")" +| GTypTuple tl -> str "Tup(" ++ prlist_with_sep (fun () -> str ", ") pr_glbtype tl ++ str ")" + +let unify loc env t1 t2 = + try unify env t1 t2 + with CannotUnify (u1, u2) -> + user_err ~loc (str "This expression has type " ++ pr_glbtype t1 ++ + str " but an expression what expected of type " ++ pr_glbtype t2) + +(** Term typing *) + +let rec is_value = function +| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true +| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false +| GTacTup el -> List.for_all is_value el +| GTacCst (_, _, []) -> true +| GTacCst (kn, n, el) -> + (** To be a value, a constructor must be immutable *) + assert false (** TODO *) +| GTacArr _ | GTacCse _ | GTacPrm _ -> false + +let is_rec_rhs = function +| GTacFun _ -> true +| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ -> false +| GTacTup _ | GTacArr _ | GTacPrm _ | GTacCst _ | GTacCse _ -> false + +let rec fv_type f t accu = match t with +| GTypVar id -> f id accu +| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) +| GTypTuple tl -> List.fold_left (fun accu t -> fv_type f t accu) accu tl +| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl + +let fv_env env = + let rec f id accu = match UF.find id env.env_cst with + | id, None -> UF.Map.add id () accu + | _, Some t -> fv_type f t accu + in + let fold_var id (_, t) accu = + let fmix id accu = match id with + | LVar _ -> accu + | GVar id -> f id accu + in + fv_type fmix t accu + in + let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in + let fold_als _ id accu = f id accu in + Id.Map.fold fold_als !(env.env_als) fv_var + +let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = + let fv = fv_env env in + let count = ref 0 in + let vars = ref UF.Map.empty in + let rec subst id = + let (id, t) = UF.find id env.env_cst in + match t with + | None -> + if UF.Map.mem id fv then GTypVar (GVar id) + else + begin try UF.Map.find id !vars + with Not_found -> + let n = !count in + let var = GTypVar (LVar n) in + let () = incr count in + let () = vars := UF.Map.add id var !vars in + var + end + | Some t -> subst_type subst t + in + let t = subst_type subst t in + (!count, t) + +let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = + let subst id = GTypVar (GVar id) in + (0, subst_type subst t) + +let warn_not_unit = + CWarnings.create ~name:"not-unit" ~category:"ltac" + (fun () -> strbrk "The following expression should have type unit.") + +let warn_redundant_clause = + CWarnings.create ~name:"redundant-clause" ~category:"ltac" + (fun () -> strbrk "The following clause is redundant.") + +let check_elt_unit loc env t = + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ | GTypTuple _ -> false + | GTypRef (kn, _) -> KerName.equal kn t_unit + in + if not maybe_unit then warn_not_unit ~loc () + +let check_elt_empty loc env t = match kind env t with +| GTypVar _ -> + user_err ~loc (str "Cannot infer an empty type for this expression") +| GTypArrow _ | GTypTuple _ -> + user_err ~loc (str "Type " ++ pr_glbtype t ++ str " is not an empty type") +| GTypRef (kn, _) -> + let def = Tac2env.interp_type kn in + match def with + | _, GTydAlg [] -> kn + | _ -> + user_err ~loc (str "Type " ++ pr_glbtype t ++ str " is not an empty type") + +let check_unit ?loc t = + let maybe_unit = match t with + | GTypVar _ -> true + | GTypArrow _ | GTypTuple _ -> false + | GTypRef (kn, _) -> KerName.equal kn t_unit + in + if not maybe_unit then warn_not_unit ?loc () + +let check_redundant_clause = function +| [] -> () +| (p, _) :: _ -> warn_redundant_clause ~loc:(loc_of_patexpr p) () + +let get_variable env (loc, qid) = + let (dp, id) = repr_qualid qid in + if DirPath.is_empty dp && Id.Map.mem id env.env_var then ArgVar (loc, id) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> + CErrors.user_err ~loc (str "Unbound value " ++ pr_qualid qid) + in + ArgArg kn + +let get_constructor env (loc, qid) = + let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in + match c with + | Some knc -> + let kn = + try Tac2env.interp_constructor knc + with Not_found -> + CErrors.user_err ~loc (str "The term " ++ pr_qualid qid ++ + str " is not the constructor of an inductive type.") in + ArgArg (kn, knc) + | None -> + let (dp, id) = repr_qualid qid in + if DirPath.is_empty dp then ArgVar (loc, id) + else CErrors.user_err ~loc (str "Unbound constructor " ++ pr_qualid qid) + +let intern_atm env = function +| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (t_int, [])) +| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (t_string, [])) + +let invalid_pattern ~loc kn t = + let pt = match t with + | GCaseAlg kn' -> KerName.print kn + | GCaseTuple n -> str "tuple" + in + user_err ~loc (str "Invalid pattern, expected a pattern for type " ++ + KerName.print kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) + +type pattern_kind = +| PKind_empty +| PKind_variant of KerName.t +| PKind_tuple of int +| PKind_any + +let get_pattern_kind env pl = match pl with +| [] -> PKind_empty +| p :: pl -> + let rec get_kind p pl = match fst p with + | CPatAny _ -> + begin match pl with + | [] -> PKind_any + | p :: pl -> get_kind p pl + end + | CPatRef (_, qid, []) -> + begin match get_constructor env qid with + | ArgVar _ -> + begin match pl with + | [] -> PKind_any + | p :: pl -> get_kind p pl + end + | ArgArg (data, _) -> PKind_variant data.cdata_type + end + | CPatRef (_, qid, _ :: _) -> + begin match get_constructor env qid with + | ArgVar (loc, _) -> + user_err ~loc (str "Unbound constructor " ++ pr_qualid (snd qid)) + | ArgArg (data, _) -> PKind_variant data.cdata_type + end + | CPatTup (_, tp) -> PKind_tuple (List.length tp) + in + get_kind p pl + +let rec intern_rec env = function +| CTacAtm (_, atm) -> intern_atm env atm +| CTacRef qid -> + begin match get_variable env qid with + | ArgVar (_, id) -> + let sch = Id.Map.find id env.env_var in + (GTacVar id, fresh_mix_type_scheme env sch) + | ArgArg kn -> + let (_, sch) = Tac2env.interp_global kn in + (GTacRef kn, fresh_type_scheme env sch) + end +| CTacFun (loc, bnd, e) -> + let fold (env, bnd, tl) ((_, na), t) = + let t = match t with + | None -> GTypVar (fresh_id env) + | Some t -> intern_type env t + in + let env = push_name na (monomorphic t) env in + (env, na :: bnd, t :: tl) + in + let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in + let (e, t) = intern_rec env e in + let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in + (GTacFun (bnd, e), t) +| CTacApp (loc, f, args) -> + let (f, ft) = intern_rec env f in + let fold arg (args, t) = + let (arg, argt) = intern_rec env arg in + (arg :: args, GTypArrow (argt, t)) + in + let ret = GTypVar (fresh_id env) in + let (args, t) = List.fold_right fold args ([], ret) in + let () = unify loc env ft t in + (GTacApp (f, args), ret) +| CTacLet (loc, false, el, e) -> + let fold accu ((loc, na), _, _) = match na with + | Anonymous -> accu + | Name id -> + if Id.Set.mem id accu then + user_err ~loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + else Id.Set.add id accu + in + let _ = List.fold_left fold Id.Set.empty el in + let fold ((loc, na), tc, e) (el, p) = + let (e, t) = intern_rec env e in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify loc env t tc + in + let t = if is_value e then abstract_var env t else monomorphic t in + ((na, e) :: el), ((na, t) :: p) + in + let (el, p) = List.fold_right fold el ([], []) in + let nenv = List.fold_left (fun accu (na, t) -> push_name na t env) env p in + let (e, t) = intern_rec nenv e in + (GTacLet (false, el, e), t) +| CTacLet (loc, true, el, e) -> + intern_let_rec env loc el e +| CTacTup (loc, []) -> + (GTacTup [], GTypRef (t_unit, [])) +| CTacTup (loc, el) -> + let fold e (el, tl) = + let (e, t) = intern_rec env e in + (e :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + (GTacTup el, GTypTuple tl) +| CTacArr (loc, []) -> + let id = fresh_id env in + (GTacArr [], GTypRef (t_int, [GTypVar id])) +| CTacArr (loc, e0 :: el) -> + let (e0, t0) = intern_rec env e0 in + let fold e el = + let loc = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let () = unify loc env t t0 in + e :: el + in + let el = e0 :: List.fold_right fold el [] in + (GTacArr el, GTypRef (t_array, [t0])) +| CTacLst (loc, []) -> + let id = fresh_id env in + (c_nil, GTypRef (t_list, [GTypVar id])) +| CTacLst (loc, e0 :: el) -> + let (e0, t0) = intern_rec env e0 in + let fold e el = + let loc = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let () = unify loc env t t0 in + c_cons e el + in + let el = c_cons e0 (List.fold_right fold el c_nil) in + (el, GTypRef (t_list, [t0])) +| CTacCnv (loc, e, tc) -> + let (e, t) = intern_rec env e in + let tc = intern_type env tc in + let () = unify loc env t tc in + (e, tc) +| CTacSeq (loc, e1, e2) -> + let (e1, t1) = intern_rec env e1 in + let (e2, t2) = intern_rec env e2 in + let () = check_elt_unit loc env t1 in + (GTacLet (false, [Anonymous, e1], e2), t2) +| CTacCse (loc, e, pl) -> + intern_case env loc e pl + +and intern_let_rec env loc el e = + let fold accu ((loc, na), _, _) = match na with + | Anonymous -> accu + | Name id -> + if Id.Set.mem id accu then + user_err ~loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + else Id.Set.add id accu + in + let _ = List.fold_left fold Id.Set.empty el in + let map env ((loc, na), t, e) = + let id = fresh_id env in + let env = push_name na (monomorphic (GTypVar id)) env in + (env, (loc, na, t, e, id)) + in + let (env, el) = List.fold_map map env el in + let fold (loc, na, tc, e, id) (el, tl) = + let loc_e = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let () = + if not (is_rec_rhs e) then + user_err ~loc:loc_e (str "This kind of expression is not allowed as \ + right-hand side of a recursive binding") + in + let () = unify loc env t (GTypVar id) in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify loc env t tc + in + ((na, e) :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + let (e, t) = intern_rec env e in + (GTacLet (true, el, e), t) + +(** For now, patterns recognized by the pattern-matching compiling are limited + to depth-one where leaves are either variables or catch-all *) +and intern_case env loc e pl = + let (e', t) = intern_rec env e in + let todo ~loc () = user_err ~loc (str "Pattern not handled yet") in + match get_pattern_kind env pl with + | PKind_any -> + let (pat, b) = List.hd pl in + let na = match pat with + | CPatAny _ -> Anonymous + | CPatRef (_, (_, qid), _) -> Name (snd (repr_qualid qid)) + | _ -> assert false + in + let () = check_redundant_clause (List.tl pl) in + let env = push_name na (monomorphic t) env in + let (b, tb) = intern_rec env b in + (GTacLet (false, [na, e'], b), tb) + | PKind_empty -> + let kn = check_elt_empty loc env t in + let r = fresh_id env in + (GTacCse (e', GCaseAlg kn, [||], [||]), GTypVar r) + | PKind_tuple len -> + begin match pl with + | [] -> assert false + | [CPatTup (_, []), b] -> + let () = unify (loc_of_tacexpr e) env t (GTypRef (t_unit, [])) in + let (b, tb) = intern_rec env b in + (GTacCse (e', GCaseAlg t_unit, [|b|], [||]), tb) + | [CPatTup (_, pl), b] -> + let map = function + | CPatAny _ -> Anonymous + | CPatRef (loc, qid, []) -> + begin match get_constructor env qid with + | ArgVar (_, id) -> Name id + | ArgArg _ -> todo ~loc () + end + | p -> todo ~loc:(loc_of_patexpr p) () + in + let ids = Array.map_of_list map pl in + let tc = GTypTuple (List.map (fun _ -> GTypVar (fresh_id env)) pl) in + let () = unify (loc_of_tacexpr e) env t tc in + let (b, tb) = intern_rec env b in + (GTacCse (e', GCaseTuple len, [||], [|ids, b|]), tb) + | (p, _) :: _ -> todo ~loc:(loc_of_patexpr p) () + end + | PKind_variant kn -> + let subst, tc = fresh_reftype env kn in + let () = unify (loc_of_tacexpr e) env t tc in + let (params, def) = Tac2env.interp_type kn in + let cstrs = match def with + | GTydAlg c -> c + | _ -> assert false + in + let count (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left count (0, 0) cstrs in + let const = Array.make nconst None in + let nonconst = Array.make nnonconst None in + let ret = GTypVar (fresh_id env) in + let rec intern_branch = function + | [] -> () + | (pat, br) :: rem -> + let tbr = match pat with + | CPatAny _ -> + let () = check_redundant_clause rem in + let (br', brT) = intern_rec env br in + (** Fill all remaining branches *) + let fill (ncst, narg) (_, args) = + if List.is_empty args then + let () = + if Option.is_empty const.(ncst) then const.(ncst) <- Some br' + in + (succ ncst, narg) + else + let () = + if Option.is_empty const.(narg) then + let ids = Array.map_of_list (fun _ -> Anonymous) args in + nonconst.(narg) <- Some (ids, br') + in + (ncst, succ narg) + in + let _ = List.fold_left fill (0, 0) cstrs in + brT + | CPatRef (loc, qid, args) -> + let data = match get_constructor env qid with + | ArgVar _ -> todo ~loc () + | ArgArg (data, _) -> + let () = + let kn' = data.cdata_type in + if not (KerName.equal kn kn') then + invalid_pattern ~loc kn (GCaseAlg kn') + in + data + in + let get_id = function + | CPatAny _ -> Anonymous + | CPatRef (loc, qid, []) -> + begin match get_constructor env qid with + | ArgVar (_, id) -> Name id + | ArgArg _ -> todo ~loc () + end + | p -> todo ~loc:(loc_of_patexpr p) () + in + let ids = List.map get_id args in + let nids = List.length ids in + let nargs = List.length (snd data.cdata_args) in + let () = + if not (Int.equal nids nargs) then + user_err ~loc (str "Constructor expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nids ++ + str " arguments") + in + let fold env id tpe = + (** Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids (snd data.cdata_args) in + let (br', brT) = intern_rec nenv br in + let () = + let index = data.cdata_indx in + if List.is_empty args then + if Option.is_empty const.(index) then const.(index) <- Some br' + else warn_redundant_clause ~loc () + else + let ids = Array.of_list ids in + if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') + else warn_redundant_clause ~loc () + in + brT + | CPatTup (loc, tup) -> + invalid_pattern ~loc kn (GCaseTuple (List.length tup)) + in + let () = unify (loc_of_tacexpr br) env ret tbr in + intern_branch rem + in + let () = intern_branch pl in + let map = function + | None -> user_err ~loc (str "Unhandled match case") (** FIXME *) + | Some x -> x + in + let const = Array.map map const in + let nonconst = Array.map map nonconst in + let ce = GTacCse (e', GCaseAlg kn, const, nonconst) in + (ce, ret) + +let normalize env (count, vars) (t : UF.elt glb_typexpr) = + let get_var id = + try UF.Map.find id !vars + with Not_found -> + let () = assert env.env_opn in + let n = GTypVar !count in + let () = incr count in + let () = vars := UF.Map.add id n !vars in + n + in + let rec subst id = match UF.find id env.env_cst with + | id, None -> get_var id + | _, Some t -> subst_type subst t + in + subst_type subst t + +let intern e = + let env = empty_env () in + let (e, t) = intern_rec env e in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (e, (!count, t)) + +let intern_typedef self (ids, t) : glb_quant_typedef = + let env = { (empty_env ()) with env_rec = self } in + (** Initialize type parameters *) + let map id = get_alias id env in + let ids = List.map map ids in + let count = ref (List.length ids) in + let vars = ref UF.Map.empty in + let iter n id = vars := UF.Map.add id (GTypVar n) !vars in + let () = List.iteri iter ids in + (** Do not accept unbound type variables *) + let env = { env with env_opn = false } in + let intern t = + let t = intern_type env t in + normalize env (count, vars) t + in + let count = !count in + match t with + | CTydDef None -> (count, GTydDef None) + | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) + | CTydAlg constrs -> + let map (c, t) = (c, List.map intern t) in + let constrs = List.map map constrs in + (count, GTydAlg constrs) + | CTydRec fields -> + let map (c, mut, t) = (c, mut, intern t) in + let fields = List.map map fields in + (count, GTydRec fields) + +let intern_open_type t = + let env = empty_env () in + let t = intern_type env t in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (!count, t) + +(** Kernel substitution *) + +open Mod_subst + +let rec subst_type subst t = match t with +| GTypVar _ -> t +| GTypArrow (t1, t2) -> + let t1' = subst_type subst t1 in + let t2' = subst_type subst t2 in + if t1' == t1 && t2' == t2 then t + else GTypArrow (t1', t2') +| GTypTuple tl -> + let tl'= List.smartmap (fun t -> subst_type subst t) tl in + if tl' == tl then t else GTypTuple tl' +| GTypRef (kn, tl) -> + let kn' = subst_kn subst kn in + let tl' = List.smartmap (fun t -> subst_type subst t) tl in + if kn' == kn && tl' == tl then t else GTypRef (kn', tl') + +let subst_case_info subst ci = match ci with +| GCaseAlg kn -> + let kn' = subst_kn subst kn in + if kn' == kn then ci else GCaseAlg kn' +| GCaseTuple _ -> ci + +let rec subst_expr subst e = match e with +| GTacAtm _ | GTacVar _ | GTacPrm _ -> e +| GTacRef kn -> GTacRef (subst_kn subst kn) +| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) +| GTacApp (f, args) -> + GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) +| GTacLet (r, bs, e) -> + let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in + GTacLet (r, bs, subst_expr subst e) +| GTacTup el -> + GTacTup (List.map (fun e -> subst_expr subst e) el) +| GTacArr el -> + GTacArr (List.map (fun e -> subst_expr subst e) el) +| GTacCst (kn, n, el) -> + GTacCst (subst_kn subst kn, n, List.map (fun e -> subst_expr subst e) el) +| GTacCse (e, ci, cse0, cse1) -> + let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in + let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in + let ci' = subst_case_info subst ci in + GTacCse (subst_expr subst e, ci', cse0', cse1') + +let subst_typedef subst e = match e with +| GTydDef t -> + let t' = Option.smartmap (fun t -> subst_type subst t) t in + if t' == t then e else GTydDef t' +| GTydAlg constrs -> + let map (c, tl as p) = + let tl' = List.smartmap (fun t -> subst_type subst t) tl in + if tl' == tl then p else (c, tl') + in + let constrs' = List.smartmap map constrs in + if constrs' == constrs then e else GTydAlg constrs' +| GTydRec fields -> + let map (c, mut, t as p) = + let t' = subst_type subst t in + if t' == t then p else (c, mut, t') + in + let fields' = List.smartmap map fields in + if fields' == fields then e else GTydRec fields' + +let subst_quant_typedef subst (prm, def as qdef) = + let def' = subst_typedef subst def in + if def' == def then qdef else (prm, def') + +let subst_type_scheme subst (prm, t as sch) = + let t' = subst_type subst t in + if t' == t then sch else (prm, t') diff --git a/tac2intern.mli b/tac2intern.mli new file mode 100644 index 0000000000..a6be01d647 --- /dev/null +++ b/tac2intern.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Loc.t + +val intern : raw_tacexpr -> glb_tacexpr * type_scheme +val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef +val intern_open_type : raw_typexpr -> type_scheme + +(** Check that a term is a value. Only values are safe to marshall between + processes. *) +val is_value : glb_tacexpr -> bool +val check_unit : ?loc:Loc.t -> int glb_typexpr -> unit + +val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr +val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr +val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef +val subst_type_scheme : substitution -> type_scheme -> type_scheme + +val pr_glbtype : 'a glb_typexpr -> Pp.std_ppcmds diff --git a/tac2interp.ml b/tac2interp.ml new file mode 100644 index 0000000000..221f107dc8 --- /dev/null +++ b/tac2interp.ml @@ -0,0 +1,108 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ist +| Name id -> Id.Map.add id v ist + +let get_var ist id = + try Id.Map.find id ist with Not_found -> + anomaly (str "Unbound variable " ++ Id.print id) + +let get_ref ist kn = + try fst (Tac2env.interp_global kn) with Not_found -> + anomaly (str "Unbound reference" ++ KerName.print kn) + +let return = Proofview.tclUNIT + +let rec interp ist = function +| GTacAtm (AtmInt n) -> return (ValInt n) +| GTacAtm (AtmStr s) -> return (ValStr s) +| GTacVar id -> return (get_var ist id) +| GTacRef qid -> return (get_ref ist qid) +| GTacFun (ids, e) -> + let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + return (ValCls cls) +| GTacApp (f, args) -> + interp ist f >>= fun f -> + Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> + interp_app ist f args +| GTacLet (false, el, e) -> + let fold accu (na, e) = + interp ist e >>= fun e -> + return (push_name accu na e) + in + Proofview.Monad.List.fold_left fold ist el >>= fun ist -> + interp ist e +| GTacLet (true, el, e) -> + let map (na, e) = match e with + | GTacFun (ids, e) -> + let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + na, cls + | _ -> anomaly (str "Ill-formed recursive function") + in + let fixs = List.map map el in + let fold accu (na, cls) = match na with + | Anonymous -> accu + | Name id -> Id.Map.add id (ValCls cls) accu + in + let ist = List.fold_left fold ist fixs in + (** Hack to make a cycle imperatively in the environment *) + let iter (_, e) = e.clos_env <- ist in + let () = List.iter iter fixs in + interp ist e +| GTacTup [] -> + return (ValInt 0) +| GTacTup el | GTacArr el -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (ValBlk (0, Array.of_list el)) +| GTacCst (_, n, []) -> return (ValInt n) +| GTacCst (_, n, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (ValBlk (n, Array.of_list el)) +| GTacCse (e, _, cse0, cse1) -> + interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacPrm (ml, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + Tac2env.interp_primitive ml el + +and interp_app ist f args = match f with +| ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> + let rec push ist ids args = match ids, args with + | [], [] -> interp ist e + | [], _ :: _ -> interp ist e >>= fun f -> interp_app ist f args + | _ :: _, [] -> + let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + return (ValCls cls) + | id :: ids, arg :: args -> push (push_name ist id arg) ids args + in + push ist ids args +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ -> + anomaly (str "Unexpected value shape") + +and interp_case ist e cse0 cse1 = match e with +| ValInt n -> interp ist cse0.(n) +| ValBlk (n, args) -> + let (ids, e) = cse1.(n) in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist e +| ValExt _ | ValStr _ | ValCls _ -> + anomaly (str "Unexpected value shape") diff --git a/tac2interp.mli b/tac2interp.mli new file mode 100644 index 0000000000..b11ee36012 --- /dev/null +++ b/tac2interp.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glb_tacexpr -> valexpr Proofview.tactic diff --git a/vo.itarget b/vo.itarget new file mode 100644 index 0000000000..776404ad79 --- /dev/null +++ b/vo.itarget @@ -0,0 +1 @@ +Ltac2.vo -- cgit v1.2.3 From 0c3c2459eae24cc8e87c7c6a4a4e6a1afd171d72 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 25 Oct 2016 15:11:41 +0200 Subject: Embedding generic arguments in Ltac2 AST. --- tac2env.ml | 19 ++++++++++++++++++- tac2env.mli | 10 ++++++++++ tac2expr.mli | 4 ++++ tac2intern.ml | 22 ++++++++++++++++++++-- tac2interp.ml | 4 ++++ 5 files changed, 56 insertions(+), 3 deletions(-) diff --git a/tac2env.ml b/tac2env.ml index d17e657516..3500b2ef3d 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -52,7 +52,7 @@ let rec eval_pure = function | GTacCst (_, n, []) -> ValInt n | GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) | GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ -| GTacApp _ | GTacCse _ | GTacPrm _ -> +| GTacApp _ | GTacCse _ | GTacPrm _ | GTacExt _ -> anomaly (Pp.str "Term is not a syntactical value") let define_global kn e = @@ -137,3 +137,20 @@ let locate_type qid = let locate_extended_all_type qid = let tab = !nametab in KnTab.find_prefixes qid tab.tab_type + +type 'a ml_object = { + ml_type : type_constant; + ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; +} + +module MLTypeObj = +struct + type ('a, 'b, 'c) obj = 'b ml_object + let name = "ltac2_ml_type" + let default _ = None +end + +module MLType = Genarg.Register(MLTypeObj) + +let define_ml_object t tpe = MLType.register0 t tpe +let interp_ml_object t = MLType.obj t diff --git a/tac2env.mli b/tac2env.mli index efabdb5466..eb471b9abf 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -56,3 +56,13 @@ val locate_extended_all_type : qualid -> type_constant list val define_primitive : ml_tactic_name -> ml_tactic -> unit val interp_primitive : ml_tactic_name -> ml_tactic + +(** {5 ML primitive types} *) + +type 'a ml_object = { + ml_type : type_constant; + ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; +} + +val define_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object -> unit +val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object diff --git a/tac2expr.mli b/tac2expr.mli index 445c69aa23..15c630ca87 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -76,6 +76,7 @@ type raw_tacexpr = | CTacCnv of Loc.t * raw_tacexpr * raw_typexpr | CTacSeq of Loc.t * raw_tacexpr * raw_tacexpr | CTacCse of Loc.t * raw_tacexpr * raw_taccase list +| CTacExt of Loc.t * raw_generic_argument and raw_taccase = raw_patexpr * raw_tacexpr @@ -94,6 +95,7 @@ type glb_tacexpr = | GTacArr of glb_tacexpr list | GTacCst of KerName.t * int * glb_tacexpr list | GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array +| GTacExt of glob_generic_argument | GTacPrm of ml_tactic_name * glb_tacexpr list (** Toplevel statements *) @@ -134,3 +136,5 @@ and closure = { } type ml_tactic = valexpr list -> valexpr Proofview.tactic + +type environment = valexpr Id.Map.t diff --git a/tac2intern.ml b/tac2intern.ml index b1b35b0787..516690dfd3 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -144,6 +144,9 @@ let empty_env () = { env_rec = Id.Map.empty; } +let ltac2_env : environment Genintern.Store.field = + Genintern.Store.field () + let fresh_id env = UF.fresh env.env_cst let get_alias (loc, id) env = @@ -171,6 +174,7 @@ let loc_of_tacexpr = function | CTacCnv (loc, _, _) -> loc | CTacSeq (loc, _, _) -> loc | CTacCse (loc, _, _) -> loc +| CTacExt (loc, _) -> loc let loc_of_patexpr = function | CPatAny loc -> loc @@ -324,12 +328,12 @@ let rec is_value = function | GTacCst (kn, n, el) -> (** To be a value, a constructor must be immutable *) assert false (** TODO *) -| GTacArr _ | GTacCse _ | GTacPrm _ -> false +| GTacArr _ | GTacCse _ | GTacExt _ | GTacPrm _ -> false let is_rec_rhs = function | GTacFun _ -> true | GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ -> false -| GTacTup _ | GTacArr _ | GTacPrm _ | GTacCst _ | GTacCse _ -> false +| GTacTup _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ | GTacCse _ -> false let rec fv_type f t accu = match t with | GTypVar id -> f id accu @@ -600,6 +604,17 @@ let rec intern_rec env = function (GTacLet (false, [Anonymous, e1], e2), t2) | CTacCse (loc, e, pl) -> intern_case env loc e pl +| CTacExt (loc, ext) -> + let open Genintern in + let GenArg (Rawwit tag, _) = ext in + let tpe = interp_ml_object tag in + (** External objects do not have access to the named context because this is + not stable by dynamic semantics. *) + let genv = Global.env_of_context Environ.empty_named_context_val in + let ist = empty_glob_sign genv in + let ist = { ist with extra = Store.set ist.extra ltac2_env env } in + let (_, ext) = generic_intern ist ext in + (GTacExt ext, GTypRef (tpe.ml_type, [])) and intern_let_rec env loc el e = let fold accu ((loc, na), _, _) = match na with @@ -892,6 +907,9 @@ let rec subst_expr subst e = match e with let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in let ci' = subst_case_info subst ci in GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacExt ext -> + let ext' = Genintern.generic_substitute subst ext in + if ext' == ext then e else GTacExt ext' let subst_typedef subst e = match e with | GTydDef t -> diff --git a/tac2interp.ml b/tac2interp.ml index 221f107dc8..b868caf963 100644 --- a/tac2interp.ml +++ b/tac2interp.ml @@ -83,6 +83,10 @@ let rec interp ist = function | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> Tac2env.interp_primitive ml el +| GTacExt e -> + let GenArg (Glbwit tag, e) = e in + let tpe = Tac2env.interp_ml_object tag in + tpe.Tac2env.ml_interp ist e >>= fun e -> return (ValExt e) and interp_app ist f args = match f with | ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> -- cgit v1.2.3 From 2dc3175916f3968d4cdba9af140fbc2667ff70a5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 2 Dec 2016 14:31:27 +0100 Subject: Allowing to include Coq terms in Ltac2 using the constr:(...) syntax. --- g_ltac2.ml4 | 4 ++++ tac2core.ml | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tac2intern.ml | 2 +- 3 files changed, 74 insertions(+), 1 deletion(-) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index 349220f9de..b613f22a8d 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -21,6 +21,9 @@ let tac2def_typ = Gram.entry_create "tactic:tac2def_typ" let tac2def_ext = Gram.entry_create "tactic:tac2def_ext" let tac2mode = Gram.entry_create "vernac:ltac2_command" +let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) +let inj_constr loc c = inj_wit Stdarg.wit_constr loc c + GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext; tac2pat: @@ -77,6 +80,7 @@ GEXTEND Gram [ [ n = Prim.integer -> CTacAtm (!@loc, AtmInt n) | s = Prim.string -> CTacAtm (!@loc, AtmStr s) | id = Prim.qualid -> CTacRef id + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c ] ] ; let_clause: diff --git a/tac2core.ml b/tac2core.ml index af4124e647..95632bf7b1 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -8,8 +8,11 @@ open CSig open Pp +open CErrors open Names +open Genarg open Geninterp +open Tac2env open Tac2expr open Proofview.Notations @@ -26,6 +29,7 @@ let t_string = coq_core "string" let t_array = coq_core "array" let t_unit = coq_core "unit" let t_list = coq_core "list" +let t_constr = coq_core "constr" let c_nil = coq_core "[]" let c_cons = coq_core "::" @@ -66,6 +70,8 @@ match Val.eq tag tag' with let val_pp = Val.create "ltac2:pp" let get_pp v = extract_val val_pp v +let val_valexpr = Val.create "ltac2:valexpr" + (** Helper functions *) let return x = Proofview.tclUNIT x @@ -117,3 +123,66 @@ let () = Tac2env.define_primitive (pname "array_make") prm_array_make let () = Tac2env.define_primitive (pname "array_length") prm_array_length let () = Tac2env.define_primitive (pname "array_get") prm_array_get let () = Tac2env.define_primitive (pname "array_set") prm_array_set + +(** ML types *) + +let val_tag t = match val_tag t with +| Val.Base t -> t +| _ -> assert false + +let tag_constr = val_tag (topwit Stdarg.wit_constr) + +let constr_flags () = + let open Pretyping in + { + use_typeclasses = true; + solve_unification_constraints = true; + use_hook = Pfedit.solve_by_implicit_tactic (); + fail_evar = true; + expand_evars = true + } + +(** In Ltac2, the notion of "current environment" only makes sense when there is + at most one goal under focus. Contrarily to Ltac1, instead of dynamically + focussing when we need it, we raise a non-backtracking error when it does + not make sense. *) +exception NonFocussedGoal + +let () = register_handler begin function +| NonFocussedGoal -> str "Several goals under focus" +| _ -> raise Unhandled +end + +let pf_apply f = + Proofview.Goal.goals >>= function + | [] -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + f env sigma + | [gl] -> + gl >>= fun gl -> + f (Proofview.Goal.env gl) (Tacmach.New.project gl) + | _ :: _ :: _ -> + Proofview.tclLIFT (Proofview.NonLogical.raise NonFocussedGoal) + +(** Embed all Ltac2 data into Values *) +let to_lvar ist = + let open Pretyping in + let map e = Val.Dyn (val_valexpr, e) in + let lfun = Id.Map.map map ist in + { empty_lvar with ltac_genargs = lfun } + +let () = + let open Pretyping in + let interp ist (c, _) = pf_apply begin fun env sigma -> + let ist = to_lvar ist in + let (sigma, c) = understand_ltac (constr_flags ()) env sigma ist WithoutTypeConstraint c in + let c = Val.Dyn (tag_constr, c) in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT c + end in + let obj = { + ml_type = t_constr; + ml_interp = interp; + } in + define_ml_object Stdarg.wit_constr obj diff --git a/tac2intern.ml b/tac2intern.ml index 516690dfd3..a554f959a0 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -613,7 +613,7 @@ let rec intern_rec env = function let genv = Global.env_of_context Environ.empty_named_context_val in let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let (_, ext) = generic_intern ist ext in + let (_, ext) = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> generic_intern ist ext) () in (GTacExt ext, GTypRef (tpe.ml_type, [])) and intern_let_rec env loc el e = -- cgit v1.2.3 From 07ad1ca45473ba02db9b687bb7e89d440ba79b20 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 4 Dec 2016 21:48:06 +0100 Subject: Proper handling of record types. We add the standard ML facilities for records, that is, projections, mutable fields and primitive to set them. --- Ltac2.v | 2 +- g_ltac2.ml4 | 30 ++++++++-- tac2entries.ml | 79 +++++++++++++++++-------- tac2env.ml | 65 ++++++++++++++++++--- tac2env.mli | 45 ++++++++++++--- tac2expr.mli | 20 +++++-- tac2intern.ml | 180 +++++++++++++++++++++++++++++++++++++++++++++++---------- tac2interp.ml | 19 ++++++ 8 files changed, 360 insertions(+), 80 deletions(-) diff --git a/Ltac2.v b/Ltac2.v index a952524e71..0933c1e0b4 100644 --- a/Ltac2.v +++ b/Ltac2.v @@ -20,7 +20,7 @@ Ltac2 Type 'a array. (** Pervasive types *) -Ltac2 Type 'a option := | None | Some ('a). +Ltac2 Type 'a option := [ None | Some ('a) ]. (** Primitive tactics *) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index b613f22a8d..ce2becd9f9 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -50,6 +50,8 @@ GEXTEND Gram [ e1 = tac2expr; ";"; e2 = tac2expr -> CTacSeq (!@loc, e1, e2) ] | "1" LEFTA [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) + | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, qid) + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, qid, r) | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "0" SEP "," -> CTacTup (!@loc, e0 :: el) ] | "0" [ "("; a = tac2expr LEVEL "5"; ")" -> a @@ -57,6 +59,7 @@ GEXTEND Gram | "()" -> CTacTup (!@loc, []) | "("; ")" -> CTacTup (!@loc, []) | "["; a = LIST0 tac2expr LEVEL "1" SEP ";"; "]" -> CTacLst (!@loc, a) + | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) | a = tactic_atom -> a ] ] ; @@ -126,16 +129,35 @@ GEXTEND Gram ; tac2typ_knd: [ [ t = tac2type -> CTydDef (Some t) - | t = tac2alg_type -> CTydAlg t ] ] + | "["; t = tac2alg_constructors; "]" -> CTydAlg t + | "{"; t = tac2rec_fields; "}"-> CTydRec t ] ] ; - tac2alg_type: - [ [ -> [] - | "|"; bl = LIST1 tac2alg_constructor SEP "|" -> bl ] ] + tac2alg_constructors: + [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> cs + | cs = LIST0 tac2alg_constructor SEP "|" -> cs ] ] ; tac2alg_constructor: [ [ c = Prim.ident -> (c, []) | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> (c, args) ] ] ; + tac2rec_fields: + [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> f :: l + | f = tac2rec_field; ";" -> [f] + | f = tac2rec_field -> [f] + | -> [] ] ] + ; + tac2rec_field: + [ [ mut = [ -> false | IDENT "mutable" -> true]; id = Prim.ident; ":"; t = tac2type -> (id, mut, t) ] ] + ; + tac2rec_fieldexprs: + [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> f :: l + | f = tac2rec_fieldexpr; ";" -> [f] + | f = tac2rec_fieldexpr-> [f] + | -> [] ] ] + ; + tac2rec_fieldexpr: + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> qid, e ] ] + ; tac2typ_prm: [ [ -> [] | id = typ_param -> [!@loc, id] diff --git a/tac2entries.ml b/tac2entries.ml index 7572270ab3..4098324f12 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -13,6 +13,7 @@ open Names open Libnames open Libobject open Nametab +open Tac2env open Tac2expr open Tac2intern open Vernacexpr @@ -24,14 +25,14 @@ type tacdef = { } let perform_tacdef visibility ((sp, kn), def) = - let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp kn in + let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp (TacConstant kn) in Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) let load_tacdef i obj = perform_tacdef (Until i) obj let open_tacdef i obj = perform_tacdef (Exactly i) obj let cache_tacdef ((sp, kn), def) = - let () = Tac2env.push_ltac (Until 1) sp kn in + let () = Tac2env.push_ltac (Until 1) sp (TacConstant kn) in Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) let subst_tacdef (subst, def) = @@ -71,12 +72,19 @@ let push_typedef visibility sp kn (_, def) = match def with let iter (c, _) = let spc = change_sp_label sp c in let knc = change_kn_label kn c in - Tac2env.push_ltac visibility spc knc + Tac2env.push_ltac visibility spc (TacConstructor knc) in Tac2env.push_type visibility sp kn; List.iter iter cstrs -| GTydRec _ -> - assert false (** FIXME *) +| GTydRec fields -> + (** Register fields *) + let iter (c, _, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_projection visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter fields let next i = let ans = !i in @@ -95,27 +103,31 @@ let define_typedef kn (params, def as qdef) = match def with let iter (c, args) = let knc = change_kn_label kn c in let tag = if List.is_empty args then next constant else next nonconstant in - let ids = List.mapi (fun i _ -> dummy_var i) args in - let c = GTacCst (kn, tag, List.map (fun id -> GTacVar id) ids) in - let c = - if List.is_empty args then c - else GTacFun (List.map (fun id -> Name id) ids, c) - in - let fold arg tpe = GTypArrow (arg, tpe) in - let cT = GTypRef (kn, List.init params (fun i -> GTypVar i)) in - let cT = List.fold_right fold args cT in let data = { - Tac2env.cdata_type = kn; - cdata_args = params, args; + Tac2env.cdata_prms = params; + cdata_type = kn; + cdata_args = args; cdata_indx = tag; } in - Tac2env.define_constructor knc data; - Tac2env.define_global knc (c, (params, cT)) + Tac2env.define_constructor knc data in Tac2env.define_type kn qdef; List.iter iter cstrs -| GTydRec _ -> - assert false (** FIXME *) +| GTydRec fs -> + (** Define projections *) + let iter i (id, mut, t) = + let knp = change_kn_label kn id in + let proj = { + Tac2env.pdata_prms = params; + pdata_type = kn; + pdata_ptyp = t; + pdata_mutb = mut; + pdata_indx = i; + } in + Tac2env.define_projection knp proj + in + Tac2env.define_type kn qdef; + List.iteri iter fs let perform_typdef vs ((sp, kn), def) = let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in @@ -213,8 +225,22 @@ let register_type ?(local = false) isrec types = if isrec then user_err ~loc (str "The type abbreviation " ++ Id.print id ++ str " cannot be recursive") - | CTydAlg _ -> () (** FIXME *) - | CTydRec _ -> assert false (** FIXME *) + | CTydAlg cs -> + let same_name (id1, _) (id2, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name cs with + | [] -> () + | (id, _) :: _ -> + user_err (str "Multiple definitions of the constructor " ++ Id.print id) + in + () + | CTydRec ps -> + let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name ps with + | [] -> () + | (id, _, _) :: _ -> + user_err (str "Multiple definitions of the projection " ++ Id.print id) + in + () in let () = List.iter check types in let self = @@ -275,8 +301,13 @@ let print_ltac ref = try Tac2env.locate_ltac qid with Not_found -> user_err ~loc (str "Unknown tactic " ++ pr_qualid qid) in - let (_, (_, t)) = Tac2env.interp_global kn in - Feedback.msg_notice (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype t) + match kn with + | TacConstant kn -> + let (_, (_, t)) = Tac2env.interp_global kn in + Feedback.msg_notice (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype t) + | TacConstructor kn -> + let _ = Tac2env.interp_constructor kn in + Feedback.msg_notice (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid) (** Calling tactics *) diff --git a/tac2env.ml b/tac2env.ml index 3500b2ef3d..bdb8f41ef8 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -15,23 +15,35 @@ open Tac2expr type ltac_constant = KerName.t type ltac_constructor = KerName.t +type ltac_projection = KerName.t type type_constant = KerName.t type constructor_data = { + cdata_prms : int; cdata_type : type_constant; - cdata_args : int * int glb_typexpr list; + cdata_args : int glb_typexpr list; cdata_indx : int; } +type projection_data = { + pdata_prms : int; + pdata_type : type_constant; + pdata_ptyp : int glb_typexpr; + pdata_mutb : bool; + pdata_indx : int; +} + type ltac_state = { ltac_tactics : (glb_tacexpr * type_scheme) KNmap.t; ltac_constructors : constructor_data KNmap.t; + ltac_projections : projection_data KNmap.t; ltac_types : glb_quant_typedef KNmap.t; } let empty_state = { ltac_tactics = KNmap.empty; ltac_constructors = KNmap.empty; + ltac_projections = KNmap.empty; ltac_types = KNmap.empty; } @@ -51,8 +63,8 @@ let rec eval_pure = function | GTacTup el -> ValBlk (0, Array.map_of_list eval_pure el) | GTacCst (_, n, []) -> ValInt n | GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) -| GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ -| GTacApp _ | GTacCse _ | GTacPrm _ | GTacExt _ -> +| GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ | GTacSet _ +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ -> anomaly (Pp.str "Term is not a syntactical value") let define_global kn e = @@ -69,6 +81,12 @@ let define_constructor kn t = let interp_constructor kn = KNmap.find kn ltac_state.contents.ltac_constructors +let define_projection kn t = + let state = !ltac_state in + ltac_state := { state with ltac_projections = KNmap.add kn t state.ltac_projections } + +let interp_projection kn = KNmap.find kn ltac_state.contents.ltac_projections + let define_type kn e = let state = !ltac_state in ltac_state := { state with ltac_types = KNmap.add kn e state.ltac_types } @@ -103,28 +121,47 @@ struct id, (DirPath.repr dir) end +type tacref = +| TacConstant of ltac_constant +| TacConstructor of ltac_constructor + +module TacRef = +struct +type t = tacref +let equal r1 r2 = match r1, r2 with +| TacConstant c1, TacConstant c2 -> KerName.equal c1 c2 +| TacConstructor c1, TacConstructor c2 -> KerName.equal c1 c2 +| _ -> false +end + module KnTab = Nametab.Make(FullPath)(KerName) +module RfTab = Nametab.Make(FullPath)(TacRef) type nametab = { - tab_ltac : KnTab.t; + tab_ltac : RfTab.t; tab_type : KnTab.t; + tab_proj : KnTab.t; } -let empty_nametab = { tab_ltac = KnTab.empty; tab_type = KnTab.empty } +let empty_nametab = { + tab_ltac = RfTab.empty; + tab_type = KnTab.empty; + tab_proj = KnTab.empty; +} let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" let push_ltac vis sp kn = let tab = !nametab in - nametab := { tab with tab_ltac = KnTab.push vis sp kn tab.tab_ltac } + nametab := { tab with tab_ltac = RfTab.push vis sp kn tab.tab_ltac } let locate_ltac qid = let tab = !nametab in - KnTab.locate qid tab.tab_ltac + RfTab.locate qid tab.tab_ltac let locate_extended_all_ltac qid = let tab = !nametab in - KnTab.find_prefixes qid tab.tab_ltac + RfTab.find_prefixes qid tab.tab_ltac let push_type vis sp kn = let tab = !nametab in @@ -138,6 +175,18 @@ let locate_extended_all_type qid = let tab = !nametab in KnTab.find_prefixes qid tab.tab_type +let push_projection vis sp kn = + let tab = !nametab in + nametab := { tab with tab_proj = KnTab.push vis sp kn tab.tab_proj } + +let locate_projection qid = + let tab = !nametab in + KnTab.locate qid tab.tab_proj + +let locate_extended_all_projection qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_proj + type 'a ml_object = { ml_type : type_constant; ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; diff --git a/tac2env.mli b/tac2env.mli index eb471b9abf..bcfa70487a 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -14,10 +14,6 @@ open Tac2expr (** Ltac2 global environment *) -type ltac_constant = KerName.t -type ltac_constructor = KerName.t -type type_constant = KerName.t - (** {5 Toplevel definition of values} *) val define_global : ltac_constant -> (glb_tacexpr * type_scheme) -> unit @@ -31,24 +27,57 @@ val interp_type : type_constant -> glb_quant_typedef (** {5 Toplevel definition of algebraic constructors} *) type constructor_data = { + cdata_prms : int; + (** Type parameters *) cdata_type : type_constant; - cdata_args : int * int glb_typexpr list; + (** Inductive definition to which the constructor pertains *) + cdata_args : int glb_typexpr list; + (** Types of the constructor arguments *) cdata_indx : int; + (** Index of the constructor in the ADT. Numbering is duplicated between + argumentless and argument-using constructors, e.g. in type ['a option] + [None] and [Some] have both index 0. *) } val define_constructor : ltac_constructor -> constructor_data -> unit val interp_constructor : ltac_constructor -> constructor_data +(** {5 Toplevel definition of projections} *) + +type projection_data = { + pdata_prms : int; + (** Type parameters *) + pdata_type : type_constant; + (** Record definition to which the projection pertains *) + pdata_ptyp : int glb_typexpr; + (** Type of the projection *) + pdata_mutb : bool; + (** Whether the field is mutable *) + pdata_indx : int; + (** Index of the projection *) +} + +val define_projection : ltac_projection -> projection_data -> unit +val interp_projection : ltac_projection -> projection_data + (** {5 Name management} *) -val push_ltac : visibility -> full_path -> ltac_constant -> unit -val locate_ltac : qualid -> ltac_constant -val locate_extended_all_ltac : qualid -> ltac_constant list +type tacref = +| TacConstant of ltac_constant +| TacConstructor of ltac_constructor + +val push_ltac : visibility -> full_path -> tacref -> unit +val locate_ltac : qualid -> tacref +val locate_extended_all_ltac : qualid -> tacref list val push_type : visibility -> full_path -> type_constant -> unit val locate_type : qualid -> type_constant val locate_extended_all_type : qualid -> type_constant list +val push_projection : visibility -> full_path -> ltac_projection -> unit +val locate_projection : qualid -> ltac_projection +val locate_extended_all_projection : qualid -> ltac_projection list + (** {5 Toplevel definitions of ML tactics} *) (** This state is not part of the summary, contrarily to the ones above. It is diff --git a/tac2expr.mli b/tac2expr.mli index 15c630ca87..b9b649e481 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -16,6 +16,11 @@ type rec_flag = bool type lid = Id.t type uid = Id.t +type ltac_constant = KerName.t +type ltac_constructor = KerName.t +type ltac_projection = KerName.t +type type_constant = KerName.t + (** {5 Misc} *) type ml_tactic_name = { @@ -40,7 +45,7 @@ type 'a glb_typexpr = | GTypVar of 'a | GTypArrow of 'a glb_typexpr * 'a glb_typexpr | GTypTuple of 'a glb_typexpr list -| GTypRef of KerName.t * 'a glb_typexpr list +| GTypRef of type_constant * 'a glb_typexpr list type glb_typedef = | GTydDef of int glb_typexpr option @@ -76,25 +81,32 @@ type raw_tacexpr = | CTacCnv of Loc.t * raw_tacexpr * raw_typexpr | CTacSeq of Loc.t * raw_tacexpr * raw_tacexpr | CTacCse of Loc.t * raw_tacexpr * raw_taccase list +| CTacRec of Loc.t * raw_recexpr +| CTacPrj of Loc.t * raw_tacexpr * qualid located +| CTacSet of Loc.t * raw_tacexpr * qualid located * raw_tacexpr | CTacExt of Loc.t * raw_generic_argument and raw_taccase = raw_patexpr * raw_tacexpr +and raw_recexpr = (qualid located * raw_tacexpr) list + type case_info = | GCaseTuple of int -| GCaseAlg of KerName.t +| GCaseAlg of type_constant type glb_tacexpr = | GTacAtm of atom | GTacVar of Id.t -| GTacRef of KerName.t +| GTacRef of ltac_constant | GTacFun of Name.t list * glb_tacexpr | GTacApp of glb_tacexpr * glb_tacexpr list | GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr | GTacTup of glb_tacexpr list | GTacArr of glb_tacexpr list -| GTacCst of KerName.t * int * glb_tacexpr list +| GTacCst of type_constant * int * glb_tacexpr list | GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array +| GTacPrj of glb_tacexpr * int +| GTacSet of glb_tacexpr * int * glb_tacexpr | GTacExt of glob_generic_argument | GTacPrm of ml_tactic_name * glb_tacexpr list diff --git a/tac2intern.ml b/tac2intern.ml index a554f959a0..10fcde6efa 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -174,6 +174,9 @@ let loc_of_tacexpr = function | CTacCnv (loc, _, _) -> loc | CTacSeq (loc, _, _) -> loc | CTacCse (loc, _, _) -> loc +| CTacRec (loc, _) -> loc +| CTacPrj (loc, _, _) -> loc +| CTacSet (loc, _, _, _) -> loc | CTacExt (loc, _) -> loc let loc_of_patexpr = function @@ -181,6 +184,11 @@ let loc_of_patexpr = function | CPatRef (loc, _, _) -> loc | CPatTup (loc, _) -> loc +let error_nargs_mismatch loc nargs nfound = + user_err ~loc (str "Constructor expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + let rec subst_type subst (t : 'a glb_typexpr) = match t with | GTypVar id -> subst id | GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) @@ -320,20 +328,27 @@ let unify loc env t1 t2 = (** Term typing *) +let is_pure_constructor kn = + match snd (Tac2env.interp_type kn) with + | GTydAlg _ -> true + | GTydRec fields -> + let is_pure (_, mut, _) = not mut in + List.for_all is_pure fields + | GTydDef _ -> assert false (** Type definitions have no constructors *) + let rec is_value = function | GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true | GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false | GTacTup el -> List.for_all is_value el | GTacCst (_, _, []) -> true -| GTacCst (kn, n, el) -> - (** To be a value, a constructor must be immutable *) - assert false (** TODO *) -| GTacArr _ | GTacCse _ | GTacExt _ | GTacPrm _ -> false +| GTacCst (kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ -> false let is_rec_rhs = function | GTacFun _ -> true -| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ -> false -| GTacTup _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ | GTacCse _ -> false +| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ +| GTacSet _ | GTacTup _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacCse _ -> false let rec fv_type f t accu = match t with | GTypVar id -> f id accu @@ -438,18 +453,23 @@ let get_variable env (loc, qid) = let get_constructor env (loc, qid) = let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in match c with - | Some knc -> - let kn = - try Tac2env.interp_constructor knc - with Not_found -> - CErrors.user_err ~loc (str "The term " ++ pr_qualid qid ++ - str " is not the constructor of an inductive type.") in + | Some (TacConstructor knc) -> + let kn = Tac2env.interp_constructor knc in ArgArg (kn, knc) + | Some (TacConstant _) -> + CErrors.user_err ~loc (str "The term " ++ pr_qualid qid ++ + str " is not the constructor of an inductive type.") | None -> let (dp, id) = repr_qualid qid in if DirPath.is_empty dp then ArgVar (loc, id) else CErrors.user_err ~loc (str "Unbound constructor " ++ pr_qualid qid) +let get_projection (loc, qid) = + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ~loc (pr_qualid qid ++ str " is not a projection") + in + Tac2env.interp_projection kn + let intern_atm env = function | AtmInt n -> (GTacAtm (AtmInt n), GTypRef (t_int, [])) | AtmStr s -> (GTacAtm (AtmStr s), GTypRef (t_string, [])) @@ -496,6 +516,10 @@ let get_pattern_kind env pl = match pl with in get_kind p pl +let is_constructor env qid = match get_variable env qid with +| ArgArg (TacConstructor _) -> true +| _ -> false + let rec intern_rec env = function | CTacAtm (_, atm) -> intern_atm env atm | CTacRef qid -> @@ -503,9 +527,11 @@ let rec intern_rec env = function | ArgVar (_, id) -> let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) - | ArgArg kn -> + | ArgArg (TacConstant kn) -> let (_, sch) = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) + | ArgArg (TacConstructor kn) -> + intern_constructor env (fst qid) kn [] end | CTacFun (loc, bnd, e) -> let fold (env, bnd, tl) ((_, na), t) = @@ -520,6 +546,12 @@ let rec intern_rec env = function let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in (GTacFun (bnd, e), t) +| CTacApp (loc, CTacRef qid, args) when is_constructor env qid -> + let kn = match get_variable env qid with + | ArgArg (TacConstructor kn) -> kn + | _ -> assert false + in + intern_constructor env (fst qid) kn args | CTacApp (loc, f, args) -> let (f, ft) = intern_rec env f in let fold arg (args, t) = @@ -571,12 +603,7 @@ let rec intern_rec env = function (GTacArr [], GTypRef (t_int, [GTypVar id])) | CTacArr (loc, e0 :: el) -> let (e0, t0) = intern_rec env e0 in - let fold e el = - let loc = loc_of_tacexpr e in - let (e, t) = intern_rec env e in - let () = unify loc env t t0 in - e :: el - in + let fold e el = intern_rec_with_constraint env e t0 :: el in let el = e0 :: List.fold_right fold el [] in (GTacArr el, GTypRef (t_array, [t0])) | CTacLst (loc, []) -> @@ -584,12 +611,7 @@ let rec intern_rec env = function (c_nil, GTypRef (t_list, [GTypVar id])) | CTacLst (loc, e0 :: el) -> let (e0, t0) = intern_rec env e0 in - let fold e el = - let loc = loc_of_tacexpr e in - let (e, t) = intern_rec env e in - let () = unify loc env t t0 in - c_cons e el - in + let fold e el = c_cons (intern_rec_with_constraint env e t0) el in let el = c_cons e0 (List.fold_right fold el c_nil) in (el, GTypRef (t_list, [t0])) | CTacCnv (loc, e, tc) -> @@ -604,6 +626,34 @@ let rec intern_rec env = function (GTacLet (false, [Anonymous, e1], e2), t2) | CTacCse (loc, e, pl) -> intern_case env loc e pl +| CTacRec (loc, fs) -> + intern_record env loc fs +| CTacPrj (loc, e, proj) -> + let pinfo = get_projection proj in + let loc = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (pinfo.pdata_type, params) in + let () = unify loc env t exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + (GTacPrj (e, pinfo.pdata_indx), ret) +| CTacSet (loc, e, proj, r) -> + let pinfo = get_projection proj in + let () = + if not pinfo.pdata_mutb then + let (loc, _) = proj in + user_err ~loc (str "Field is not mutable") + in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (pinfo.pdata_type, params) in + let e = intern_rec_with_constraint env e exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + let r = intern_rec_with_constraint env r ret in + (GTacSet (e, pinfo.pdata_indx, r), GTypRef (t_unit, [])) | CTacExt (loc, ext) -> let open Genintern in let GenArg (Rawwit tag, _) = ext in @@ -616,6 +666,12 @@ let rec intern_rec env = function let (_, ext) = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> generic_intern ist ext) () in (GTacExt ext, GTypRef (tpe.ml_type, [])) +and intern_rec_with_constraint env e exp = + let loc = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let () = unify loc env t exp in + e + and intern_let_rec env loc el e = let fold accu ((loc, na), _, _) = match na with | Anonymous -> accu @@ -760,12 +816,9 @@ and intern_case env loc e pl = in let ids = List.map get_id args in let nids = List.length ids in - let nargs = List.length (snd data.cdata_args) in + let nargs = List.length data.cdata_args in let () = - if not (Int.equal nids nargs) then - user_err ~loc (str "Constructor expects " ++ int nargs ++ - str " arguments, but is applied to " ++ int nids ++ - str " arguments") + if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids in let fold env id tpe = (** Instantiate all arguments *) @@ -773,7 +826,7 @@ and intern_case env loc e pl = let tpe = subst_type subst tpe in push_name id (monomorphic tpe) env in - let nenv = List.fold_left2 fold env ids (snd data.cdata_args) in + let nenv = List.fold_left2 fold env ids data.cdata_args in let (br', brT) = intern_rec nenv br in let () = let index = data.cdata_indx in @@ -802,6 +855,64 @@ and intern_case env loc e pl = let ce = GTacCse (e', GCaseAlg kn, const, nonconst) in (ce, ret) +and intern_constructor env loc kn args = + let cstr = interp_constructor kn in + let nargs = List.length cstr.cdata_args in + if Int.equal nargs (List.length args) then + let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in + let ans = GTypRef (cstr.cdata_type, List.init cstr.cdata_prms (fun i -> GTypVar subst.(i))) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + (GTacCst (cstr.cdata_type, cstr.cdata_indx, args), ans) + else + error_nargs_mismatch loc nargs (List.length args) + +and intern_record env loc fs = + let map ((loc, qid), e) = + let proj = get_projection (loc, qid) in + (loc, proj, e) + in + let fs = List.map map fs in + let kn = match fs with + | [] -> user_err ~loc (str "Cannot infer the corresponding record type") + | (_, proj, _) :: _ -> proj.pdata_type + in + let params, typdef = match Tac2env.interp_type kn with + | n, GTydRec def -> n, def + | _ -> assert false + in + let subst = Array.init params (fun _ -> fresh_id env) in + (** Set the answer [args] imperatively *) + let args = Array.make (List.length typdef) None in + let iter (loc, pinfo, e) = + if KerName.equal kn pinfo.pdata_type then + let index = pinfo.pdata_indx in + match args.(index) with + | None -> + let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in + let e = intern_rec_with_constraint env e exp in + args.(index) <- Some e + | Some _ -> + let (name, _, _) = List.nth typdef pinfo.pdata_indx in + user_err ~loc (str "Field " ++ Id.print name ++ str " is defined \ + several times") + else + user_err ~loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ + pertain to record definition " ++ KerName.print pinfo.pdata_type) + in + let () = List.iter iter fs in + let () = match Array.findi (fun _ o -> Option.is_empty o) args with + | None -> () + | Some i -> + let (field, _, _) = List.nth typdef i in + user_err ~loc (str "Field " ++ Id.print field ++ str " is undefined") + in + let args = Array.map_to_list Option.get args in + let tparam = List.init params (fun i -> GTypVar subst.(i)) in + (GTacCst (kn, 0, args), GTypRef (kn, tparam)) + let normalize env (count, vars) (t : UF.elt glb_typexpr) = let get_var id = try UF.Map.find id !vars @@ -907,6 +1018,13 @@ let rec subst_expr subst e = match e with let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in let ci' = subst_case_info subst ci in GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacPrj (e, p) as e0 -> + let e' = subst_expr subst e in + if e' == e then e0 else GTacPrj (e', p) +| GTacSet (e, p, r) as e0 -> + let e' = subst_expr subst e in + let r' = subst_expr subst r in + if e' == e && r' == r then e0 else GTacSet (e', p, r') | GTacExt ext -> let ext' = Genintern.generic_substitute subst ext in if ext' == ext then e else GTacExt ext' diff --git a/tac2interp.ml b/tac2interp.ml index b868caf963..fedbb13e7d 100644 --- a/tac2interp.ml +++ b/tac2interp.ml @@ -80,6 +80,12 @@ let rec interp ist = function return (ValBlk (n, Array.of_list el)) | GTacCse (e, _, cse0, cse1) -> interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacPrj (e, p) -> + interp ist e >>= fun e -> interp_proj ist e p +| GTacSet (e, p, r) -> + interp ist e >>= fun e -> + interp ist r >>= fun r -> + interp_set ist e p r | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> Tac2env.interp_primitive ml el @@ -110,3 +116,16 @@ and interp_case ist e cse0 cse1 = match e with interp ist e | ValExt _ | ValStr _ | ValCls _ -> anomaly (str "Unexpected value shape") + +and interp_proj ist e p = match e with +| ValBlk (_, args) -> + return args.(p) +| ValInt _ | ValExt _ | ValStr _ | ValCls _ -> + anomaly (str "Unexpected value shape") + +and interp_set ist e p r = match e with +| ValBlk (_, args) -> + let () = args.(p) <- r in + return (ValInt 0) +| ValInt _ | ValExt _ | ValStr _ | ValCls _ -> + anomaly (str "Unexpected value shape") -- cgit v1.2.3 From 152b259b7b587ea949dd856b24beaf56466f3f27 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 5 Dec 2016 16:32:26 +0100 Subject: Fixing a precedence issue in type parameters. --- Array.v | 14 +++ Constr.v | 9 ++ Control.v | 44 +++++++ Init.v | 32 +++++ Int.v | 16 +++ Ltac2.v | 42 ++----- Message.v | 20 +++ String.v | 14 +++ g_ltac2.ml4 | 14 ++- tac2core.ml | 381 ++++++++++++++++++++++++++++++++++++++++++++++++++------- tac2core.mli | 19 +++ tac2entries.ml | 3 +- tac2env.ml | 5 + tac2env.mli | 5 + tac2expr.mli | 2 +- tac2intern.ml | 3 +- tac2interp.ml | 10 +- tac2interp.mli | 12 +- vo.itarget | 7 ++ 19 files changed, 556 insertions(+), 96 deletions(-) create mode 100644 Array.v create mode 100644 Constr.v create mode 100644 Control.v create mode 100644 Init.v create mode 100644 Int.v create mode 100644 Message.v create mode 100644 String.v diff --git a/Array.v b/Array.v new file mode 100644 index 0000000000..be4ab025ae --- /dev/null +++ b/Array.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'a array := "ltac2" "array_make". +Ltac2 @external length : 'a array -> int := "ltac2" "array_length". +Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". +Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/Constr.v b/Constr.v new file mode 100644 index 0000000000..994f9bf3ac --- /dev/null +++ b/Constr.v @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a := "ltac2" "throw". +(** Fatal exception throwing. This does not induce backtracking. *) + +(** Generic backtracking control *) + +Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". +Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". +Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". +Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". +Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". +Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". + +(** Proof state manipulation *) + +Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". +Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". +Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". + +(** Goal inspection *) + +Ltac2 @ external goal : unit -> constr := "ltac2" "goal". +(** Panics if there is not exactly one goal under focus. Otherwise returns + the conclusion of this goal. *) + +Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, looks for the section variable with the given name. + If there is one, looks for the hypothesis with the given name. *) + +(** Refinement *) + +Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". diff --git a/Init.v b/Init.v new file mode 100644 index 0000000000..0f0b4636d8 --- /dev/null +++ b/Init.v @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> bool := "ltac2" "int_equal". +Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". +Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". +Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". +Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". +Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/Ltac2.v b/Ltac2.v index 0933c1e0b4..625d4ac513 100644 --- a/Ltac2.v +++ b/Ltac2.v @@ -6,37 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Declare ML Module "ltac2_plugin". - -Global Set Default Proof Mode "Ltac2". - -(** Primitive types *) - -Ltac2 Type int. -Ltac2 Type string. -Ltac2 Type constr. -Ltac2 Type message. -Ltac2 Type 'a array. - -(** Pervasive types *) - -Ltac2 Type 'a option := [ None | Some ('a) ]. - -(** Primitive tactics *) - -Module Message. - -Ltac2 @ external print : message -> unit := "ltac2" "print". -Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". -Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". - -End Message. - -Module Array. - -Ltac2 @external make : int -> 'a -> ('a) array := "ltac2" "array_make". -Ltac2 @external length : ('a) array -> int := "ltac2" "array_length". -Ltac2 @external get : ('a) array -> int -> 'a := "ltac2" "array_get". -Ltac2 @external set : ('a) array -> int -> 'a -> unit := "ltac2" "array_set". - -End Array. +Require Export Coq.ltac2.Init. + +Require Coq.ltac2.Int. +Require Coq.ltac2.String. +Require Coq.ltac2.Array. +Require Coq.ltac2.Message. +Require Coq.ltac2.Constr. +Require Coq.ltac2.Control. diff --git a/Message.v b/Message.v new file mode 100644 index 0000000000..36233f4544 --- /dev/null +++ b/Message.v @@ -0,0 +1,20 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit := "ltac2" "print". + +Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". + +Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". + +Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/String.v b/String.v new file mode 100644 index 0000000000..3a4a178878 --- /dev/null +++ b/String.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char -> string := "ltac2" "string_make". +Ltac2 @external length : string -> int := "ltac2" "string_length". +Ltac2 @external get : string -> int -> char := "ltac2" "string_get". +Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index ce2becd9f9..ff3d79bbae 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -23,6 +23,8 @@ let tac2mode = Gram.entry_create "vernac:ltac2_command" let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) let inj_constr loc c = inj_wit Stdarg.wit_constr loc c +let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c +let inj_ident loc c = inj_wit Stdarg.wit_ident loc c GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext; @@ -84,6 +86,8 @@ GEXTEND Gram | s = Prim.string -> CTacAtm (!@loc, AtmStr s) | id = Prim.qualid -> CTacRef id | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c + | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c ] ] ; let_clause: @@ -97,13 +101,15 @@ GEXTEND Gram [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] | "2" [ t = tac2type; "*"; tl = LIST1 tac2type SEP "*" -> CTypTuple (!@loc, t :: tl) ] - | "1" - [ "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> CTypRef (!@loc, qid, p) ] + | "1" LEFTA + [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, qid, [t]) ] | "0" - [ "("; t = tac2type; ")" -> t + [ "("; t = tac2type LEVEL "5"; ")" -> t | id = typ_param -> CTypVar (!@loc, Name id) | "_" -> CTypVar (!@loc, Anonymous) - | qid = Prim.qualid -> CTypRef (!@loc, qid, []) ] + | qid = Prim.qualid -> CTypRef (!@loc, qid, []) + | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> + CTypRef (!@loc, qid, p) ] ]; locident: [ [ id = Prim.ident -> (!@loc, id) ] ] diff --git a/tac2core.ml b/tac2core.ml index 95632bf7b1..fd998151fd 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -14,12 +14,25 @@ open Genarg open Geninterp open Tac2env open Tac2expr +open Tac2interp open Proofview.Notations (** Standard values *) -let coq_prefix = DirPath.make (List.map Id.of_string ["Ltac2"; "ltac2"; "Coq"]) -let coq_core n = KerName.make2 (MPfile coq_prefix) (Label.of_id (Id.of_string_soft n)) +let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) + +let val_tag t = match val_tag t with +| Val.Base t -> t +| _ -> assert false + +let val_constr = val_tag (topwit Stdarg.wit_constr) +let val_ident = val_tag (topwit Stdarg.wit_ident) +let val_pp = Val.create "ltac2:pp" + +let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v module Core = struct @@ -30,6 +43,7 @@ let t_array = coq_core "array" let t_unit = coq_core "unit" let t_list = coq_core "list" let t_constr = coq_core "constr" +let t_ident = coq_core "ident" let c_nil = coq_core "[]" let c_cons = coq_core "::" @@ -51,6 +65,28 @@ let to_unit = function | ValInt 0 -> () | _ -> assert false +let of_int n = ValInt n +let to_int = function +| ValInt n -> n +| _ -> assert false + +let of_bool b = if b then ValInt 0 else ValInt 1 + +let to_bool = function +| ValInt 0 -> true +| ValInt 1 -> false +| _ -> assert false + +let of_char n = ValInt (Char.code n) +let to_char = function +| ValInt n -> Char.chr n +| _ -> assert false + +let of_string s = ValStr s +let to_string = function +| ValStr s -> s +| _ -> assert false + let rec of_list = function | [] -> v_nil | x :: l -> v_cons x (of_list l) @@ -60,20 +96,33 @@ let rec to_list = function | ValBlk (0, [|v; vl|]) -> v :: to_list vl | _ -> assert false -end +let of_ext tag c = + ValExt (Val.Dyn (tag, c)) -let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = -match Val.eq tag tag' with -| None -> assert false -| Some Refl -> v +let to_ext tag = function +| ValExt e -> extract_val tag e +| _ -> assert false -let val_pp = Val.create "ltac2:pp" -let get_pp v = extract_val val_pp v +let of_constr c = of_ext val_constr c +let to_constr c = to_ext val_constr c + +let of_ident c = of_ext val_ident c +let to_ident c = to_ext val_ident c + +let of_exn c = of_ext val_exn c +let to_exn c = to_ext val_exn c + +let of_pp c = of_ext val_pp c +let to_pp c = to_ext val_pp c + +end let val_valexpr = Val.create "ltac2:valexpr" (** Helper functions *) +let thaw f = interp_app f [v_unit] + let return x = Proofview.tclUNIT x let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -83,10 +132,35 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit +(** In Ltac2, the notion of "current environment" only makes sense when there is + at most one goal under focus. Contrarily to Ltac1, instead of dynamically + focussing when we need it, we raise a non-backtracking error when it does + not make sense. *) +exception NonFocussedGoal + +let () = register_handler begin function +| NonFocussedGoal -> str "Several goals under focus" +| _ -> raise Unhandled +end + +let pf_apply f = + Proofview.Goal.goals >>= function + | [] -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + f env sigma + | [gl] -> + gl >>= fun gl -> + f (Proofview.Goal.env gl) (Tacmach.New.project gl) + | _ :: _ :: _ -> + Proofview.tclLIFT (Proofview.NonLogical.raise NonFocussedGoal) + (** Primitives *) +(** Printing *) + let prm_print : ml_tactic = function -| [ValExt pp] -> wrap_unit (fun () -> Feedback.msg_notice (get_pp pp)) +| [pp] -> wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) | _ -> assert false let prm_message_of_int : ml_tactic = function @@ -94,11 +168,31 @@ let prm_message_of_int : ml_tactic = function | _ -> assert false let prm_message_of_string : ml_tactic = function -| [ValStr s] -> return (ValExt (Val.Dyn (val_pp, str s))) +| [ValStr s] -> return (ValExt (Val.Dyn (val_pp, str (Bytes.to_string s)))) +| _ -> assert false + +let prm_message_of_constr : ml_tactic = function +| [c] -> + pf_apply begin fun env sigma -> + let c = Value.to_constr c in + let pp = Printer.pr_econstr_env env sigma c in + return (ValExt (Val.Dyn (val_pp, pp))) + end | _ -> assert false +let prm_message_concat : ml_tactic = function +| [m1; m2] -> + let m1 = Value.to_pp m1 in + let m2 = Value.to_pp m2 in + return (Value.of_pp (Pp.app m1 m2)) +| _ -> assert false + +(** Array *) + let prm_array_make : ml_tactic = function -| [ValInt n; x] -> wrap (fun () -> ValBlk (0, Array.make n x)) +| [ValInt n; x] -> + (** FIXME: wrap exception *) + wrap (fun () -> ValBlk (0, Array.make n x)) | _ -> assert false let prm_array_length : ml_tactic = function @@ -106,31 +200,214 @@ let prm_array_length : ml_tactic = function | _ -> assert false let prm_array_set : ml_tactic = function -| [ValBlk (_, v); ValInt n; x] -> wrap_unit (fun () -> v.(n) <- x) +| [ValBlk (_, v); ValInt n; x] -> + (** FIXME: wrap exception *) + wrap_unit (fun () -> v.(n) <- x) | _ -> assert false let prm_array_get : ml_tactic = function -| [ValBlk (_, v); ValInt n] -> wrap (fun () -> v.(n)) +| [ValBlk (_, v); ValInt n] -> + (** FIXME: wrap exception *) + wrap (fun () -> v.(n)) +| _ -> assert false + +(** Int *) + +let prm_int_equal : ml_tactic = function +| [m; n] -> + return (Value.of_bool (Value.to_int m == Value.to_int n)) +| _ -> assert false + +let binop f : ml_tactic = function +| [m; n] -> return (Value.of_int (f (Value.to_int m) (Value.to_int n))) +| _ -> assert false + +let prm_int_compare args = binop Int.compare args +let prm_int_add args = binop (+) args +let prm_int_sub args = binop (-) args +let prm_int_mul args = binop ( * ) args + +let prm_int_neg : ml_tactic = function +| [m] -> return (Value.of_int (~- (Value.to_int m))) +| _ -> assert false + +(** String *) + +let prm_string_make : ml_tactic = function +| [n; c] -> + let n = Value.to_int n in + let c = Value.to_char c in + (** FIXME: wrap exception *) + wrap (fun () -> Value.of_string (Bytes.make n c)) +| _ -> assert false + +let prm_string_length : ml_tactic = function +| [s] -> + return (Value.of_int (Bytes.length (Value.to_string s))) +| _ -> assert false + +let prm_string_set : ml_tactic = function +| [s; n; c] -> + let s = Value.to_string s in + let n = Value.to_int n in + let c = Value.to_char c in + (** FIXME: wrap exception *) + wrap_unit (fun () -> Bytes.set s n c) +| _ -> assert false + +let prm_string_get : ml_tactic = function +| [s; n] -> + let s = Value.to_string s in + let n = Value.to_int n in + (** FIXME: wrap exception *) + wrap (fun () -> Value.of_char (Bytes.get s n)) +| _ -> assert false + +(** Error *) + +let prm_throw : ml_tactic = function +| [e] -> + let (e, info) = Value.to_exn e in + Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) +| _ -> assert false + +(** Control *) + +(** exn -> 'a *) +let prm_zero : ml_tactic = function +| [e] -> + let (e, info) = Value.to_exn e in + Proofview.tclZERO ~info e +| _ -> assert false + +(** exn -> 'a *) +let prm_plus : ml_tactic = function +| [x; k] -> + Proofview.tclOR (thaw x) (fun e -> interp_app k [Value.of_exn e]) +| _ -> assert false + +(** (unit -> 'a) -> 'a *) +let prm_once : ml_tactic = function +| [f] -> Proofview.tclONCE (thaw f) +| _ -> assert false + +(** (unit -> unit) list -> unit *) +let prm_dispatch : ml_tactic = function +| [l] -> + let l = Value.to_list l in + let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in + Proofview.tclDISPATCH l >>= fun () -> return v_unit +| _ -> assert false + +(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) +let prm_extend : ml_tactic = function +| [lft; tac; rgt] -> + let lft = Value.to_list lft in + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let tac = Proofview.tclIGNORE (thaw tac) in + let rgt = Value.to_list rgt in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in + Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit | _ -> assert false +(** (unit -> unit) -> unit *) +let prm_enter : ml_tactic = function +| [f] -> + let f = Proofview.tclIGNORE (thaw f) in + Proofview.tclINDEPENDENT f >>= fun () -> return v_unit +| _ -> assert false + +(** int -> int -> (unit -> 'a) -> 'a *) +let prm_focus : ml_tactic = function +| [i; j; tac] -> + let i = Value.to_int i in + let j = Value.to_int j in + Proofview.tclFOCUS i j (thaw tac) +| _ -> assert false + +(** unit -> unit *) +let prm_shelve : ml_tactic = function +| [_] -> Proofview.shelve >>= fun () -> return v_unit +| _ -> assert false + +(** unit -> unit *) +let prm_shelve_unifiable : ml_tactic = function +| [_] -> Proofview.shelve_unifiable >>= fun () -> return v_unit +| _ -> assert false + +(** unit -> constr *) +let prm_goal : ml_tactic = function +| [_] -> + Proofview.Goal.enter_one { enter = fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + return (Value.of_constr concl) + } +| _ -> assert false + +(** ident -> constr *) +let prm_hyp : ml_tactic = function +| [id] -> + let id = Value.to_ident id in + pf_apply begin fun env _ -> + let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in + if mem then return (Value.of_constr (EConstr.mkVar id)) + else Tacticals.New.tclZEROMSG + (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (** FIXME: Do something more sensible *) + end +| _ -> assert false + +(** (unit -> constr) -> unit *) +let prm_refine : ml_tactic = function +| [c] -> + let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in + Proofview.Goal.nf_enter { enter = fun gl -> + Refine.generic_refine ~unsafe:false c gl + } >>= fun () -> return v_unit +| _ -> assert false + + (** Registering *) let () = Tac2env.define_primitive (pname "print") prm_print let () = Tac2env.define_primitive (pname "message_of_string") prm_message_of_string let () = Tac2env.define_primitive (pname "message_of_int") prm_message_of_int +let () = Tac2env.define_primitive (pname "message_of_constr") prm_message_of_constr +let () = Tac2env.define_primitive (pname "message_concat") prm_message_concat let () = Tac2env.define_primitive (pname "array_make") prm_array_make let () = Tac2env.define_primitive (pname "array_length") prm_array_length let () = Tac2env.define_primitive (pname "array_get") prm_array_get let () = Tac2env.define_primitive (pname "array_set") prm_array_set -(** ML types *) +let () = Tac2env.define_primitive (pname "string_make") prm_string_make +let () = Tac2env.define_primitive (pname "string_length") prm_string_length +let () = Tac2env.define_primitive (pname "string_get") prm_string_get +let () = Tac2env.define_primitive (pname "string_set") prm_string_set + +let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal +let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare +let () = Tac2env.define_primitive (pname "int_neg") prm_int_neg +let () = Tac2env.define_primitive (pname "int_add") prm_int_add +let () = Tac2env.define_primitive (pname "int_sub") prm_int_sub +let () = Tac2env.define_primitive (pname "int_mul") prm_int_mul + +let () = Tac2env.define_primitive (pname "throw") prm_throw + +let () = Tac2env.define_primitive (pname "zero") prm_zero +let () = Tac2env.define_primitive (pname "plus") prm_plus +let () = Tac2env.define_primitive (pname "once") prm_once +let () = Tac2env.define_primitive (pname "dispatch") prm_dispatch +let () = Tac2env.define_primitive (pname "extend") prm_extend +let () = Tac2env.define_primitive (pname "enter") prm_enter + +let () = Tac2env.define_primitive (pname "focus") prm_focus +let () = Tac2env.define_primitive (pname "shelve") prm_shelve +let () = Tac2env.define_primitive (pname "shelve_unifiable") prm_shelve_unifiable +let () = Tac2env.define_primitive (pname "goal") prm_goal +let () = Tac2env.define_primitive (pname "hyp") prm_hyp +let () = Tac2env.define_primitive (pname "refine") prm_refine -let val_tag t = match val_tag t with -| Val.Base t -> t -| _ -> assert false - -let tag_constr = val_tag (topwit Stdarg.wit_constr) +(** ML types *) let constr_flags () = let open Pretyping in @@ -142,28 +419,15 @@ let constr_flags () = expand_evars = true } -(** In Ltac2, the notion of "current environment" only makes sense when there is - at most one goal under focus. Contrarily to Ltac1, instead of dynamically - focussing when we need it, we raise a non-backtracking error when it does - not make sense. *) -exception NonFocussedGoal - -let () = register_handler begin function -| NonFocussedGoal -> str "Several goals under focus" -| _ -> raise Unhandled -end - -let pf_apply f = - Proofview.Goal.goals >>= function - | [] -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - f env sigma - | [gl] -> - gl >>= fun gl -> - f (Proofview.Goal.env gl) (Tacmach.New.project gl) - | _ :: _ :: _ -> - Proofview.tclLIFT (Proofview.NonLogical.raise NonFocussedGoal) +let open_constr_no_classes_flags () = + let open Pretyping in + { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Pfedit.solve_by_implicit_tactic (); + fail_evar = false; + expand_evars = true + } (** Embed all Ltac2 data into Values *) let to_lvar ist = @@ -172,17 +436,40 @@ let to_lvar ist = let lfun = Id.Map.map map ist in { empty_lvar with ltac_genargs = lfun } -let () = +let interp_constr flags ist (c, _) = let open Pretyping in - let interp ist (c, _) = pf_apply begin fun env sigma -> + pf_apply begin fun env sigma -> + Proofview.V82.wrap_exceptions begin fun () -> let ist = to_lvar ist in - let (sigma, c) = understand_ltac (constr_flags ()) env sigma ist WithoutTypeConstraint c in - let c = Val.Dyn (tag_constr, c) in + let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in + let c = Val.Dyn (val_constr, c) in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c - end in + end + end + +let () = + let open Pretyping in + let interp ist c = interp_constr (constr_flags ()) ist c in let obj = { ml_type = t_constr; ml_interp = interp; } in define_ml_object Stdarg.wit_constr obj + +let () = + let open Pretyping in + let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let obj = { + ml_type = t_constr; + ml_interp = interp; + } in + define_ml_object Stdarg.wit_open_constr obj + +let () = + let interp _ id = return (Val.Dyn (val_ident, id)) in + let obj = { + ml_type = t_ident; + ml_interp = interp; + } in + define_ml_object Stdarg.wit_ident obj diff --git a/tac2core.mli b/tac2core.mli index 14bde483c1..27144bc6e2 100644 --- a/tac2core.mli +++ b/tac2core.mli @@ -22,13 +22,32 @@ end (** {5 Ltac2 FFI} *) +(** These functions allow to convert back and forth between OCaml and Ltac2 + data representation. The [to_*] functions raise an anomaly whenever the data + has not expected shape. *) + module Value : sig val of_unit : unit -> valexpr val to_unit : valexpr -> unit +val of_int : int -> valexpr +val to_int : valexpr -> int + +val of_bool : bool -> valexpr +val to_bool : valexpr -> bool + +val of_char : char -> valexpr +val to_char : valexpr -> char + val of_list : valexpr list -> valexpr val to_list : valexpr -> valexpr list +val of_constr : EConstr.t -> valexpr +val to_constr : valexpr -> EConstr.t + +val of_exn : Exninfo.iexn -> valexpr +val to_exn : valexpr -> Exninfo.iexn + end diff --git a/tac2entries.ml b/tac2entries.ml index 4098324f12..93ad0ceb0b 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -338,8 +338,7 @@ let register_prim_alg name params def = let def = { typdef_local = false; typdef_expr = def } in ignore (Lib.add_leaf id (inTypDef def)) -let coq_prefix = DirPath.make (List.map Id.of_string ["Ltac2"; "ltac2"; "Coq"]) -let coq_def n = KerName.make2 (MPfile coq_prefix) (Label.make n) +let coq_def n = KerName.make2 Tac2env.coq_prefix (Label.make n) let t_list = coq_def "list" diff --git a/tac2env.ml b/tac2env.ml index bdb8f41ef8..17c70d2e44 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -203,3 +203,8 @@ module MLType = Genarg.Register(MLTypeObj) let define_ml_object t tpe = MLType.register0 t tpe let interp_ml_object t = MLType.obj t + +(** Absolute paths *) + +let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "ltac2"; "Coq"])) diff --git a/tac2env.mli b/tac2env.mli index bcfa70487a..96174e8c92 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -95,3 +95,8 @@ type 'a ml_object = { val define_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object -> unit val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object + +(** {5 Absolute paths} *) + +val coq_prefix : ModPath.t +(** Path where primitive datatypes are defined in Ltac2 plugin. *) diff --git a/tac2expr.mli b/tac2expr.mli index b9b649e481..c3c1e56dea 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -131,7 +131,7 @@ type valexpr = (** Immediate integers *) | ValBlk of tag * valexpr array (** Structured blocks *) -| ValStr of string +| ValStr of Bytes.t (** Strings *) | ValCls of closure (** Closures *) diff --git a/tac2intern.ml b/tac2intern.ml index 10fcde6efa..23f8325da8 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -18,8 +18,7 @@ open Tac2expr (** Hardwired types and constants *) -let coq_prefix = DirPath.make (List.map Id.of_string ["Ltac2"; "ltac2"; "Coq"]) -let coq_type n = KerName.make2 (MPfile coq_prefix) (Label.make n) +let coq_type n = KerName.make2 Tac2env.coq_prefix (Label.make n) let t_int = coq_type "int" let t_string = coq_type "string" diff --git a/tac2interp.ml b/tac2interp.ml index fedbb13e7d..d508b0c967 100644 --- a/tac2interp.ml +++ b/tac2interp.ml @@ -15,6 +15,8 @@ open Tac2expr exception LtacError of KerName.t * valexpr +let val_exn = Geninterp.Val.create "ltac2:exn" + type environment = valexpr Id.Map.t let empty_environment = Id.Map.empty @@ -35,7 +37,7 @@ let return = Proofview.tclUNIT let rec interp ist = function | GTacAtm (AtmInt n) -> return (ValInt n) -| GTacAtm (AtmStr s) -> return (ValStr s) +| GTacAtm (AtmStr s) -> return (ValStr (Bytes.of_string s)) | GTacVar id -> return (get_var ist id) | GTacRef qid -> return (get_ref ist qid) | GTacFun (ids, e) -> @@ -44,7 +46,7 @@ let rec interp ist = function | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - interp_app ist f args + interp_app f args | GTacLet (false, el, e) -> let fold accu (na, e) = interp ist e >>= fun e -> @@ -94,11 +96,11 @@ let rec interp ist = function let tpe = Tac2env.interp_ml_object tag in tpe.Tac2env.ml_interp ist e >>= fun e -> return (ValExt e) -and interp_app ist f args = match f with +and interp_app f args = match f with | ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> let rec push ist ids args = match ids, args with | [], [] -> interp ist e - | [], _ :: _ -> interp ist e >>= fun f -> interp_app ist f args + | [], _ :: _ -> interp ist e >>= fun f -> interp_app f args | _ :: _, [] -> let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in return (ValCls cls) diff --git a/tac2interp.mli b/tac2interp.mli index b11ee36012..7fe78a9460 100644 --- a/tac2interp.mli +++ b/tac2interp.mli @@ -10,10 +10,18 @@ open Genarg open Names open Tac2expr -exception LtacError of KerName.t * valexpr - type environment = valexpr Id.Map.t val empty_environment : environment val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic + +val interp_app : valexpr -> valexpr list -> valexpr Proofview.tactic + +(** {5 Exceptions} *) + +exception LtacError of KerName.t * valexpr +(** Ltac2-defined exceptions *) + +val val_exn : Exninfo.iexn Geninterp.Val.typ +(** Toplevel representation of Ltac2 exceptions *) diff --git a/vo.itarget b/vo.itarget index 776404ad79..5777585681 100644 --- a/vo.itarget +++ b/vo.itarget @@ -1 +1,8 @@ +Init.vo +Int.vo +String.vo +Array.vo +Control.vo +Message.vo +Constr.vo Ltac2.vo -- cgit v1.2.3 From d54eacd7b48b9cb0212d5a7cef2ea428469df74a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Dec 2016 14:44:05 +0100 Subject: Allow the embedding of Ltac2 terms in constrs via the ltac2:(...) syntax. --- g_ltac2.ml4 | 10 ++++++++++ tac2core.ml | 14 ++++++++++++++ tac2env.ml | 4 ++++ tac2env.mli | 4 ++++ tac2intern.ml | 17 +++++++++++++++++ 5 files changed, 49 insertions(+) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index ff3d79bbae..1dbd223b22 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -11,6 +11,8 @@ open Util open Genarg open Names open Pcoq +open Constrexpr +open Misctypes open Tac2expr open Ltac_plugin @@ -190,6 +192,14 @@ GEXTEND Gram ; END +GEXTEND Gram + Pcoq.Constr.operconstr: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + ; +END + let pr_ltac2entry _ = mt () (** FIXME *) let pr_ltac2expr _ = mt () (** FIXME *) diff --git a/tac2core.ml b/tac2core.ml index fd998151fd..c18b6032a6 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -473,3 +473,17 @@ let () = ml_interp = interp; } in define_ml_object Stdarg.wit_ident obj + +let () = + let interp ist env sigma concl tac = + let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = + match Val.eq tag val_valexpr with + | None -> accu + | Some Refl -> Id.Map.add id v accu + in + let ist = Id.Map.fold fold ist Id.Map.empty in + let tac = Proofview.tclIGNORE (interp ist tac) in + let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in + (EConstr.of_constr c, sigma) + in + Pretyping.register_constr_interp0 wit_ltac2 interp diff --git a/tac2env.ml b/tac2env.ml index 17c70d2e44..a058d764e7 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -208,3 +208,7 @@ let interp_ml_object t = MLType.obj t let coq_prefix = MPfile (DirPath.make (List.map Id.of_string ["Init"; "ltac2"; "Coq"])) + +(** Generic arguments *) + +let wit_ltac2 = Genarg.make0 "ltac2" diff --git a/tac2env.mli b/tac2env.mli index 96174e8c92..4d2a1645ea 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -100,3 +100,7 @@ val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object val coq_prefix : ModPath.t (** Path where primitive datatypes are defined in Ltac2 plugin. *) + +(** {5 Generic arguments} *) + +val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type diff --git a/tac2intern.ml b/tac2intern.ml index 23f8325da8..bc15b567d4 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -1054,3 +1054,20 @@ let subst_quant_typedef subst (prm, def as qdef) = let subst_type_scheme subst (prm, t as sch) = let t' = subst_type subst t in if t' == t then sch else (prm, t') + +(** Registering *) + +let () = + let open Genintern in + let intern ist tac = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> empty_env () + | Some env -> env + in + let loc = loc_of_tacexpr tac in + let (tac, t) = intern_rec env tac in + let () = check_elt_unit loc env t in + (ist, tac) + in + Genintern.register_intern0 wit_ltac2 intern +let () = Genintern.register_subst0 wit_ltac2 subst_expr -- cgit v1.2.3 From f0b3169d5494074d159f94ed1d3d482037990a58 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Dec 2016 18:14:23 +0100 Subject: Towards a proper printing of Ltac2 data structures. --- g_ltac2.ml4 | 2 +- ltac2_plugin.mlpack | 1 + tac2entries.ml | 13 ++- tac2env.ml | 42 ++++++++- tac2env.mli | 5 +- tac2expr.mli | 4 +- tac2intern.ml | 69 +++++++++----- tac2intern.mli | 2 - tac2interp.ml | 7 +- tac2print.ml | 266 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tac2print.mli | 28 ++++++ 11 files changed, 401 insertions(+), 38 deletions(-) create mode 100644 tac2print.ml create mode 100644 tac2print.mli diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index 1dbd223b22..9384584f19 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -56,7 +56,7 @@ GEXTEND Gram [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, qid) | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, qid, r) - | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "0" SEP "," -> CTacTup (!@loc, e0 :: el) ] + | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> CTacTup (!@loc, e0 :: el) ] | "0" [ "("; a = tac2expr LEVEL "5"; ")" -> a | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) diff --git a/ltac2_plugin.mlpack b/ltac2_plugin.mlpack index 561bd0eb0a..3d87a8cddb 100644 --- a/ltac2_plugin.mlpack +++ b/ltac2_plugin.mlpack @@ -1,4 +1,5 @@ Tac2env +Tac2print Tac2intern Tac2interp Tac2entries diff --git a/tac2entries.ml b/tac2entries.ml index 93ad0ceb0b..f4b3147c48 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -15,6 +15,7 @@ open Libobject open Nametab open Tac2env open Tac2expr +open Tac2print open Tac2intern open Vernacexpr @@ -303,11 +304,17 @@ let print_ltac ref = in match kn with | TacConstant kn -> - let (_, (_, t)) = Tac2env.interp_global kn in - Feedback.msg_notice (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype t) + let (e, _, (_, t)) = Tac2env.interp_global kn in + let name = int_name () in + Feedback.msg_notice ( + hov 0 ( + hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ + hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + ) + ) | TacConstructor kn -> let _ = Tac2env.interp_constructor kn in - Feedback.msg_notice (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid) + Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) (** Calling tactics *) diff --git a/tac2env.ml b/tac2env.ml index a058d764e7..18519a6ce1 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -73,7 +73,7 @@ let define_global kn e = let interp_global kn = let (e, t) = KNmap.find kn ltac_state.contents.ltac_tactics in - (eval_pure e, t) + (e, eval_pure e, t) let define_constructor kn t = let state = !ltac_state in @@ -139,21 +139,33 @@ module RfTab = Nametab.Make(FullPath)(TacRef) type nametab = { tab_ltac : RfTab.t; + tab_ltac_rev : full_path KNmap.t * full_path KNmap.t; tab_type : KnTab.t; + tab_type_rev : full_path KNmap.t; tab_proj : KnTab.t; + tab_proj_rev : full_path KNmap.t; } let empty_nametab = { tab_ltac = RfTab.empty; + tab_ltac_rev = (KNmap.empty, KNmap.empty); tab_type = KnTab.empty; + tab_type_rev = KNmap.empty; tab_proj = KnTab.empty; + tab_proj_rev = KNmap.empty; } let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" let push_ltac vis sp kn = let tab = !nametab in - nametab := { tab with tab_ltac = RfTab.push vis sp kn tab.tab_ltac } + let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in + let (constant_map, constructor_map) = tab.tab_ltac_rev in + let tab_ltac_rev = match kn with + | TacConstant c -> (KNmap.add c sp constant_map, constructor_map) + | TacConstructor c -> (constant_map, KNmap.add c sp constructor_map) + in + nametab := { tab with tab_ltac; tab_ltac_rev } let locate_ltac qid = let tab = !nametab in @@ -163,9 +175,19 @@ let locate_extended_all_ltac qid = let tab = !nametab in RfTab.find_prefixes qid tab.tab_ltac +let shortest_qualid_of_ltac kn = + let tab = !nametab in + let sp = match kn with + | TacConstant c -> KNmap.find c (fst tab.tab_ltac_rev) + | TacConstructor c -> KNmap.find c (snd tab.tab_ltac_rev) + in + RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + let push_type vis sp kn = let tab = !nametab in - nametab := { tab with tab_type = KnTab.push vis sp kn tab.tab_type } + let tab_type = KnTab.push vis sp kn tab.tab_type in + let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in + nametab := { tab with tab_type; tab_type_rev } let locate_type qid = let tab = !nametab in @@ -175,9 +197,16 @@ let locate_extended_all_type qid = let tab = !nametab in KnTab.find_prefixes qid tab.tab_type +let shortest_qualid_of_type kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_type_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_type + let push_projection vis sp kn = let tab = !nametab in - nametab := { tab with tab_proj = KnTab.push vis sp kn tab.tab_proj } + let tab_proj = KnTab.push vis sp kn tab.tab_proj in + let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in + nametab := { tab with tab_proj; tab_proj_rev } let locate_projection qid = let tab = !nametab in @@ -187,6 +216,11 @@ let locate_extended_all_projection qid = let tab = !nametab in KnTab.find_prefixes qid tab.tab_proj +let shortest_qualid_of_projection kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_proj_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj + type 'a ml_object = { ml_type : type_constant; ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; diff --git a/tac2env.mli b/tac2env.mli index 4d2a1645ea..16232ec810 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -17,7 +17,7 @@ open Tac2expr (** {5 Toplevel definition of values} *) val define_global : ltac_constant -> (glb_tacexpr * type_scheme) -> unit -val interp_global : ltac_constant -> (valexpr * type_scheme) +val interp_global : ltac_constant -> (glb_tacexpr * valexpr * type_scheme) (** {5 Toplevel definition of types} *) @@ -69,14 +69,17 @@ type tacref = val push_ltac : visibility -> full_path -> tacref -> unit val locate_ltac : qualid -> tacref val locate_extended_all_ltac : qualid -> tacref list +val shortest_qualid_of_ltac : tacref -> qualid val push_type : visibility -> full_path -> type_constant -> unit val locate_type : qualid -> type_constant val locate_extended_all_type : qualid -> type_constant list +val shortest_qualid_of_type : type_constant -> qualid val push_projection : visibility -> full_path -> ltac_projection -> unit val locate_projection : qualid -> ltac_projection val locate_extended_all_projection : qualid -> ltac_projection list +val shortest_qualid_of_projection : ltac_projection -> qualid (** {5 Toplevel definitions of ML tactics} *) diff --git a/tac2expr.mli b/tac2expr.mli index c3c1e56dea..7a2c684fbc 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -105,8 +105,8 @@ type glb_tacexpr = | GTacArr of glb_tacexpr list | GTacCst of type_constant * int * glb_tacexpr list | GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array -| GTacPrj of glb_tacexpr * int -| GTacSet of glb_tacexpr * int * glb_tacexpr +| GTacPrj of type_constant * glb_tacexpr * int +| GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr | GTacExt of glob_generic_argument | GTacPrm of ml_tactic_name * glb_tacexpr list diff --git a/tac2intern.ml b/tac2intern.ml index bc15b567d4..350dc4efe6 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -14,6 +14,7 @@ open Names open Libnames open Misctypes open Tac2env +open Tac2print open Tac2expr (** Hardwired types and constants *) @@ -50,6 +51,7 @@ sig val add : key -> 'a -> 'a t -> 'a t val mem : key -> 'a t -> bool val find : key -> 'a t -> 'a + val exists : (key -> 'a -> bool) -> 'a t -> bool end end = @@ -143,6 +145,31 @@ let empty_env () = { env_rec = Id.Map.empty; } +let env_name env = + (** Generate names according to a provided environment *) + let mk num = + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + name + in + let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in + let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in + let vars = ref vars in + let rec fresh n = + let name = mk n in + if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) + else name + in + fun n -> + if UF.Map.mem n !vars then UF.Map.find n !vars + else + let ans = fresh 0 in + let () = vars := UF.Map.add n ans !vars in + ans + let ltac2_env : environment Genintern.Store.field = Genintern.Store.field () @@ -311,19 +338,12 @@ let rec unify env t1 t2 = match kind env t1, kind env t2 with else raise (CannotUnify (t1, t2)) | _ -> raise (CannotUnify (t1, t2)) -(** FIXME *) -let rec pr_glbtype = function -| GTypVar n -> str "?" -| GTypRef (kn, tl) -> - KerName.print kn ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_glbtype tl ++ str ")" -| GTypArrow (t1, t2) -> str "Arr(" ++ pr_glbtype t1 ++ str ", " ++ pr_glbtype t2 ++ str ")" -| GTypTuple tl -> str "Tup(" ++ prlist_with_sep (fun () -> str ", ") pr_glbtype tl ++ str ")" - let unify loc env t1 t2 = try unify env t1 t2 with CannotUnify (u1, u2) -> - user_err ~loc (str "This expression has type " ++ pr_glbtype t1 ++ - str " but an expression what expected of type " ++ pr_glbtype t2) + let name = env_name env in + user_err ~loc (str "This expression has type " ++ pr_glbtype name t1 ++ + str " but an expression what expected of type " ++ pr_glbtype name t2) (** Term typing *) @@ -418,13 +438,15 @@ let check_elt_empty loc env t = match kind env t with | GTypVar _ -> user_err ~loc (str "Cannot infer an empty type for this expression") | GTypArrow _ | GTypTuple _ -> - user_err ~loc (str "Type " ++ pr_glbtype t ++ str " is not an empty type") + let name = env_name env in + user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") | GTypRef (kn, _) -> let def = Tac2env.interp_type kn in match def with | _, GTydAlg [] -> kn | _ -> - user_err ~loc (str "Type " ++ pr_glbtype t ++ str " is not an empty type") + let name = env_name env in + user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") let check_unit ?loc t = let maybe_unit = match t with @@ -475,11 +497,11 @@ let intern_atm env = function let invalid_pattern ~loc kn t = let pt = match t with - | GCaseAlg kn' -> KerName.print kn + | GCaseAlg kn' -> pr_typref kn | GCaseTuple n -> str "tuple" in user_err ~loc (str "Invalid pattern, expected a pattern for type " ++ - KerName.print kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) + pr_typref kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) type pattern_kind = | PKind_empty @@ -527,7 +549,7 @@ let rec intern_rec env = function let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) | ArgArg (TacConstant kn) -> - let (_, sch) = Tac2env.interp_global kn in + let (_, _, sch) = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) | ArgArg (TacConstructor kn) -> intern_constructor env (fst qid) kn [] @@ -542,6 +564,7 @@ let rec intern_rec env = function (env, na :: bnd, t :: tl) in let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in + let bnd = List.rev bnd in let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in (GTacFun (bnd, e), t) @@ -637,7 +660,7 @@ let rec intern_rec env = function let () = unify loc env t exp in let substf i = GTypVar subst.(i) in let ret = subst_type substf pinfo.pdata_ptyp in - (GTacPrj (e, pinfo.pdata_indx), ret) + (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) | CTacSet (loc, e, proj, r) -> let pinfo = get_projection proj in let () = @@ -652,7 +675,7 @@ let rec intern_rec env = function let substf i = GTypVar subst.(i) in let ret = subst_type substf pinfo.pdata_ptyp in let r = intern_rec_with_constraint env r ret in - (GTacSet (e, pinfo.pdata_indx, r), GTypRef (t_unit, [])) + (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (t_unit, [])) | CTacExt (loc, ext) -> let open Genintern in let GenArg (Rawwit tag, _) = ext in @@ -899,7 +922,7 @@ and intern_record env loc fs = several times") else user_err ~loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ - pertain to record definition " ++ KerName.print pinfo.pdata_type) + pertain to record definition " ++ pr_typref pinfo.pdata_type) in let () = List.iter iter fs in let () = match Array.findi (fun _ o -> Option.is_empty o) args with @@ -1017,13 +1040,15 @@ let rec subst_expr subst e = match e with let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in let ci' = subst_case_info subst ci in GTacCse (subst_expr subst e, ci', cse0', cse1') -| GTacPrj (e, p) as e0 -> +| GTacPrj (kn, e, p) as e0 -> + let kn' = subst_kn subst kn in let e' = subst_expr subst e in - if e' == e then e0 else GTacPrj (e', p) -| GTacSet (e, p, r) as e0 -> + if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) +| GTacSet (kn, e, p, r) as e0 -> + let kn' = subst_kn subst kn in let e' = subst_expr subst e in let r' = subst_expr subst r in - if e' == e && r' == r then e0 else GTacSet (e', p, r') + if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') | GTacExt ext -> let ext' = Genintern.generic_substitute subst ext in if ext' == ext then e else GTacExt ext' diff --git a/tac2intern.mli b/tac2intern.mli index a6be01d647..6633792e7e 100644 --- a/tac2intern.mli +++ b/tac2intern.mli @@ -26,5 +26,3 @@ val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef val subst_type_scheme : substitution -> type_scheme -> type_scheme - -val pr_glbtype : 'a glb_typexpr -> Pp.std_ppcmds diff --git a/tac2interp.ml b/tac2interp.ml index d508b0c967..f93c8cb5fe 100644 --- a/tac2interp.ml +++ b/tac2interp.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Pp open CErrors open Genarg @@ -30,7 +31,7 @@ let get_var ist id = anomaly (str "Unbound variable " ++ Id.print id) let get_ref ist kn = - try fst (Tac2env.interp_global kn) with Not_found -> + try pi2 (Tac2env.interp_global kn) with Not_found -> anomaly (str "Unbound reference" ++ KerName.print kn) let return = Proofview.tclUNIT @@ -82,9 +83,9 @@ let rec interp ist = function return (ValBlk (n, Array.of_list el)) | GTacCse (e, _, cse0, cse1) -> interp ist e >>= fun e -> interp_case ist e cse0 cse1 -| GTacPrj (e, p) -> +| GTacPrj (_, e, p) -> interp ist e >>= fun e -> interp_proj ist e p -| GTacSet (e, p, r) -> +| GTacSet (_, e, p, r) -> interp ist e >>= fun e -> interp ist r >>= fun r -> interp_set ist e p r diff --git a/tac2print.ml b/tac2print.ml new file mode 100644 index 0000000000..96d0ceb875 --- /dev/null +++ b/tac2print.ml @@ -0,0 +1,266 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* str "'" ++ str (pr n) + | GTypRef (kn, []) -> pr_typref kn + | GTypRef (kn, [t]) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (pr_glbtype lvl t ++ spc () ++ pr_typref kn) + | GTypRef (kn, tl) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) + | GTypArrow (t1, t2) -> + let paren = match lvl with + | T5_r -> fun x -> x + | T5_l | T2 | T1 | T0 -> paren + in + paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) + | GTypTuple tl -> + let paren = match lvl with + | T5_r | T5_l -> fun x -> x + | T2 | T1 | T0 -> paren + in + paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) + in + hov 0 (pr_glbtype lvl c) + +let pr_glbtype pr c = pr_glbtype_gen pr T5_r c + +let int_name () = + let vars = ref Int.Map.empty in + fun n -> + if Int.Map.mem n !vars then Int.Map.find n !vars + else + let num = Int.Map.cardinal !vars in + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + let () = vars := Int.Map.add n name !vars in + name + +(** Term printing *) + +let pr_constructor kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstructor kn)) + +let pr_projection kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) + +type exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +let pr_atom = function +| AtmInt n -> int n +| AtmStr s -> qstring s + +let pr_name = function +| Name id -> Id.print id +| Anonymous -> str "_" + +let find_constructor n empty def = + let rec find n = function + | [] -> assert false + | (id, []) :: rem -> + if empty then + if Int.equal n 0 then id + else find (pred n) rem + else find n rem + | (id, _ :: _) :: rem -> + if not empty then + if Int.equal n 0 then id + else find (pred n) rem + else find n rem + in + find n def + +let order_branches cbr nbr def = + let rec order cidx nidx def = match def with + | [] -> [] + | (id, []) :: rem -> + let ans = order (succ cidx) nidx rem in + (id, [], cbr.(cidx)) :: ans + | (id, _ :: _) :: rem -> + let ans = order cidx (succ nidx) rem in + let (vars, e) = nbr.(nidx) in + (id, Array.to_list vars, e) :: ans + in + order 0 0 def + +let pr_glbexpr_gen lvl c = + let rec pr_glbexpr lvl = function + | GTacAtm atm -> pr_atom atm + | GTacVar id -> Id.print id + | GTacRef gr -> + let qid = shortest_qualid_of_ltac (TacConstant gr) in + Libnames.pr_qualid qid + | GTacFun (nas, c) -> + let nas = pr_sequence pr_name nas in + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + paren (str "fun" ++ spc () ++ nas ++ spc () ++ str "=>" ++ spc () ++ + hov 0 (pr_glbexpr E5 c)) + | GTacApp (c, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (pr_glbexpr E1 c) ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl) + | GTacLet (mut, bnd, e) -> + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + let mut = if mut then str "rec" ++ spc () else mt () in + let pr_bnd (na, e) = + pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () + in + let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in + paren (str "let" ++ spc () ++ mut ++ bnd ++ str "in" ++ spc () ++ pr_glbexpr E5 e) + | GTacTup cl -> + let paren = match lvl with + | E0 | E1 -> paren + | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) + | GTacArr cl -> + mt () (** FIXME when implemented *) + | GTacCst (tpe, n, cl) -> + begin match Tac2env.interp_type tpe with + | _, GTydAlg def -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let id = find_constructor n (List.is_empty cl) def in + let kn = change_kn_label tpe id in + let cl = match cl with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl + in + paren (pr_constructor kn ++ cl) + | _, GTydRec def -> + let args = List.combine def cl in + let pr_arg ((id, _, _), arg) = + let kn = change_kn_label tpe id in + pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg + in + let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in + str "{" ++ spc () ++ args ++ spc () ++ str "}" + | _, GTydDef _ -> assert false + end + | GTacCse (e, info, cst_br, ncst_br) -> + let e = pr_glbexpr E5 e in + let br = match info with + | GCaseAlg kn -> + let def = match Tac2env.interp_type kn with + | _, GTydAlg def -> def + | _, GTydDef _ | _, GTydRec _ -> assert false + in + let br = order_branches cst_br ncst_br def in + let pr_branch (cstr, vars, p) = + let cstr = change_kn_label kn cstr in + let cstr = pr_constructor cstr in + let vars = match vars with + | [] -> mt () + | _ -> spc () ++ pr_sequence pr_name vars + in + hov 0 (str "|" ++ spc () ++ cstr ++ vars ++ spc () ++ str "=>" ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + prlist pr_branch br + | GCaseTuple n -> + let (vars, p) = ncst_br.(0) in + let p = pr_glbexpr E5 p in + let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in + str "|" ++ spc () ++ paren vars ++ spc () ++ str "=>" ++ spc () ++ p + in + hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") + | GTacPrj (kn, e, n) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + e ++ str "." ++ paren proj + | GTacSet (kn, e, n, r) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + let r = pr_glbexpr E1 r in + e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r + | GTacExt arg -> + let GenArg (Glbwit tag, arg) = arg in + let name = match tag with + | ExtraArg tag -> ArgT.repr tag + | _ -> assert false + in + str name ++ str ":" ++ paren (Genprint.glb_print tag arg) + | GTacPrm (prm, args) -> + let args = match args with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args + in + str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ + qstring prm.mltac_tactic ++ args + in + hov 0 (pr_glbexpr lvl c) + +let pr_glbexpr c = + pr_glbexpr_gen E5 c diff --git a/tac2print.mli b/tac2print.mli new file mode 100644 index 0000000000..94555a4c95 --- /dev/null +++ b/tac2print.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds +val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> std_ppcmds + +(** {5 Printing expressions} *) + +val pr_constructor : ltac_constructor -> std_ppcmds +val pr_projection : ltac_projection -> std_ppcmds +val pr_glbexpr : glb_tacexpr -> std_ppcmds + +(** {5 Utilities} *) + +val int_name : unit -> (int -> string) +(** Create a function that give names to integers. The names are generated on + the fly, in the order they are encountered. *) -- cgit v1.2.3 From 4c5f635769811be7d5f8b39f699b76ea51388cd4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 8 Dec 2016 09:10:39 +0100 Subject: Merging GTacTuple and GTacCst nodes. --- tac2env.ml | 1 - tac2expr.mli | 3 +-- tac2intern.ml | 31 ++++++++++++++++++------------- tac2interp.ml | 4 +--- tac2print.ml | 4 ++-- 5 files changed, 22 insertions(+), 21 deletions(-) diff --git a/tac2env.ml b/tac2env.ml index 18519a6ce1..5e379473c8 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -60,7 +60,6 @@ let rec eval_pure = function eval_pure e | GTacFun (na, e) -> ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e } -| GTacTup el -> ValBlk (0, Array.map_of_list eval_pure el) | GTacCst (_, n, []) -> ValInt n | GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) | GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ | GTacSet _ diff --git a/tac2expr.mli b/tac2expr.mli index 7a2c684fbc..1fac5a2315 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -101,9 +101,8 @@ type glb_tacexpr = | GTacFun of Name.t list * glb_tacexpr | GTacApp of glb_tacexpr * glb_tacexpr list | GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr -| GTacTup of glb_tacexpr list | GTacArr of glb_tacexpr list -| GTacCst of type_constant * int * glb_tacexpr list +| GTacCst of case_info * int * glb_tacexpr list | GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array | GTacPrj of type_constant * glb_tacexpr * int | GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr diff --git a/tac2intern.ml b/tac2intern.ml index 350dc4efe6..c4d2fc277b 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -27,8 +27,8 @@ let t_array = coq_type "array" let t_unit = coq_type "unit" let t_list = coq_type "list" -let c_nil = GTacCst (t_list, 0, []) -let c_cons e el = GTacCst (t_list, 0, [e; el]) +let c_nil = GTacCst (GCaseAlg t_list, 0, []) +let c_cons e el = GTacCst (GCaseAlg t_list, 0, [e; el]) (** Union find *) @@ -358,15 +358,15 @@ let is_pure_constructor kn = let rec is_value = function | GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true | GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false -| GTacTup el -> List.for_all is_value el +| GTacCst (GCaseTuple _, _, el) -> List.for_all is_value el | GTacCst (_, _, []) -> true -| GTacCst (kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacCst (GCaseAlg kn, _, el) -> is_pure_constructor kn && List.for_all is_value el | GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ -> false let is_rec_rhs = function | GTacFun _ -> true | GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ -| GTacSet _ | GTacTup _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacSet _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ | GTacCse _ -> false let rec fv_type f t accu = match t with @@ -612,14 +612,14 @@ let rec intern_rec env = function | CTacLet (loc, true, el, e) -> intern_let_rec env loc el e | CTacTup (loc, []) -> - (GTacTup [], GTypRef (t_unit, [])) + (GTacCst (GCaseAlg t_unit, 0, []), GTypRef (t_unit, [])) | CTacTup (loc, el) -> let fold e (el, tl) = let (e, t) = intern_rec env e in (e :: el, t :: tl) in let (el, tl) = List.fold_right fold el ([], []) in - (GTacTup el, GTypTuple tl) + (GTacCst (GCaseTuple (List.length el), 0, el), GTypTuple tl) | CTacArr (loc, []) -> let id = fresh_id env in (GTacArr [], GTypRef (t_int, [GTypVar id])) @@ -887,7 +887,7 @@ and intern_constructor env loc kn args = let ans = GTypRef (cstr.cdata_type, List.init cstr.cdata_prms (fun i -> GTypVar subst.(i))) in let map arg tpe = intern_rec_with_constraint env arg tpe in let args = List.map2 map args types in - (GTacCst (cstr.cdata_type, cstr.cdata_indx, args), ans) + (GTacCst (GCaseAlg cstr.cdata_type, cstr.cdata_indx, args), ans) else error_nargs_mismatch loc nargs (List.length args) @@ -933,7 +933,7 @@ and intern_record env loc fs = in let args = Array.map_to_list Option.get args in let tparam = List.init params (fun i -> GTypVar subst.(i)) in - (GTacCst (kn, 0, args), GTypRef (kn, tparam)) + (GTacCst (GCaseAlg kn, 0, args), GTypRef (kn, tparam)) let normalize env (count, vars) (t : UF.elt glb_typexpr) = let get_var id = @@ -1029,12 +1029,17 @@ let rec subst_expr subst e = match e with | GTacLet (r, bs, e) -> let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in GTacLet (r, bs, subst_expr subst e) -| GTacTup el -> - GTacTup (List.map (fun e -> subst_expr subst e) el) | GTacArr el -> GTacArr (List.map (fun e -> subst_expr subst e) el) -| GTacCst (kn, n, el) -> - GTacCst (subst_kn subst kn, n, List.map (fun e -> subst_expr subst e) el) +| GTacCst (t, n, el) as e0 -> + let t' = match t with + | GCaseAlg kn -> + let kn' = subst_kn subst kn in + if kn' == kn then t else GCaseAlg kn' + | GCaseTuple _ -> t + in + let el' = List.smartmap (fun e -> subst_expr subst e) el in + if t' == t && el' == el then e0 else GTacCst (t', n, el') | GTacCse (e, ci, cse0, cse1) -> let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in diff --git a/tac2interp.ml b/tac2interp.ml index f93c8cb5fe..cd307e3ae7 100644 --- a/tac2interp.ml +++ b/tac2interp.ml @@ -72,9 +72,7 @@ let rec interp ist = function let iter (_, e) = e.clos_env <- ist in let () = List.iter iter fixs in interp ist e -| GTacTup [] -> - return (ValInt 0) -| GTacTup el | GTacArr el -> +| GTacArr el -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> return (ValBlk (0, Array.of_list el)) | GTacCst (_, n, []) -> return (ValInt n) diff --git a/tac2print.ml b/tac2print.ml index 96d0ceb875..a7f9ed48c8 100644 --- a/tac2print.ml +++ b/tac2print.ml @@ -165,7 +165,7 @@ let pr_glbexpr_gen lvl c = in let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in paren (str "let" ++ spc () ++ mut ++ bnd ++ str "in" ++ spc () ++ pr_glbexpr E5 e) - | GTacTup cl -> + | GTacCst (GCaseTuple _, _, cl) -> let paren = match lvl with | E0 | E1 -> paren | E2 | E3 | E4 | E5 -> fun x -> x @@ -173,7 +173,7 @@ let pr_glbexpr_gen lvl c = paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) | GTacArr cl -> mt () (** FIXME when implemented *) - | GTacCst (tpe, n, cl) -> + | GTacCst (GCaseAlg tpe, n, cl) -> begin match Tac2env.interp_type tpe with | _, GTydAlg def -> let paren = match lvl with -- cgit v1.2.3 From b5530d8953e74def1feb7dd651ba504e24749055 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 13 Dec 2016 16:23:13 +0100 Subject: Proper handling of exception definition in Ltac2. We actually implemented a full-fledged open type system, so that exceptions are a special case of it. --- Init.v | 2 +- g_ltac2.ml4 | 10 ++-- tac2core.ml | 10 +++- tac2entries.ml | 150 ++++++++++++++++++++++++++++++++++++++++++++++++++++- tac2entries.mli | 3 +- tac2env.ml | 5 +- tac2env.mli | 5 +- tac2expr.mli | 23 +++++++-- tac2intern.ml | 158 +++++++++++++++++++++++++++++++++++++++++++++----------- tac2intern.mli | 5 ++ tac2interp.ml | 38 ++++++++++++-- tac2interp.mli | 7 +-- tac2print.ml | 40 ++++++++++++-- 13 files changed, 398 insertions(+), 58 deletions(-) diff --git a/Init.v b/Init.v index 0f0b4636d8..322f275346 100644 --- a/Init.v +++ b/Init.v @@ -20,7 +20,7 @@ Ltac2 Type evar. Ltac2 Type constr. Ltac2 Type ident. Ltac2 Type message. -Ltac2 Type exn. +Ltac2 Type exn := [ .. ]. Ltac2 Type 'a array. (** Pervasive types *) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index 9384584f19..a149d942c6 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -137,6 +137,7 @@ GEXTEND Gram ; tac2typ_knd: [ [ t = tac2type -> CTydDef (Some t) + | "["; ".."; "]" -> CTydOpn | "["; t = tac2alg_constructors; "]" -> CTydAlg t | "{"; t = tac2rec_fields; "}"-> CTydRec t ] ] ; @@ -173,9 +174,12 @@ GEXTEND Gram ] ] ; tac2typ_def: - [ [ prm = tac2typ_prm; id = locident; ":="; e = tac2typ_knd -> - (id, (prm, e)) - | prm = tac2typ_prm; id = locident -> (id, (prm, CTydDef None)) + [ [ prm = tac2typ_prm; id = Prim.qualid; (r, e) = tac2type_body -> (id, r, (prm, e)) ] ] + ; + tac2type_body: + [ [ -> false, CTydDef None + | ":="; e = tac2typ_knd -> false, e + | "::="; e = tac2typ_knd -> true, e ] ] ; tac2def_typ: diff --git a/tac2core.ml b/tac2core.ml index c18b6032a6..227bea8ddd 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -109,8 +109,14 @@ let to_constr c = to_ext val_constr c let of_ident c = of_ext val_ident c let to_ident c = to_ext val_ident c -let of_exn c = of_ext val_exn c -let to_exn c = to_ext val_exn c +(** FIXME: handle backtrace in Ltac2 exceptions *) +let of_exn c = match fst c with +| LtacError (kn, c) -> ValOpn (kn, c) +| _ -> of_ext val_exn c + +let to_exn c = match c with +| ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) +| _ -> to_ext val_exn c let of_pp c = of_ext val_pp c let to_pp c = to_ext val_pp c diff --git a/tac2entries.ml b/tac2entries.ml index f4b3147c48..c776ad13d4 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -19,6 +19,8 @@ open Tac2print open Tac2intern open Vernacexpr +(** Tactic definition *) + type tacdef = { tacdef_local : bool; tacdef_expr : glb_tacexpr; @@ -52,6 +54,8 @@ let inTacDef : tacdef -> obj = subst_function = subst_tacdef; classify_function = classify_tacdef} +(** Type definition *) + type typdef = { typdef_local : bool; typdef_expr : glb_quant_typedef; @@ -86,6 +90,8 @@ let push_typedef visibility sp kn (_, def) = match def with in Tac2env.push_type visibility sp kn; List.iter iter fields +| GTydOpn -> + Tac2env.push_type visibility sp kn let next i = let ans = !i in @@ -108,7 +114,7 @@ let define_typedef kn (params, def as qdef) = match def with Tac2env.cdata_prms = params; cdata_type = kn; cdata_args = args; - cdata_indx = tag; + cdata_indx = Some tag; } in Tac2env.define_constructor knc data in @@ -129,6 +135,8 @@ let define_typedef kn (params, def as qdef) = match def with in Tac2env.define_type kn qdef; List.iteri iter fs +| GTydOpn -> + Tac2env.define_type kn qdef let perform_typdef vs ((sp, kn), def) = let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in @@ -155,6 +163,78 @@ let inTypDef : typdef -> obj = subst_function = subst_typdef; classify_function = classify_typdef} +(** Type extension *) + +type extension_data = { + edata_name : Id.t; + edata_args : int glb_typexpr list; +} + +type typext = { + typext_local : bool; + typext_prms : int; + typext_type : type_constant; + typext_expr : extension_data list; +} + +let push_typext vis sp kn def = + let iter data = + let spc = change_sp_label sp data.edata_name in + let knc = change_kn_label kn data.edata_name in + Tac2env.push_ltac vis spc (TacConstructor knc) + in + List.iter iter def.typext_expr + +let define_typext kn def = + let iter data = + let knc = change_kn_label kn data.edata_name in + let cdata = { + Tac2env.cdata_prms = def.typext_prms; + cdata_type = def.typext_type; + cdata_args = data.edata_args; + cdata_indx = None; + } in + Tac2env.define_constructor knc cdata + in + List.iter iter def.typext_expr + +let cache_typext ((sp, kn), def) = + let () = define_typext kn def in + push_typext (Until 1) sp kn def + +let perform_typext vs ((sp, kn), def) = + let () = if not def.typext_local then push_typext vs sp kn def in + define_typext kn def + +let load_typext i obj = perform_typext (Until i) obj +let open_typext i obj = perform_typext (Exactly i) obj + +let subst_typext (subst, e) = + let open Mod_subst in + let subst_data data = + let edata_args = List.smartmap (fun e -> subst_type subst e) data.edata_args in + if edata_args == data.edata_args then data + else { data with edata_args } + in + let typext_type = subst_kn subst e.typext_type in + let typext_expr = List.smartmap subst_data e.typext_expr in + if typext_type == e.typext_type && typext_expr == e.typext_expr then + e + else + { e with typext_type; typext_expr } + +let classify_typext o = Substitute o + +let inTypExt : typext -> obj = + declare_object {(default_object "TAC2-TYPE-EXTENSION") with + cache_function = cache_typext; + load_function = load_typext; + open_function = open_typext; + subst_function = subst_typext; + classify_function = classify_typext} + +(** Toplevel entries *) + let register_ltac ?(local = false) isrec tactics = if isrec then let map (na, e) = (na, None, e) in @@ -206,7 +286,12 @@ let register_ltac ?(local = false) isrec tactics = in List.iter iter defs -let register_type ?(local = false) isrec types = +let qualid_to_ident (loc, qid) = + let (dp, id) = Libnames.repr_qualid qid in + if DirPath.is_empty dp then (loc, id) + else user_err ~loc (str "Identifier expected") + +let register_typedef ?(local = false) isrec types = let same_name ((_, id1), _) ((_, id2), _) = Id.equal id1 id2 in let () = match List.duplicates same_name types with | [] -> () @@ -242,6 +327,10 @@ let register_type ?(local = false) isrec types = user_err (str "Multiple definitions of the projection " ++ Id.print id) in () + | CTydOpn -> + if isrec then + user_err ~loc (str "The open type declaration " ++ Id.print id ++ + str " cannot be recursive") in let () = List.iter check types in let self = @@ -289,6 +378,63 @@ let register_primitive ?(local = false) (loc, id) t ml = } in ignore (Lib.add_leaf id (inTacDef def)) +let register_open ?(local = false) (loc, qid) (params, def) = + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ~loc (str "Unbound type " ++ pr_qualid qid) + in + let (tparams, t) = Tac2env.interp_type kn in + let () = match t with + | GTydOpn -> () + | GTydAlg _ | GTydRec _ | GTydDef _ -> + user_err ~loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") + in + let () = + if not (Int.equal (List.length params) tparams) then + Tac2intern.error_nparams_mismatch loc (List.length params) tparams + in + match def with + | CTydOpn -> () + | CTydAlg def -> + let intern_type t = + let tpe = CTydDef (Some t) in + let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in + match ans with + | GTydDef (Some t) -> t + | _ -> assert false + in + let map (id, tpe) = + let tpe = List.map intern_type tpe in + { edata_name = id; edata_args = tpe } + in + let def = List.map map def in + let def = { + typext_local = local; + typext_type = kn; + typext_prms = tparams; + typext_expr = def; + } in + Lib.add_anonymous_leaf (inTypExt def) + | CTydRec _ | CTydDef _ -> + user_err ~loc (str "Extensions only accept inductive constructors") + +let register_type ?local isrec types = match types with +| [qid, true, def] -> + let (loc, _) = qid in + let () = if isrec then user_err ~loc (str "Extensions cannot be recursive") in + register_open ?local qid def +| _ -> + let map (qid, redef, def) = + let (loc, _) = qid in + let () = if redef then + user_err ~loc (str "Types can only be extended one by one") + in + (qualid_to_ident qid, def) + in + let types = List.map map types in + register_typedef ?local isrec types + let register_struct ?local str = match str with | StrVal (isrec, e) -> register_ltac ?local isrec e | StrTyp (isrec, t) -> register_type ?local isrec t diff --git a/tac2entries.mli b/tac2entries.mli index 9c5d0a15fd..0d9b3ad134 100644 --- a/tac2entries.mli +++ b/tac2entries.mli @@ -8,6 +8,7 @@ open Loc open Names +open Libnames open Tac2expr (** {5 Toplevel definitions} *) @@ -16,7 +17,7 @@ val register_ltac : ?local:bool -> rec_flag -> (Name.t located * raw_tacexpr) list -> unit val register_type : ?local:bool -> rec_flag -> - (Id.t located * raw_quant_typedef) list -> unit + (qualid located * redef_flag * raw_quant_typedef) list -> unit val register_primitive : ?local:bool -> Id.t located -> raw_typexpr -> ml_tactic_name -> unit diff --git a/tac2env.ml b/tac2env.ml index 5e379473c8..0fcdba1ca7 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -22,7 +22,7 @@ type constructor_data = { cdata_prms : int; cdata_type : type_constant; cdata_args : int glb_typexpr list; - cdata_indx : int; + cdata_indx : int option; } type projection_data = { @@ -62,8 +62,9 @@ let rec eval_pure = function ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e } | GTacCst (_, n, []) -> ValInt n | GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) +| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_pure el) | GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ | GTacSet _ -| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ -> +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> anomaly (Pp.str "Term is not a syntactical value") let define_global kn e = diff --git a/tac2env.mli b/tac2env.mli index 16232ec810..477f4ebec7 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -33,10 +33,11 @@ type constructor_data = { (** Inductive definition to which the constructor pertains *) cdata_args : int glb_typexpr list; (** Types of the constructor arguments *) - cdata_indx : int; + cdata_indx : int option; (** Index of the constructor in the ADT. Numbering is duplicated between argumentless and argument-using constructors, e.g. in type ['a option] - [None] and [Some] have both index 0. *) + [None] and [Some] have both index 0. This field is empty whenever the + constructor is a member of an open type. *) } val define_constructor : ltac_constructor -> constructor_data -> unit diff --git a/tac2expr.mli b/tac2expr.mli index 1fac5a2315..1840b567b4 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -13,6 +13,7 @@ open Libnames type mutable_flag = bool type rec_flag = bool +type redef_flag = bool type lid = Id.t type uid = Id.t @@ -40,6 +41,7 @@ type raw_typedef = | CTydDef of raw_typexpr option | CTydAlg of (uid * raw_typexpr list) list | CTydRec of (lid * mutable_flag * raw_typexpr) list +| CTydOpn type 'a glb_typexpr = | GTypVar of 'a @@ -51,6 +53,7 @@ type glb_typedef = | GTydDef of int glb_typexpr option | GTydAlg of (uid * int glb_typexpr list) list | GTydRec of (lid * mutable_flag * int glb_typexpr) list +| GTydOpn type type_scheme = int * int glb_typexpr @@ -94,6 +97,13 @@ type case_info = | GCaseTuple of int | GCaseAlg of type_constant +type 'a open_match = { + opn_match : 'a; + opn_branch : (Name.t * Name.t array * 'a) KNmap.t; + (** Invariant: should not be empty *) + opn_default : Name.t * 'a; +} + type glb_tacexpr = | GTacAtm of atom | GTacVar of Id.t @@ -106,22 +116,27 @@ type glb_tacexpr = | GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array | GTacPrj of type_constant * glb_tacexpr * int | GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr +| GTacOpn of ltac_constructor * glb_tacexpr list +| GTacWth of glb_tacexpr open_match | GTacExt of glob_generic_argument | GTacPrm of ml_tactic_name * glb_tacexpr list (** Toplevel statements *) type strexpr = | StrVal of rec_flag * (Name.t located * raw_tacexpr) list -| StrTyp of rec_flag * (Id.t located * raw_quant_typedef) list + (** Term definition *) +| StrTyp of rec_flag * (qualid located * redef_flag * raw_quant_typedef) list + (** Type definition *) | StrPrm of Id.t located * raw_typexpr * ml_tactic_name + (** External definition *) (** {5 Dynamic semantics} *) (** Values are represented in a way similar to OCaml, i.e. they constrast immediate integers (integers, constructors without arguments) and structured blocks (tuples, arrays, constructors with arguments), as well as a few other - base cases, namely closures, strings and dynamic type coming from the Coq - implementation. *) + base cases, namely closures, strings, named constructors, and dynamic type + coming from the Coq implementation. *) type tag = int @@ -134,6 +149,8 @@ type valexpr = (** Strings *) | ValCls of closure (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) | ValExt of Geninterp.Val.t (** Arbitrary data *) diff --git a/tac2intern.ml b/tac2intern.ml index c4d2fc277b..32d1e07c17 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -215,6 +215,11 @@ let error_nargs_mismatch loc nargs nfound = str " arguments, but is applied to " ++ int nfound ++ str " arguments") +let error_nparams_mismatch loc nargs nfound = + user_err ~loc (str "Type expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + let rec subst_type subst (t : 'a glb_typexpr) = match t with | GTypVar id -> subst id | GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) @@ -275,7 +280,7 @@ let fresh_reftype env (kn : KerName.t) = let is_unfoldable kn = match snd (Tac2env.interp_type kn) with | GTydDef (Some _) -> true -| GTydDef None | GTydAlg _ | GTydRec _ -> false +| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false let unfold env kn args = let (nparams, def) = Tac2env.interp_type kn in @@ -349,7 +354,7 @@ let unify loc env t1 t2 = let is_pure_constructor kn = match snd (Tac2env.interp_type kn) with - | GTydAlg _ -> true + | GTydAlg _ | GTydOpn -> true | GTydRec fields -> let is_pure (_, mut, _) = not mut in List.for_all is_pure fields @@ -360,14 +365,16 @@ let rec is_value = function | GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false | GTacCst (GCaseTuple _, _, el) -> List.for_all is_value el | GTacCst (_, _, []) -> true +| GTacOpn (_, el) -> List.for_all is_value el | GTacCst (GCaseAlg kn, _, el) -> is_pure_constructor kn && List.for_all is_value el -| GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ -> false +| GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ +| GTacWth _ -> false let is_rec_rhs = function | GTacFun _ -> true | GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ | GTacSet _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ -| GTacCse _ -> false +| GTacCse _ | GTacOpn _ | GTacWth _ -> false let rec fv_type f t accu = match t with | GTypVar id -> f id accu @@ -503,40 +510,55 @@ let invalid_pattern ~loc kn t = user_err ~loc (str "Invalid pattern, expected a pattern for type " ++ pr_typref kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) +(** Pattern view *) + +type glb_patexpr = +| GPatVar of Name.t +| GPatRef of ltac_constructor * glb_patexpr list +| GPatTup of glb_patexpr list + +let rec intern_patexpr env = function +| CPatAny _ -> GPatVar Anonymous +| CPatRef (_, qid, []) -> + begin match get_constructor env qid with + | ArgVar (_, id) -> GPatVar (Name id) + | ArgArg (_, kn) -> GPatRef (kn, []) + end +| CPatRef (_, qid, pl) -> + begin match get_constructor env qid with + | ArgVar (loc, _) -> + user_err ~loc (str "Unbound constructor " ++ pr_qualid (snd qid)) + | ArgArg (_, kn) -> GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) + end +| CPatTup (_, pl) -> + GPatTup (List.map (fun p -> intern_patexpr env p) pl) + type pattern_kind = | PKind_empty -| PKind_variant of KerName.t +| PKind_variant of type_constant +| PKind_open of type_constant | PKind_tuple of int | PKind_any let get_pattern_kind env pl = match pl with | [] -> PKind_empty | p :: pl -> - let rec get_kind p pl = match fst p with - | CPatAny _ -> + let rec get_kind (p, _) pl = match intern_patexpr env p with + | GPatVar _ -> begin match pl with | [] -> PKind_any | p :: pl -> get_kind p pl end - | CPatRef (_, qid, []) -> - begin match get_constructor env qid with - | ArgVar _ -> - begin match pl with - | [] -> PKind_any - | p :: pl -> get_kind p pl - end - | ArgArg (data, _) -> PKind_variant data.cdata_type - end - | CPatRef (_, qid, _ :: _) -> - begin match get_constructor env qid with - | ArgVar (loc, _) -> - user_err ~loc (str "Unbound constructor " ++ pr_qualid (snd qid)) - | ArgArg (data, _) -> PKind_variant data.cdata_type - end - | CPatTup (_, tp) -> PKind_tuple (List.length tp) + | GPatRef (kn, pl) -> + let data = Tac2env.interp_constructor kn in + if Option.is_empty data.cdata_indx then PKind_open data.cdata_type + else PKind_variant data.cdata_type + | GPatTup tp -> PKind_tuple (List.length tp) in get_kind p pl +(** Internalization *) + let is_constructor env qid = match get_variable env qid with | ArgArg (TacConstructor _) -> true | _ -> false @@ -739,9 +761,8 @@ and intern_case env loc e pl = match get_pattern_kind env pl with | PKind_any -> let (pat, b) = List.hd pl in - let na = match pat with - | CPatAny _ -> Anonymous - | CPatRef (_, (_, qid), _) -> Name (snd (repr_qualid qid)) + let na = match intern_patexpr env pat with + | GPatVar na -> na | _ -> assert false in let () = check_redundant_clause (List.tl pl) in @@ -851,7 +872,10 @@ and intern_case env loc e pl = let nenv = List.fold_left2 fold env ids data.cdata_args in let (br', brT) = intern_rec nenv br in let () = - let index = data.cdata_indx in + let index = match data.cdata_indx with + | Some i -> i + | None -> assert false + in if List.is_empty args then if Option.is_empty const.(index) then const.(index) <- Some br' else warn_redundant_clause ~loc () @@ -869,13 +893,67 @@ and intern_case env loc e pl = in let () = intern_branch pl in let map = function - | None -> user_err ~loc (str "Unhandled match case") (** FIXME *) + | None -> user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) | Some x -> x in let const = Array.map map const in let nonconst = Array.map map nonconst in let ce = GTacCse (e', GCaseAlg kn, const, nonconst) in (ce, ret) + | PKind_open kn -> + let subst, tc = fresh_reftype env kn in + let () = unify (loc_of_tacexpr e) env t tc in + let ret = GTypVar (fresh_id env) in + let rec intern_branch map = function + | [] -> + user_err ~loc (str "Missing default case") + | (pat, br) :: rem -> + match intern_patexpr env pat with + | GPatVar na -> + let () = check_redundant_clause rem in + let nenv = push_name na (monomorphic tc) env in + let br' = intern_rec_with_constraint nenv br ret in + let def = (na, br') in + (map, def) + | GPatRef (knc, args) -> + let get = function + | GPatVar na -> na + | GPatRef _ | GPatTup _ -> + user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) + in + let loc = loc_of_patexpr pat in + let ids = List.map get args in + let data = Tac2env.interp_constructor knc in + let () = + if not (KerName.equal kn data.cdata_type) then + invalid_pattern ~loc kn (GCaseAlg data.cdata_type) + in + let nids = List.length ids in + let nargs = List.length data.cdata_args in + let () = + if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids + in + let fold env id tpe = + (** Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids data.cdata_args in + let br' = intern_rec_with_constraint nenv br ret in + let map = + if KNmap.mem knc map then + let () = warn_redundant_clause ~loc () in + map + else + KNmap.add knc (Anonymous, Array.of_list ids, br') map + in + intern_branch map rem + | GPatTup tup -> + invalid_pattern ~loc kn (GCaseTuple (List.length tup)) + in + let (map, def) = intern_branch KNmap.empty pl in + (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) and intern_constructor env loc kn args = let cstr = interp_constructor kn in @@ -887,7 +965,11 @@ and intern_constructor env loc kn args = let ans = GTypRef (cstr.cdata_type, List.init cstr.cdata_prms (fun i -> GTypVar subst.(i))) in let map arg tpe = intern_rec_with_constraint env arg tpe in let args = List.map2 map args types in - (GTacCst (GCaseAlg cstr.cdata_type, cstr.cdata_indx, args), ans) + match cstr.cdata_indx with + | Some idx -> + (GTacCst (GCaseAlg cstr.cdata_type, idx, args), ans) + | None -> + (GTacOpn (kn, args), ans) else error_nargs_mismatch loc nargs (List.length args) @@ -986,6 +1068,7 @@ let intern_typedef self (ids, t) : glb_quant_typedef = let map (c, mut, t) = (c, mut, intern t) in let fields = List.map map fields in (count, GTydRec fields) + | CTydOpn -> (count, GTydOpn) let intern_open_type t = let env = empty_env () in @@ -1045,6 +1128,18 @@ let rec subst_expr subst e = match e with let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in let ci' = subst_case_info subst ci in GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> + let e' = subst_expr subst e in + let def' = subst_expr subst def in + let fold kn (self, vars, p) accu = + let kn' = subst_kn subst kn in + let p' = subst_expr subst p in + if kn' == kn && p' == p then accu + else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) + in + let br' = KNmap.fold fold br br in + if e' == e && br' == br && def' == def then e0 + else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } | GTacPrj (kn, e, p) as e0 -> let kn' = subst_kn subst kn in let e' = subst_expr subst e in @@ -1057,6 +1152,10 @@ let rec subst_expr subst e = match e with | GTacExt ext -> let ext' = Genintern.generic_substitute subst ext in if ext' == ext then e else GTacExt ext' +| GTacOpn (kn, el) as e0 -> + let kn' = subst_kn subst kn in + let el' = List.smartmap (fun e -> subst_expr subst e) el in + if kn' == kn && el' == el then e0 else GTacOpn (kn', el') let subst_typedef subst e = match e with | GTydDef t -> @@ -1076,6 +1175,7 @@ let subst_typedef subst e = match e with in let fields' = List.smartmap map fields in if fields' == fields then e else GTydRec fields' +| GTydOpn -> GTydOpn let subst_quant_typedef subst (prm, def as qdef) = let def' = subst_typedef subst def in diff --git a/tac2intern.mli b/tac2intern.mli index 6633792e7e..4c482d0b0c 100644 --- a/tac2intern.mli +++ b/tac2intern.mli @@ -26,3 +26,8 @@ val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef val subst_type_scheme : substitution -> type_scheme -> type_scheme + +(** Errors *) + +val error_nargs_mismatch : Loc.t -> int -> int -> 'a +val error_nparams_mismatch : Loc.t -> int -> int -> 'a diff --git a/tac2interp.ml b/tac2interp.ml index cd307e3ae7..664b7de3d6 100644 --- a/tac2interp.ml +++ b/tac2interp.ml @@ -14,7 +14,14 @@ open Names open Proofview.Notations open Tac2expr -exception LtacError of KerName.t * valexpr +exception LtacError of KerName.t * valexpr array + +let () = register_handler begin function +| LtacError (kn, _) -> + let c = Tac2print.pr_constructor kn in + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) +| _ -> raise Unhandled +end let val_exn = Geninterp.Val.create "ltac2:exn" @@ -81,12 +88,17 @@ let rec interp ist = function return (ValBlk (n, Array.of_list el)) | GTacCse (e, _, cse0, cse1) -> interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> + interp ist e >>= fun e -> interp_with ist e cse def | GTacPrj (_, e, p) -> interp ist e >>= fun e -> interp_proj ist e p | GTacSet (_, e, p, r) -> interp ist e >>= fun e -> interp ist r >>= fun r -> interp_set ist e p r +| GTacOpn (kn, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (ValOpn (kn, Array.of_list el)) | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> Tac2env.interp_primitive ml el @@ -106,7 +118,7 @@ and interp_app f args = match f with | id :: ids, arg :: args -> push (push_name ist id arg) ids args in push ist ids args -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ -> +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> anomaly (str "Unexpected value shape") and interp_case ist e cse0 cse1 = match e with @@ -115,18 +127,34 @@ and interp_case ist e cse0 cse1 = match e with let (ids, e) = cse1.(n) in let ist = CArray.fold_left2 push_name ist ids args in interp ist e -| ValExt _ | ValStr _ | ValCls _ -> +| ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> + anomaly (str "Unexpected value shape") + +and interp_with ist e cse def = match e with +| ValOpn (kn, args) -> + let br = try Some (KNmap.find kn cse) with Not_found -> None in + begin match br with + | None -> + let (self, def) = def in + let ist = push_name ist self e in + interp ist def + | Some (self, ids, p) -> + let ist = push_name ist self e in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist p + end +| ValInt _ | ValBlk _ | ValExt _ | ValStr _ | ValCls _ -> anomaly (str "Unexpected value shape") and interp_proj ist e p = match e with | ValBlk (_, args) -> return args.(p) -| ValInt _ | ValExt _ | ValStr _ | ValCls _ -> +| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> anomaly (str "Unexpected value shape") and interp_set ist e p r = match e with | ValBlk (_, args) -> let () = args.(p) <- r in return (ValInt 0) -| ValInt _ | ValExt _ | ValStr _ | ValCls _ -> +| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> anomaly (str "Unexpected value shape") diff --git a/tac2interp.mli b/tac2interp.mli index 7fe78a9460..bf6b2d4dde 100644 --- a/tac2interp.mli +++ b/tac2interp.mli @@ -20,8 +20,9 @@ val interp_app : valexpr -> valexpr list -> valexpr Proofview.tactic (** {5 Exceptions} *) -exception LtacError of KerName.t * valexpr -(** Ltac2-defined exceptions *) +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) val val_exn : Exninfo.iexn Geninterp.Val.typ -(** Toplevel representation of Ltac2 exceptions *) +(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] + should be put into a value with tag [val_exn]. *) diff --git a/tac2print.ml b/tac2print.ml index a7f9ed48c8..ffa5ddc05a 100644 --- a/tac2print.ml +++ b/tac2print.ml @@ -153,7 +153,7 @@ let pr_glbexpr_gen lvl c = | E0 -> paren | E1 | E2 | E3 | E4 | E5 -> fun x -> x in - paren (pr_glbexpr E1 c) ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl) + paren (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) | GTacLet (mut, bnd, e) -> let paren = match lvl with | E0 | E1 | E2 | E3 | E4 -> paren @@ -195,7 +195,7 @@ let pr_glbexpr_gen lvl c = in let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in str "{" ++ spc () ++ args ++ spc () ++ str "}" - | _, GTydDef _ -> assert false + | _, (GTydDef _ | GTydOpn) -> assert false end | GTacCse (e, info, cst_br, ncst_br) -> let e = pr_glbexpr E5 e in @@ -203,7 +203,7 @@ let pr_glbexpr_gen lvl c = | GCaseAlg kn -> let def = match Tac2env.interp_type kn with | _, GTydAlg def -> def - | _, GTydDef _ | _, GTydRec _ -> assert false + | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false in let br = order_branches cst_br ncst_br def in let pr_branch (cstr, vars, p) = @@ -224,10 +224,33 @@ let pr_glbexpr_gen lvl c = str "|" ++ spc () ++ paren vars ++ spc () ++ str "=>" ++ spc () ++ p in hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") + | GTacWth wth -> + let e = pr_glbexpr E5 wth.opn_match in + let pr_pattern c self vars p = + let self = match self with + | Anonymous -> mt () + | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id + in + hov 0 (str "|" ++ spc () ++ c ++ vars ++ self ++ spc () ++ str "=>" ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + let pr_branch (cstr, (self, vars, p)) = + let cstr = pr_constructor cstr in + let vars = match Array.to_list vars with + | [] -> mt () + | vars -> spc () ++ pr_sequence pr_name vars + in + pr_pattern cstr self vars p + in + let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in + let (def_as, def_p) = wth.opn_default in + let def = pr_pattern (str "_") def_as (mt ()) def_p in + let br = br ++ def in + hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") | GTacPrj (kn, e, n) -> let def = match Tac2env.interp_type kn with | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ -> assert false + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false in let (proj, _, _) = List.nth def n in let proj = change_kn_label kn proj in @@ -237,7 +260,7 @@ let pr_glbexpr_gen lvl c = | GTacSet (kn, e, n, r) -> let def = match Tac2env.interp_type kn with | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ -> assert false + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false in let (proj, _, _) = List.nth def n in let proj = change_kn_label kn proj in @@ -245,6 +268,13 @@ let pr_glbexpr_gen lvl c = let e = pr_glbexpr E0 e in let r = pr_glbexpr E1 r in e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r + | GTacOpn (kn, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let c = pr_constructor kn in + paren (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) | GTacExt arg -> let GenArg (Glbwit tag, arg) = arg in let name = match tag with -- cgit v1.2.3 From 735ab0a7d2f7afaed0695e014034f4b2d6e287c8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 14 Dec 2016 08:09:54 +0100 Subject: Stdlib functions now return Ltac2 exceptions. --- Init.v | 14 ++++++++++++++ Int.v | 2 ++ tac2core.ml | 55 ++++++++++++++++++++++++++++++++----------------------- 3 files changed, 48 insertions(+), 23 deletions(-) diff --git a/Init.v b/Init.v index 322f275346..8ff5837bb4 100644 --- a/Init.v +++ b/Init.v @@ -30,3 +30,17 @@ Ltac2 Type 'a option := [ None | Some ('a) ]. Ltac2 Type 'a ref := { mutable contents : 'a }. Ltac2 Type bool := [ true | false ]. + +(** Pervasive exceptions *) + +Ltac2 Type exn ::= [ Out_of_bounds ]. +(** Used for bound checking, e.g. with String and Array. *) + +Ltac2 Type exn ::= [ Not_focussed ]. +(** In Ltac2, the notion of "current environment" only makes sense when there is + at most one goal under focus. Contrarily to Ltac1, instead of dynamically + focussing when we need it, we raise this non-backtracking error when it does + not make sense. *) + +Ltac2 Type exn ::= [ Not_found ]. +(** Used when something is missing. *) diff --git a/Int.v b/Int.v index bb0287efc8..ab43eb27b0 100644 --- a/Int.v +++ b/Int.v @@ -8,6 +8,8 @@ Require Import Coq.ltac2.Init. +Ltac2 Type exn ::= [ Division_by_zero ]. + Ltac2 @ external equal : int -> int -> bool := "ltac2" "int_equal". Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". diff --git a/tac2core.ml b/tac2core.ml index 227bea8ddd..3232fcba5b 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -20,6 +20,10 @@ open Proofview.Notations (** Standard values *) let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) +let stdlib_prefix md = + MPfile (DirPath.make (List.map Id.of_string [md; "ltac2"; "Coq"])) +let coq_stdlib md n = + KerName.make2 (stdlib_prefix md) (Label.of_id (Id.of_string n)) let val_tag t = match val_tag t with | Val.Base t -> t @@ -125,9 +129,21 @@ end let val_valexpr = Val.create "ltac2:valexpr" +(** Stdlib exceptions *) + +let err_notfocussed = + LtacError (coq_core "Not_focussed", [||]) + +let err_outofbounds = + LtacError (coq_core "Out_of_bounds", [||]) + +let err_notfound = + LtacError (coq_core "Not_found", [||]) + (** Helper functions *) let thaw f = interp_app f [v_unit] +let throw e = Proofview.tclLIFT (Proofview.NonLogical.raise e) let return x = Proofview.tclUNIT x let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -138,16 +154,9 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit -(** In Ltac2, the notion of "current environment" only makes sense when there is - at most one goal under focus. Contrarily to Ltac1, instead of dynamically - focussing when we need it, we raise a non-backtracking error when it does - not make sense. *) -exception NonFocussedGoal - -let () = register_handler begin function -| NonFocussedGoal -> str "Several goals under focus" -| _ -> raise Unhandled -end +let wrap_exn f err = + return () >>= fun () -> + try return (f ()) with e when CErrors.noncritical e -> err let pf_apply f = Proofview.Goal.goals >>= function @@ -159,7 +168,7 @@ let pf_apply f = gl >>= fun gl -> f (Proofview.Goal.env gl) (Tacmach.New.project gl) | _ :: _ :: _ -> - Proofview.tclLIFT (Proofview.NonLogical.raise NonFocussedGoal) + throw err_notfocussed (** Primitives *) @@ -197,8 +206,8 @@ let prm_message_concat : ml_tactic = function let prm_array_make : ml_tactic = function | [ValInt n; x] -> - (** FIXME: wrap exception *) - wrap (fun () -> ValBlk (0, Array.make n x)) + if n < 0 || n > Sys.max_array_length then throw err_outofbounds + else wrap (fun () -> ValBlk (0, Array.make n x)) | _ -> assert false let prm_array_length : ml_tactic = function @@ -207,14 +216,14 @@ let prm_array_length : ml_tactic = function let prm_array_set : ml_tactic = function | [ValBlk (_, v); ValInt n; x] -> - (** FIXME: wrap exception *) - wrap_unit (fun () -> v.(n) <- x) + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap_unit (fun () -> v.(n) <- x) | _ -> assert false let prm_array_get : ml_tactic = function | [ValBlk (_, v); ValInt n] -> - (** FIXME: wrap exception *) - wrap (fun () -> v.(n)) + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap (fun () -> v.(n)) | _ -> assert false (** Int *) @@ -243,8 +252,8 @@ let prm_string_make : ml_tactic = function | [n; c] -> let n = Value.to_int n in let c = Value.to_char c in - (** FIXME: wrap exception *) - wrap (fun () -> Value.of_string (Bytes.make n c)) + if n < 0 || n > Sys.max_string_length then throw err_outofbounds + else wrap (fun () -> Value.of_string (Bytes.make n c)) | _ -> assert false let prm_string_length : ml_tactic = function @@ -257,16 +266,16 @@ let prm_string_set : ml_tactic = function let s = Value.to_string s in let n = Value.to_int n in let c = Value.to_char c in - (** FIXME: wrap exception *) - wrap_unit (fun () -> Bytes.set s n c) + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap_unit (fun () -> Bytes.set s n c) | _ -> assert false let prm_string_get : ml_tactic = function | [s; n] -> let s = Value.to_string s in let n = Value.to_int n in - (** FIXME: wrap exception *) - wrap (fun () -> Value.of_char (Bytes.get s n)) + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap (fun () -> Value.of_char (Bytes.get s n)) | _ -> assert false (** Error *) -- cgit v1.2.3 From c341a00d916c27b75c79c2fdcce13e969772a990 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 16 Mar 2017 09:05:04 +0100 Subject: Allow raw terms to contain references to absolute definitions. --- g_ltac2.ml4 | 20 +++++++++---------- tac2entries.ml | 2 +- tac2env.ml | 7 +------ tac2env.mli | 4 ---- tac2expr.mli | 20 +++++++++++++------ tac2intern.ml | 62 ++++++++++++++++++++++++++++++++++++++++++---------------- 6 files changed, 71 insertions(+), 44 deletions(-) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index a149d942c6..30f5399a88 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -32,12 +32,12 @@ GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext; tac2pat: [ "1" LEFTA - [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> CPatRef (!@loc, id, pl) - | id = Prim.qualid -> CPatRef (!@loc, id, []) ] + [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> CPatRef (!@loc, RelId id, pl) + | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) ] | "0" [ "_" -> CPatAny (!@loc) | "()" -> CPatTup (!@loc, []) - | id = Prim.qualid -> CPatRef (!@loc, id, []) + | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> CPatTup (!@loc, pl) ] ] ; @@ -54,8 +54,8 @@ GEXTEND Gram [ e1 = tac2expr; ";"; e2 = tac2expr -> CTacSeq (!@loc, e1, e2) ] | "1" LEFTA [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) - | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, qid) - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, qid, r) + | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, RelId qid, r) | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> CTacTup (!@loc, e0 :: el) ] | "0" [ "("; a = tac2expr LEVEL "5"; ")" -> a @@ -86,7 +86,7 @@ GEXTEND Gram tactic_atom: [ [ n = Prim.integer -> CTacAtm (!@loc, AtmInt n) | s = Prim.string -> CTacAtm (!@loc, AtmStr s) - | id = Prim.qualid -> CTacRef id + | id = Prim.qualid -> CTacRef (RelId id) | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c @@ -104,14 +104,14 @@ GEXTEND Gram | "2" [ t = tac2type; "*"; tl = LIST1 tac2type SEP "*" -> CTypTuple (!@loc, t :: tl) ] | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, qid, [t]) ] + [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, RelId qid, [t]) ] | "0" [ "("; t = tac2type LEVEL "5"; ")" -> t | id = typ_param -> CTypVar (!@loc, Name id) | "_" -> CTypVar (!@loc, Anonymous) - | qid = Prim.qualid -> CTypRef (!@loc, qid, []) + | qid = Prim.qualid -> CTypRef (!@loc, RelId qid, []) | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - CTypRef (!@loc, qid, p) ] + CTypRef (!@loc, RelId qid, p) ] ]; locident: [ [ id = Prim.ident -> (!@loc, id) ] ] @@ -165,7 +165,7 @@ GEXTEND Gram | -> [] ] ] ; tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> qid, e ] ] + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> RelId qid, e ] ] ; tac2typ_prm: [ [ -> [] diff --git a/tac2entries.ml b/tac2entries.ml index c776ad13d4..374a367188 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -243,7 +243,7 @@ let register_ltac ?(local = false) isrec tactics = | Anonymous -> None | Name id -> let qid = Libnames.qualid_of_ident id in - let e = CTacLet (Loc.ghost, true, bindings, CTacRef (loc, qid)) in + let e = CTacLet (Loc.ghost, true, bindings, CTacRef (RelId (loc, qid))) in let (e, t) = intern e in let e = match e with | GTacLet (true, _, e) -> assert false diff --git a/tac2env.ml b/tac2env.ml index 0fcdba1ca7..a36d022e4d 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -13,11 +13,6 @@ open Names open Libnames open Tac2expr -type ltac_constant = KerName.t -type ltac_constructor = KerName.t -type ltac_projection = KerName.t -type type_constant = KerName.t - type constructor_data = { cdata_prms : int; cdata_type : type_constant; @@ -121,7 +116,7 @@ struct id, (DirPath.repr dir) end -type tacref = +type tacref = Tac2expr.tacref = | TacConstant of ltac_constant | TacConstructor of ltac_constructor diff --git a/tac2env.mli b/tac2env.mli index 477f4ebec7..c4b8c1e0ca 100644 --- a/tac2env.mli +++ b/tac2env.mli @@ -63,10 +63,6 @@ val interp_projection : ltac_projection -> projection_data (** {5 Name management} *) -type tacref = -| TacConstant of ltac_constant -| TacConstructor of ltac_constructor - val push_ltac : visibility -> full_path -> tacref -> unit val locate_ltac : qualid -> tacref val locate_extended_all_ltac : qualid -> tacref list diff --git a/tac2expr.mli b/tac2expr.mli index 1840b567b4..63207ac78f 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -22,6 +22,10 @@ type ltac_constructor = KerName.t type ltac_projection = KerName.t type type_constant = KerName.t +type 'a or_relid = +| RelId of qualid located +| AbsKn of 'a + (** {5 Misc} *) type ml_tactic_name = { @@ -35,7 +39,7 @@ type raw_typexpr = | CTypVar of Name.t located | CTypArrow of Loc.t * raw_typexpr * raw_typexpr | CTypTuple of Loc.t * raw_typexpr list -| CTypRef of Loc.t * qualid located * raw_typexpr list +| CTypRef of Loc.t * type_constant or_relid * raw_typexpr list type raw_typedef = | CTydDef of raw_typexpr option @@ -66,15 +70,19 @@ type atom = | AtmInt of int | AtmStr of string +type tacref = +| TacConstant of ltac_constant +| TacConstructor of ltac_constructor + (** Tactic expressions *) type raw_patexpr = | CPatAny of Loc.t -| CPatRef of Loc.t * qualid located * raw_patexpr list +| CPatRef of Loc.t * ltac_constructor or_relid * raw_patexpr list | CPatTup of raw_patexpr list located type raw_tacexpr = | CTacAtm of atom located -| CTacRef of qualid located +| CTacRef of tacref or_relid | CTacFun of Loc.t * (Name.t located * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list | CTacLet of Loc.t * rec_flag * (Name.t located * raw_typexpr option * raw_tacexpr) list * raw_tacexpr @@ -85,13 +93,13 @@ type raw_tacexpr = | CTacSeq of Loc.t * raw_tacexpr * raw_tacexpr | CTacCse of Loc.t * raw_tacexpr * raw_taccase list | CTacRec of Loc.t * raw_recexpr -| CTacPrj of Loc.t * raw_tacexpr * qualid located -| CTacSet of Loc.t * raw_tacexpr * qualid located * raw_tacexpr +| CTacPrj of Loc.t * raw_tacexpr * ltac_projection or_relid +| CTacSet of Loc.t * raw_tacexpr * ltac_projection or_relid * raw_tacexpr | CTacExt of Loc.t * raw_generic_argument and raw_taccase = raw_patexpr * raw_tacexpr -and raw_recexpr = (qualid located * raw_tacexpr) list +and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list type case_info = | GCaseTuple of int diff --git a/tac2intern.ml b/tac2intern.ml index 32d1e07c17..c7e02a7b06 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -190,7 +190,8 @@ let push_name id t env = match id with let loc_of_tacexpr = function | CTacAtm (loc, _) -> loc -| CTacRef (loc, _) -> loc +| CTacRef (RelId (loc, _)) -> loc +| CTacRef (AbsKn _) -> Loc.ghost | CTacFun (loc, _, _) -> loc | CTacApp (loc, _, _) -> loc | CTacLet (loc, _, _, _) -> loc @@ -230,9 +231,10 @@ let rec subst_type subst (t : 'a glb_typexpr) = match t with let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with | CTypVar (loc, Name id) -> GTypVar (get_alias (loc, id) env) | CTypVar (_, Anonymous) -> GTypVar (fresh_id env) -| CTypRef (_, (loc, qid), args) -> - let (dp, id) = repr_qualid qid in - let (kn, nparams) = +| CTypRef (loc, rel, args) -> + let (kn, nparams) = match rel with + | RelId (loc, qid) -> + let (dp, id) = repr_qualid qid in if DirPath.is_empty dp && Id.Map.mem id env.env_rec then Id.Map.find id env.env_rec else @@ -243,10 +245,17 @@ let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with in let (nparams, _) = Tac2env.interp_type kn in (kn, nparams) + | AbsKn kn -> + let (nparams, _) = Tac2env.interp_type kn in + (kn, nparams) in let nargs = List.length args in let () = if not (Int.equal nparams nargs) then + let loc, qid = match rel with + | RelId lid -> lid + | AbsKn kn -> loc, shortest_qualid_of_type kn + in user_err ~loc (strbrk "The type constructor " ++ pr_qualid qid ++ strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ applied to " ++ int nargs ++ strbrk "argument(s)") @@ -467,7 +476,8 @@ let check_redundant_clause = function | [] -> () | (p, _) :: _ -> warn_redundant_clause ~loc:(loc_of_patexpr p) () -let get_variable env (loc, qid) = +let get_variable env var = match var with +| RelId (loc, qid) -> let (dp, id) = repr_qualid qid in if DirPath.is_empty dp && Id.Map.mem id env.env_var then ArgVar (loc, id) else @@ -477,10 +487,12 @@ let get_variable env (loc, qid) = CErrors.user_err ~loc (str "Unbound value " ++ pr_qualid qid) in ArgArg kn +| AbsKn kn -> ArgArg kn -let get_constructor env (loc, qid) = +let get_constructor env var = match var with +| RelId (loc, qid) -> let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in - match c with + begin match c with | Some (TacConstructor knc) -> let kn = Tac2env.interp_constructor knc in ArgArg (kn, knc) @@ -491,12 +503,19 @@ let get_constructor env (loc, qid) = let (dp, id) = repr_qualid qid in if DirPath.is_empty dp then ArgVar (loc, id) else CErrors.user_err ~loc (str "Unbound constructor " ++ pr_qualid qid) + end +| AbsKn knc -> + let kn = Tac2env.interp_constructor knc in + ArgArg (kn, knc) -let get_projection (loc, qid) = +let get_projection var = match var with +| RelId (loc, qid) -> let kn = try Tac2env.locate_projection qid with Not_found -> user_err ~loc (pr_qualid qid ++ str " is not a projection") in Tac2env.interp_projection kn +| AbsKn kn -> + Tac2env.interp_projection kn let intern_atm env = function | AtmInt n -> (GTacAtm (AtmInt n), GTypRef (t_int, [])) @@ -526,8 +545,8 @@ let rec intern_patexpr env = function end | CPatRef (_, qid, pl) -> begin match get_constructor env qid with - | ArgVar (loc, _) -> - user_err ~loc (str "Unbound constructor " ++ pr_qualid (snd qid)) + | ArgVar (loc, id) -> + user_err ~loc (str "Unbound constructor " ++ Nameops.pr_id id) | ArgArg (_, kn) -> GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) end | CPatTup (_, pl) -> @@ -565,7 +584,7 @@ let is_constructor env qid = match get_variable env qid with let rec intern_rec env = function | CTacAtm (_, atm) -> intern_atm env atm -| CTacRef qid -> +| CTacRef qid as e -> begin match get_variable env qid with | ArgVar (_, id) -> let sch = Id.Map.find id env.env_var in @@ -574,7 +593,8 @@ let rec intern_rec env = function let (_, _, sch) = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) | ArgArg (TacConstructor kn) -> - intern_constructor env (fst qid) kn [] + let loc = loc_of_tacexpr e in + intern_constructor env loc kn [] end | CTacFun (loc, bnd, e) -> let fold (env, bnd, tl) ((_, na), t) = @@ -590,12 +610,13 @@ let rec intern_rec env = function let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in (GTacFun (bnd, e), t) -| CTacApp (loc, CTacRef qid, args) when is_constructor env qid -> +| CTacApp (loc, CTacRef qid, args) as e when is_constructor env qid -> let kn = match get_variable env qid with | ArgArg (TacConstructor kn) -> kn | _ -> assert false in - intern_constructor env (fst qid) kn args + let loc = loc_of_tacexpr e in + intern_constructor env loc kn args | CTacApp (loc, f, args) -> let (f, ft) = intern_rec env f in let fold arg (args, t) = @@ -687,7 +708,10 @@ let rec intern_rec env = function let pinfo = get_projection proj in let () = if not pinfo.pdata_mutb then - let (loc, _) = proj in + let loc = match proj with + | RelId (loc, _) -> loc + | AbsKn _ -> Loc.ghost + in user_err ~loc (str "Field is not mutable") in let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in @@ -974,8 +998,12 @@ and intern_constructor env loc kn args = error_nargs_mismatch loc nargs (List.length args) and intern_record env loc fs = - let map ((loc, qid), e) = - let proj = get_projection (loc, qid) in + let map (proj, e) = + let loc = match proj with + | RelId (loc, _) -> loc + | AbsKn _ -> Loc.ghost + in + let proj = get_projection proj in (loc, proj, e) in let fs = List.map map fs in -- cgit v1.2.3 From a16d9c10b874a38fd4901e7d946d975ad49592c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 May 2017 15:57:01 +0200 Subject: Introducing tactic notations in Ltac2. --- g_ltac2.ml4 | 31 +++++++- tac2core.ml | 74 +++++++++++++++++- tac2entries.ml | 146 +++++++++++++++++++++++++++++++++++- tac2entries.mli | 23 ++++++ tac2expr.mli | 21 +++++- tac2intern.ml | 228 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- tac2intern.mli | 8 ++ tac2print.ml | 4 +- tac2print.mli | 9 +++ 9 files changed, 533 insertions(+), 11 deletions(-) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index 30f5399a88..565be4a199 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -16,11 +16,12 @@ open Misctypes open Tac2expr open Ltac_plugin -let tac2expr = Gram.entry_create "tactic:tac2expr" +let tac2expr = Tac2entries.Pltac.tac2expr let tac2type = Gram.entry_create "tactic:tac2type" let tac2def_val = Gram.entry_create "tactic:tac2def_val" let tac2def_typ = Gram.entry_create "tactic:tac2def_typ" let tac2def_ext = Gram.entry_create "tactic:tac2def_ext" +let tac2def_syn = Gram.entry_create "tactic:tac2def_syn" let tac2mode = Gram.entry_create "vernac:ltac2_command" let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) @@ -29,7 +30,7 @@ let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c let inj_ident loc c = inj_wit Stdarg.wit_ident loc c GEXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext; + GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn; tac2pat: [ "1" LEFTA [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> CPatRef (!@loc, RelId id, pl) @@ -194,6 +195,30 @@ GEXTEND Gram StrPrm (id, t, ml) ] ] ; + syn_node: + [ [ "_" -> (!@loc, None) + | id = Prim.ident -> (!@loc, Some id) + ] ] + ; + sexpr: + [ [ s = Prim.string -> SexprStr (!@loc, s) + | n = Prim.integer -> SexprInt (!@loc, n) + | id = syn_node -> SexprRec (!@loc, id, []) + | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + SexprRec (!@loc, id, tok) + ] ] + ; + syn_level: + [ [ -> None + | ":"; n = Prim.integer -> Some n + ] ] + ; + tac2def_syn: + [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; + e = tac2expr -> + StrSyn (toks, n, e) + ] ] + ; END GEXTEND Gram @@ -212,6 +237,7 @@ PRINTED BY pr_ltac2entry | [ tac2def_val(v) ] -> [ v ] | [ tac2def_typ(t) ] -> [ t ] | [ tac2def_ext(e) ] -> [ e ] +| [ tac2def_syn(e) ] -> [ e ] END VERNAC COMMAND EXTEND VernacDeclareTactic2Definition CLASSIFIED AS SIDEFF @@ -250,3 +276,4 @@ open Stdarg VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF | [ "Print" "Ltac2" reference(tac) ] -> [ Tac2entries.print_ltac tac ] END + diff --git a/tac2core.ml b/tac2core.ml index 3232fcba5b..ad238e6b8f 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -48,10 +48,14 @@ let t_unit = coq_core "unit" let t_list = coq_core "list" let t_constr = coq_core "constr" let t_ident = coq_core "ident" +let t_option = coq_core "option" let c_nil = coq_core "[]" let c_cons = coq_core "::" +let c_none = coq_core "None" +let c_some = coq_core "Some" + end open Core @@ -464,7 +468,6 @@ let interp_constr flags ist (c, _) = end let () = - let open Pretyping in let interp ist c = interp_constr (constr_flags ()) ist c in let obj = { ml_type = t_constr; @@ -473,7 +476,6 @@ let () = define_ml_object Stdarg.wit_constr obj let () = - let open Pretyping in let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in let obj = { ml_type = t_constr; @@ -502,3 +504,71 @@ let () = (EConstr.of_constr c, sigma) in Pretyping.register_constr_interp0 wit_ltac2 interp + +(** Built-in notation scopes *) + +let add_scope s f = + Tac2entries.register_scope (Id.of_string s) f + +let scope_fail () = CErrors.user_err (str "Invalid parsing token") + +let rthunk e = + let loc = Tac2intern.loc_of_tacexpr e in + let var = [(loc, Anonymous), Some (CTypRef (loc, AbsKn Core.t_unit, []))] in + CTacFun (loc, var, e) + +let add_generic_scope s entry arg = + let parse = function + | [] -> + let scope = Extend.Aentry entry in + let act x = rthunk (CTacExt (Loc.ghost, in_gen (rawwit arg) x)) in + Tac2entries.ScopeRule (scope, act) + | _ -> scope_fail () + in + add_scope s parse + +let () = add_scope "list0" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist0 scope in + let act l = + let l = List.map act l in + CTacLst (Loc.ghost, l) + in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr (_, str)] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist0sep (scope, sep) in + let act l = + let l = List.map act l in + CTacLst (Loc.ghost, l) + in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "opt" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Aopt scope in + let act opt = match opt with + | None -> + CTacRef (AbsKn (TacConstructor Core.c_none)) + | Some x -> + CTacApp (Loc.ghost, CTacRef (AbsKn (TacConstructor Core.c_some)), [act x]) + in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "self" begin function +| [] -> + let scope = Extend.Aself in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_generic_scope "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr diff --git a/tac2entries.ml b/tac2entries.ml index 374a367188..fbfc687ee7 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -19,6 +19,13 @@ open Tac2print open Tac2intern open Vernacexpr +(** Grammar entries *) + +module Pltac = +struct +let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" +end + (** Tactic definition *) type tacdef = { @@ -98,8 +105,6 @@ let next i = let () = incr i in ans -let dummy_var i = Id.of_string (Printf.sprintf "_%i" i) - let define_typedef kn (params, def as qdef) = match def with | GTydDef _ -> Tac2env.define_type kn qdef @@ -435,10 +440,147 @@ let register_type ?local isrec types = match types with let types = List.map map types in register_typedef ?local isrec types +(** Parsing *) + +type 'a token = +| TacTerm of string +| TacNonTerm of Name.t * 'a + +type scope_rule = +| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty + +let register_scope id s = + scope_table := Id.Map.add id s !scope_table + +module ParseToken = +struct + +let loc_of_token = function +| SexprStr (loc, _) -> loc +| SexprInt (loc, _) -> loc +| SexprRec (loc, _, _) -> loc + +let parse_scope = function +| SexprRec (_, (loc, Some id), toks) -> + if Id.Map.mem id !scope_table then + Id.Map.find id !scope_table toks + else + CErrors.user_err ~loc (str "Unknown scope" ++ spc () ++ Nameops.pr_id id) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ~loc (str "Invalid parsing token") + +let parse_token = function +| SexprStr (_, s) -> TacTerm s +| SexprRec (_, (_, na), [tok]) -> + let na = match na with None -> Anonymous | Some id -> Name id in + let scope = parse_scope tok in + TacNonTerm (na, scope) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ~loc (str "Invalid parsing token") + +end + +let parse_scope = ParseToken.parse_scope + +type synext = { + synext_tok : sexpr list; + synext_exp : raw_tacexpr; + synext_lev : int option; + synext_loc : bool; +} + +type krule = +| KRule : + (raw_tacexpr, 'act, Loc.t -> raw_tacexpr) Extend.rule * + ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule + +let rec get_rule (tok : scope_rule token list) : krule = match tok with +| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, scope) in + let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in + KRule (rule, act) +| TacTerm t :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let act k _ = act k in + KRule (rule, act) + +let perform_notation syn st = + let tok = List.rev_map ParseToken.parse_token syn.synext_tok in + let KRule (rule, act) = get_rule tok in + let mk loc args = + let map (na, e) = + let loc = loc_of_tacexpr e in + ((loc, na), None, e) + in + let bnd = List.map map args in + CTacLet (loc, false, bnd, syn.synext_exp) + in + let rule = Extend.Rule (rule, act mk) in + let lev = match syn.synext_lev with + | None -> None + | Some lev -> Some (string_of_int lev) + in + let rule = (lev, None, [rule]) in + ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) + +let ltac2_notation = + Pcoq.create_grammar_command "ltac2-notation" perform_notation + +let cache_synext (_, syn) = + Pcoq.extend_grammar_command ltac2_notation syn + +let open_synext i (_, syn) = + if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn + +let subst_synext (subst, syn) = + let e = Tac2intern.subst_rawexpr subst syn.synext_exp in + if e == syn.synext_exp then syn else { syn with synext_exp = e } + +let classify_synext o = + if o.synext_loc then Dispose else Substitute o + +let inTac2Notation : synext -> obj = + declare_object {(default_object "TAC2-NOTATION") with + cache_function = cache_synext; + open_function = open_synext; + subst_function = subst_synext; + classify_function = classify_synext} + +let register_notation ?(local = false) tkn lev body = + (** Check that the tokens make sense *) + let entries = List.map ParseToken.parse_token tkn in + let fold accu tok = match tok with + | TacTerm _ -> accu + | TacNonTerm (Name id, _) -> Id.Set.add id accu + | TacNonTerm (Anonymous, _) -> accu + in + let ids = List.fold_left fold Id.Set.empty entries in + (** Globalize so that names are absolute *) + let body = Tac2intern.globalize ids body in + let ext = { + synext_tok = tkn; + synext_exp = body; + synext_lev = lev; + synext_loc = local; + } in + Lib.add_anonymous_leaf (inTac2Notation ext) + +(** Toplevel entries *) + let register_struct ?local str = match str with | StrVal (isrec, e) -> register_ltac ?local isrec e | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml +| StrSyn (tok, lev, e) -> register_notation ?local tok lev e (** Printing *) diff --git a/tac2entries.mli b/tac2entries.mli index 0d9b3ad134..71e8150057 100644 --- a/tac2entries.mli +++ b/tac2entries.mli @@ -24,6 +24,22 @@ val register_primitive : ?local:bool -> val register_struct : ?local:bool -> strexpr -> unit +val register_notation : ?local:bool -> sexpr list -> int option -> + raw_tacexpr -> unit + +(** {5 Notations} *) + +type scope_rule = +| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +val register_scope : Id.t -> scope_interpretation -> unit +(** Create a new scope with the provided name *) + +val parse_scope : sexpr -> scope_rule +(** Use this to interpret the subscopes for interpretation functions *) + (** {5 Inspecting} *) val print_ltac : Libnames.reference -> unit @@ -32,3 +48,10 @@ val print_ltac : Libnames.reference -> unit (** Evaluate a tactic expression in the current environment *) val call : default:bool -> raw_tacexpr -> unit + +(** {5 Parsing entries} *) + +module Pltac : +sig +val tac2expr : raw_tacexpr Pcoq.Gram.entry +end diff --git a/tac2expr.mli b/tac2expr.mli index 63207ac78f..acdad9bab4 100644 --- a/tac2expr.mli +++ b/tac2expr.mli @@ -129,7 +129,23 @@ type glb_tacexpr = | GTacExt of glob_generic_argument | GTacPrm of ml_tactic_name * glb_tacexpr list -(** Toplevel statements *) +(** {5 Parsing & Printing} *) + +type exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +type sexpr = +| SexprStr of string located +| SexprInt of int located +| SexprRec of Loc.t * Id.t option located * sexpr list + +(** {5 Toplevel statements} *) + type strexpr = | StrVal of rec_flag * (Name.t located * raw_tacexpr) list (** Term definition *) @@ -137,6 +153,9 @@ type strexpr = (** Type definition *) | StrPrm of Id.t located * raw_typexpr * ml_tactic_name (** External definition *) +| StrSyn of sexpr list * int option * raw_tacexpr + (** Syntactic extensions *) + (** {5 Dynamic semantics} *) diff --git a/tac2intern.ml b/tac2intern.ml index c7e02a7b06..17d08b2285 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -476,10 +476,10 @@ let check_redundant_clause = function | [] -> () | (p, _) :: _ -> warn_redundant_clause ~loc:(loc_of_patexpr p) () -let get_variable env var = match var with +let get_variable0 mem var = match var with | RelId (loc, qid) -> let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp && Id.Map.mem id env.env_var then ArgVar (loc, id) + if DirPath.is_empty dp && mem id then ArgVar (loc, id) else let kn = try Tac2env.locate_ltac qid @@ -489,6 +489,10 @@ let get_variable env var = match var with ArgArg kn | AbsKn kn -> ArgArg kn +let get_variable env var = + let mem id = Id.Map.mem id env.env_var in + get_variable0 mem var + let get_constructor env var = match var with | RelId (loc, qid) -> let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in @@ -1106,6 +1110,104 @@ let intern_open_type t = let t = normalize env (count, vars) t in (!count, t) +(** Globalization *) + +let add_name accu = function +| Name id -> Id.Set.add id accu +| Anonymous -> accu + +let get_projection0 var = match var with +| RelId (loc, qid) -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ~loc (pr_qualid qid ++ str " is not a projection") + in + kn +| AbsKn kn -> kn + +let rec globalize ids e = match e with +| CTacAtm _ -> e +| CTacRef ref -> + let mem id = Id.Set.mem id ids in + begin match get_variable0 mem ref with + | ArgVar _ -> e + | ArgArg kn -> CTacRef (AbsKn kn) + end +| CTacFun (loc, bnd, e) -> + let fold accu ((_, na), _) = add_name accu na in + let ids = List.fold_left fold ids bnd in + let e = globalize ids e in + CTacFun (loc, bnd, e) +| CTacApp (loc, e, el) -> + let e = globalize ids e in + let el = List.map (fun e -> globalize ids e) el in + CTacApp (loc, e, el) +| CTacLet (loc, isrec, bnd, e) -> + let fold accu ((_, na), _, _) = add_name accu na in + let ext = List.fold_left fold Id.Set.empty bnd in + let eids = Id.Set.union ext ids in + let e = globalize eids e in + let map (qid, t, e) = + let ids = if isrec then eids else ids in + (qid, t, globalize ids e) + in + let bnd = List.map map bnd in + CTacLet (loc, isrec, bnd, e) +| CTacTup (loc, el) -> + let el = List.map (fun e -> globalize ids e) el in + CTacTup (loc, el) +| CTacArr (loc, el) -> + let el = List.map (fun e -> globalize ids e) el in + CTacArr (loc, el) +| CTacLst (loc, el) -> + let el = List.map (fun e -> globalize ids e) el in + CTacLst (loc, el) +| CTacCnv (loc, e, t) -> + let e = globalize ids e in + CTacCnv (loc, e, t) +| CTacSeq (loc, e1, e2) -> + let e1 = globalize ids e1 in + let e2 = globalize ids e2 in + CTacSeq (loc, e1, e2) +| CTacCse (loc, e, bl) -> + let e = globalize ids e in + let bl = List.map (fun b -> globalize_case ids b) bl in + CTacCse (loc, e, bl) +| CTacRec (loc, r) -> + let map (p, e) = + let p = get_projection0 p in + let e = globalize ids e in + (AbsKn p, e) + in + CTacRec (loc, List.map map r) +| CTacPrj (loc, e, p) -> + let e = globalize ids e in + let p = get_projection0 p in + CTacPrj (loc, e, AbsKn p) +| CTacSet (loc, e, p, e') -> + let e = globalize ids e in + let p = get_projection0 p in + let e' = globalize ids e' in + CTacSet (loc, e, AbsKn p, e') +| CTacExt (loc, arg) -> + let arg = pr_argument_type (genarg_tag arg) in + CErrors.user_err ~loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) + +and globalize_case ids (p, e) = + (globalize_pattern ids p, globalize ids e) + +and globalize_pattern ids p = match p with +| CPatAny _ -> p +| CPatRef (loc, cst, pl) -> + let cst = match get_constructor () cst with + | ArgVar _ -> cst + | ArgArg (_, knc) -> AbsKn knc + in + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CPatRef (loc, cst, pl) +| CPatTup (loc, pl) -> + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CPatTup (loc, pl) + (** Kernel substitution *) open Mod_subst @@ -1213,6 +1315,128 @@ let subst_type_scheme subst (prm, t as sch) = let t' = subst_type subst t in if t' == t then sch else (prm, t') +let subst_or_relid subst ref = match ref with +| RelId _ -> ref +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn kn' + +let rec subst_rawtype subst t = match t with +| CTypVar _ -> t +| CTypArrow (loc, t1, t2) -> + let t1' = subst_rawtype subst t1 in + let t2' = subst_rawtype subst t2 in + if t1' == t1 && t2' == t2 then t else CTypArrow (loc, t1', t2') +| CTypTuple (loc, tl) -> + let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in + if tl' == tl then t else CTypTuple (loc, tl') +| CTypRef (loc, ref, tl) -> + let ref' = subst_or_relid subst ref in + let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in + if ref' == ref && tl' == tl then t else CTypRef (loc, ref', tl') + +let subst_tacref subst ref = match ref with +| RelId _ -> ref +| AbsKn (TacConstant kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstant kn') +| AbsKn (TacConstructor kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstructor kn') + +let subst_projection subst prj = match prj with +| RelId _ -> prj +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then prj else AbsKn kn' + +let rec subst_rawpattern subst p = match p with +| CPatAny _ -> p +| CPatRef (loc, c, pl) -> + let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in + let c' = match c with + | RelId _ -> c + | AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then c else AbsKn kn' + in + if pl' == pl && c' == c then p else CPatRef (loc, c', pl') +| CPatTup (loc, pl) -> + let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in + if pl' == pl then p else CPatTup (loc, pl') + +(** Used for notations *) +let rec subst_rawexpr subst t = match t with +| CTacAtm _ -> t +| CTacRef ref -> + let ref' = subst_tacref subst ref in + if ref' == ref then t else CTacRef ref' +| CTacFun (loc, bnd, e) -> + let map (na, t as p) = + let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in + if t' == t then p else (na, t') + in + let bnd' = List.smartmap map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CTacFun (loc, bnd', e') +| CTacApp (loc, e, el) -> + let e' = subst_rawexpr subst e in + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if e' == e && el' == el then t else CTacApp (loc, e', el') +| CTacLet (loc, isrec, bnd, e) -> + let map (na, t, e as p) = + let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in + let e' = subst_rawexpr subst e in + if t' == t && e' == e then p else (na, t', e') + in + let bnd' = List.smartmap map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CTacLet (loc, isrec, bnd', e') +| CTacTup (loc, el) -> + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if el' == el then t else CTacTup (loc, el') +| CTacArr (loc, el) -> + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if el' == el then t else CTacArr (loc, el') +| CTacLst (loc, el) -> + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if el' == el then t else CTacLst (loc, el') +| CTacCnv (loc, e, c) -> + let e' = subst_rawexpr subst e in + let c' = subst_rawtype subst c in + if c' == c && e' == e then t else CTacCnv (loc, e', c') +| CTacSeq (loc, e1, e2) -> + let e1' = subst_rawexpr subst e1 in + let e2' = subst_rawexpr subst e2 in + if e1' == e1 && e2' == e2 then t else CTacSeq (loc, e1', e2') +| CTacCse (loc, e, bl) -> + let map (p, e as x) = + let p' = subst_rawpattern subst p in + let e' = subst_rawexpr subst e in + if p' == p && e' == e then x else (p', e') + in + let e' = subst_rawexpr subst e in + let bl' = List.smartmap map bl in + if e' == e && bl' == bl then t else CTacCse (loc, e', bl') +| CTacRec (loc, el) -> + let map (prj, e as p) = + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then p else (prj', e') + in + let el' = List.smartmap map el in + if el' == el then t else CTacRec (loc, el') +| CTacPrj (loc, e, prj) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then t else CTacPrj (loc, e', prj') +| CTacSet (loc, e, prj, r) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + let r' = subst_rawexpr subst r in + if prj' == prj && e' == e && r' == r then t else CTacSet (loc, e', prj', r') +| CTacExt _ -> assert false (** Should not be generated by gloabalization *) + (** Registering *) let () = diff --git a/tac2intern.mli b/tac2intern.mli index 4c482d0b0c..3d400a5cdd 100644 --- a/tac2intern.mli +++ b/tac2intern.mli @@ -27,6 +27,14 @@ val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef val subst_type_scheme : substitution -> type_scheme -> type_scheme +val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr + +(** {5 Notations} *) + +val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr +(** Replaces all qualified identifiers by their corresponding kernel name. The + set represents bound variables in the context. *) + (** Errors *) val error_nargs_mismatch : Loc.t -> int -> int -> 'a diff --git a/tac2print.ml b/tac2print.ml index ffa5ddc05a..e6f0582e3d 100644 --- a/tac2print.ml +++ b/tac2print.ml @@ -33,7 +33,7 @@ type typ_level = let pr_typref kn = Libnames.pr_qualid (Tac2env.shortest_qualid_of_type kn) -let rec pr_glbtype_gen pr lvl c = +let pr_glbtype_gen pr lvl c = let rec pr_glbtype lvl = function | GTypVar n -> str "'" ++ str (pr n) | GTypRef (kn, []) -> pr_typref kn @@ -88,7 +88,7 @@ let pr_constructor kn = let pr_projection kn = Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) -type exp_level = +type exp_level = Tac2expr.exp_level = | E5 | E4 | E3 diff --git a/tac2print.mli b/tac2print.mli index 94555a4c95..ddd599641d 100644 --- a/tac2print.mli +++ b/tac2print.mli @@ -12,13 +12,22 @@ open Tac2expr (** {5 Printing types} *) +type typ_level = +| T5_l +| T5_r +| T2 +| T1 +| T0 + val pr_typref : type_constant -> std_ppcmds +val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> std_ppcmds val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> std_ppcmds (** {5 Printing expressions} *) val pr_constructor : ltac_constructor -> std_ppcmds val pr_projection : ltac_projection -> std_ppcmds +val pr_glbexpr_gen : exp_level -> glb_tacexpr -> std_ppcmds val pr_glbexpr : glb_tacexpr -> std_ppcmds (** {5 Utilities} *) -- cgit v1.2.3 From df1c50b36f4927fdf64a3ed99a4a077f5175ac5e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 16 May 2017 18:03:55 +0200 Subject: Removing dead code in Ltac2, and cleaning up a bit. --- g_ltac2.ml4 | 1 - tac2core.ml | 12 ------------ tac2core.mli | 9 +++++++++ tac2entries.ml | 1 - tac2env.ml | 1 - tac2intern.ml | 3 --- 6 files changed, 9 insertions(+), 18 deletions(-) diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 index 565be4a199..51919addf2 100644 --- a/g_ltac2.ml4 +++ b/g_ltac2.ml4 @@ -8,7 +8,6 @@ open Pp open Util -open Genarg open Names open Pcoq open Constrexpr diff --git a/tac2core.ml b/tac2core.ml index ad238e6b8f..13395c87b3 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -8,7 +8,6 @@ open CSig open Pp -open CErrors open Names open Genarg open Geninterp @@ -20,10 +19,6 @@ open Proofview.Notations (** Standard values *) let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) -let stdlib_prefix md = - MPfile (DirPath.make (List.map Id.of_string [md; "ltac2"; "Coq"])) -let coq_stdlib md n = - KerName.make2 (stdlib_prefix md) (Label.of_id (Id.of_string n)) let val_tag t = match val_tag t with | Val.Base t -> t @@ -141,9 +136,6 @@ let err_notfocussed = let err_outofbounds = LtacError (coq_core "Out_of_bounds", [||]) -let err_notfound = - LtacError (coq_core "Not_found", [||]) - (** Helper functions *) let thaw f = interp_app f [v_unit] @@ -158,10 +150,6 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit -let wrap_exn f err = - return () >>= fun () -> - try return (f ()) with e when CErrors.noncritical e -> err - let pf_apply f = Proofview.Goal.goals >>= function | [] -> diff --git a/tac2core.mli b/tac2core.mli index 27144bc6e2..fc90499ac6 100644 --- a/tac2core.mli +++ b/tac2core.mli @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Names open Tac2env open Tac2expr @@ -18,6 +19,11 @@ val t_list : type_constant val c_nil : ltac_constant val c_cons : ltac_constant +val t_int : type_constant +val t_option : type_constant +val t_string : type_constant +val t_array : type_constant + end (** {5 Ltac2 FFI} *) @@ -50,4 +56,7 @@ val to_constr : valexpr -> EConstr.t val of_exn : Exninfo.iexn -> valexpr val to_exn : valexpr -> Exninfo.iexn +val of_ident : Id.t -> valexpr +val to_ident : valexpr -> Id.t + end diff --git a/tac2entries.ml b/tac2entries.ml index fbfc687ee7..3959e705ed 100644 --- a/tac2entries.ml +++ b/tac2entries.ml @@ -13,7 +13,6 @@ open Names open Libnames open Libobject open Nametab -open Tac2env open Tac2expr open Tac2print open Tac2intern diff --git a/tac2env.ml b/tac2env.ml index a36d022e4d..5ccdd018ee 100644 --- a/tac2env.ml +++ b/tac2env.ml @@ -8,7 +8,6 @@ open CErrors open Util -open Genarg open Names open Libnames open Tac2expr diff --git a/tac2intern.ml b/tac2intern.ml index 17d08b2285..756bbe3076 100644 --- a/tac2intern.ml +++ b/tac2intern.ml @@ -39,7 +39,6 @@ type 'a t val equal : elt -> elt -> bool val create : unit -> 'a t val fresh : 'a t -> elt -val size : 'a t -> int val find : elt -> 'a t -> (elt * 'a option) val union : elt -> elt -> 'a t -> unit val set : elt -> 'a -> 'a t -> unit @@ -69,8 +68,6 @@ type 'a t = { mutable uf_size : int; } -let size p = p.uf_size - let resize p = if Int.equal (Array.length p.uf_data) p.uf_size then begin let nsize = 2 * p.uf_size + 1 in -- cgit v1.2.3 From 6a4d15c6ce3994509085ef575cc2f242925af15a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 16 May 2017 18:14:40 +0200 Subject: Extending the Coq API in Ltac2. --- Constr.v | 34 ++++++++++++++++++++++++++++++++++ Control.v | 5 +++++ Init.v | 12 +++++++++++- tac2core.ml | 41 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 91 insertions(+), 1 deletion(-) diff --git a/Constr.v b/Constr.v index 994f9bf3ac..9e5833a778 100644 --- a/Constr.v +++ b/Constr.v @@ -7,3 +7,37 @@ (************************************************************************) Require Import Coq.ltac2.Init. + +Ltac2 @ external type : constr -> constr := "ltac2" "constr_type". +(** Return the type of a term *) + +Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". +(** Strict syntactic equality: only up to α-conversion and evar expansion *) + +Module Unsafe. + +(** Low-level access to kernel term. Use with care! *) + +Ltac2 Type kind := [ +| Rel (int) +| Var (ident) +| Meta (meta) +| Evar (evar, constr list) +| Sort (sort) +| Cast (constr, cast, constr) +| Prod (ident option, constr, constr) +| Lambda (ident option, constr, constr) +| LetIn (ident option, constr, constr, constr) +| App (constr, constr list) +| Constant (constant, instance) +| Ind (inductive, instance) +| Constructor (inductive, instance) +(* + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint +*) +| Proj (projection, constr) +]. + +End Unsafe. diff --git a/Control.v b/Control.v index a476513ede..6b3b360abb 100644 --- a/Control.v +++ b/Control.v @@ -28,6 +28,11 @@ Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". +Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". +(** Adds the given evar to the list of goals as the last one. If it is + already defined in the current state, don't do anything. Panics if the + evar is not in the current state. *) + (** Goal inspection *) Ltac2 @ external goal : unit -> constr := "ltac2" "goal". diff --git a/Init.v b/Init.v index 8ff5837bb4..1d2d40f5c0 100644 --- a/Init.v +++ b/Init.v @@ -15,10 +15,20 @@ Global Set Default Proof Mode "Ltac2". Ltac2 Type int. Ltac2 Type string. Ltac2 Type char. +Ltac2 Type ident. +(** Constr-specific built-in types *) +Ltac2 Type meta. Ltac2 Type evar. +Ltac2 Type sort. +Ltac2 Type cast. +Ltac2 Type instance. +Ltac2 Type constant. +Ltac2 Type inductive. +Ltac2 Type constructor. +Ltac2 Type projection. Ltac2 Type constr. -Ltac2 Type ident. + Ltac2 Type message. Ltac2 Type exn := [ .. ]. Ltac2 Type 'a array. diff --git a/tac2core.ml b/tac2core.ml index 13395c87b3..94758eb217 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -136,6 +136,9 @@ let err_notfocussed = let err_outofbounds = LtacError (coq_core "Out_of_bounds", [||]) +let err_notfound = + LtacError (coq_core "Not_found", [||]) + (** Helper functions *) let thaw f = interp_app f [v_unit] @@ -270,6 +273,31 @@ let prm_string_get : ml_tactic = function else wrap (fun () -> Value.of_char (Bytes.get s n)) | _ -> assert false +(** Terms *) + +(** constr -> constr *) +let prm_constr_type : ml_tactic = function +| [c] -> + let c = Value.to_constr c in + let get_type env sigma = + Proofview.V82.wrap_exceptions begin fun () -> + let (sigma, t) = Typing.type_of env sigma c in + let t = Value.of_constr t in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t + end in + pf_apply get_type +| _ -> assert false + +(** constr -> constr *) +let prm_constr_equal : ml_tactic = function +| [c1; c2] -> + let c1 = Value.to_constr c1 in + let c2 = Value.to_constr c2 in + Proofview.tclEVARMAP >>= fun sigma -> + let b = EConstr.eq_constr sigma c1 c2 in + Proofview.tclUNIT (Value.of_bool b) +| _ -> assert false + (** Error *) let prm_throw : ml_tactic = function @@ -342,6 +370,15 @@ let prm_shelve_unifiable : ml_tactic = function | [_] -> Proofview.shelve_unifiable >>= fun () -> return v_unit | _ -> assert false +let prm_new_goal : ml_tactic = function +| [ev] -> + let ev = Evar.unsafe_of_int (Value.to_int ev) in + Proofview.tclEVARMAP >>= fun sigma -> + if Evd.mem sigma ev then + Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit + else throw err_notfound +| _ -> assert false + (** unit -> constr *) let prm_goal : ml_tactic = function | [_] -> @@ -391,6 +428,9 @@ let () = Tac2env.define_primitive (pname "string_length") prm_string_length let () = Tac2env.define_primitive (pname "string_get") prm_string_get let () = Tac2env.define_primitive (pname "string_set") prm_string_set +let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type +let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal + let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare let () = Tac2env.define_primitive (pname "int_neg") prm_int_neg @@ -410,6 +450,7 @@ let () = Tac2env.define_primitive (pname "enter") prm_enter let () = Tac2env.define_primitive (pname "focus") prm_focus let () = Tac2env.define_primitive (pname "shelve") prm_shelve let () = Tac2env.define_primitive (pname "shelve_unifiable") prm_shelve_unifiable +let () = Tac2env.define_primitive (pname "new_goal") prm_new_goal let () = Tac2env.define_primitive (pname "goal") prm_goal let () = Tac2env.define_primitive (pname "hyp") prm_hyp let () = Tac2env.define_primitive (pname "refine") prm_refine -- cgit v1.2.3 From 0bfa6d3cda461f4d09ec0bfa9781042199b1f43b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 May 2017 15:25:58 +0200 Subject: Adding new tactic notation scopes. --- tac2core.ml | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/tac2core.ml b/tac2core.ml index 94758eb217..c82893efc2 100644 --- a/tac2core.ml +++ b/tac2core.ml @@ -577,6 +577,27 @@ let () = add_scope "list0" begin function | _ -> scope_fail () end +let () = add_scope "list1" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist1 scope in + let act l = + let l = List.map act l in + CTacLst (Loc.ghost, l) + in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr (_, str)] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist1sep (scope, sep) in + let act l = + let l = List.map act l in + CTacLst (Loc.ghost, l) + in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + let () = add_scope "opt" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in @@ -599,5 +620,27 @@ let () = add_scope "self" begin function | _ -> scope_fail () end +let () = add_scope "next" begin function +| [] -> + let scope = Extend.Anext in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "tactic" begin function +| [] -> + (** Default to level 5 parsing *) + let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, 5) in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| [SexprInt (loc, n)] -> + let () = if n < 0 || n > 5 then scope_fail () in + let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, n) in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + let () = add_generic_scope "ident" Pcoq.Prim.ident Stdarg.wit_ident let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr -- cgit v1.2.3 From c25e86e6b4e8bb694d3c8e50f04a92cc33ad807d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 17:41:01 +0200 Subject: Turning the ltac2 subfolder into a standalone plugin. --- .gitignore | 14 + Array.v | 14 - Constr.v | 43 -- Control.v | 49 -- Init.v | 56 -- Int.v | 18 - LICENSE | 458 +++++++++++++++ Ltac2.v | 16 - Makefile | 12 + Message.v | 20 - README.md | 0 String.v | 14 - _CoqProject | 28 + g_ltac2.ml4 | 278 --------- ltac2_plugin.mlpack | 7 - src/g_ltac2.ml4 | 278 +++++++++ src/ltac2_plugin.mlpack | 7 + src/tac2core.ml | 648 +++++++++++++++++++++ src/tac2core.mli | 62 ++ src/tac2entries.ml | 648 +++++++++++++++++++++ src/tac2entries.mli | 57 ++ src/tac2env.ml | 242 ++++++++ src/tac2env.mli | 106 ++++ src/tac2expr.mli | 195 +++++++ src/tac2intern.ml | 1454 +++++++++++++++++++++++++++++++++++++++++++++++ src/tac2intern.mli | 41 ++ src/tac2interp.ml | 160 ++++++ src/tac2interp.mli | 28 + src/tac2print.ml | 296 ++++++++++ src/tac2print.mli | 37 ++ tac2core.ml | 646 --------------------- tac2core.mli | 62 -- tac2entries.ml | 645 --------------------- tac2entries.mli | 57 -- tac2env.ml | 242 -------- tac2env.mli | 106 ---- tac2expr.mli | 195 ------- tac2intern.ml | 1452 ---------------------------------------------- tac2intern.mli | 41 -- tac2interp.ml | 160 ------ tac2interp.mli | 28 - tac2print.ml | 296 ---------- tac2print.mli | 37 -- theories/Array.v | 14 + theories/Constr.v | 43 ++ theories/Control.v | 49 ++ theories/Init.v | 56 ++ theories/Int.v | 18 + theories/Ltac2.v | 16 + theories/Message.v | 20 + theories/String.v | 14 + 51 files changed, 5001 insertions(+), 4482 deletions(-) create mode 100644 .gitignore delete mode 100644 Array.v delete mode 100644 Constr.v delete mode 100644 Control.v delete mode 100644 Init.v delete mode 100644 Int.v create mode 100644 LICENSE delete mode 100644 Ltac2.v create mode 100644 Makefile delete mode 100644 Message.v create mode 100644 README.md delete mode 100644 String.v create mode 100644 _CoqProject delete mode 100644 g_ltac2.ml4 delete mode 100644 ltac2_plugin.mlpack create mode 100644 src/g_ltac2.ml4 create mode 100644 src/ltac2_plugin.mlpack create mode 100644 src/tac2core.ml create mode 100644 src/tac2core.mli create mode 100644 src/tac2entries.ml create mode 100644 src/tac2entries.mli create mode 100644 src/tac2env.ml create mode 100644 src/tac2env.mli create mode 100644 src/tac2expr.mli create mode 100644 src/tac2intern.ml create mode 100644 src/tac2intern.mli create mode 100644 src/tac2interp.ml create mode 100644 src/tac2interp.mli create mode 100644 src/tac2print.ml create mode 100644 src/tac2print.mli delete mode 100644 tac2core.ml delete mode 100644 tac2core.mli delete mode 100644 tac2entries.ml delete mode 100644 tac2entries.mli delete mode 100644 tac2env.ml delete mode 100644 tac2env.mli delete mode 100644 tac2expr.mli delete mode 100644 tac2intern.ml delete mode 100644 tac2intern.mli delete mode 100644 tac2interp.ml delete mode 100644 tac2interp.mli delete mode 100644 tac2print.ml delete mode 100644 tac2print.mli create mode 100644 theories/Array.v create mode 100644 theories/Constr.v create mode 100644 theories/Control.v create mode 100644 theories/Init.v create mode 100644 theories/Int.v create mode 100644 theories/Ltac2.v create mode 100644 theories/Message.v create mode 100644 theories/String.v diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..ffdea1320c --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ +Makefile.coq +Makefile.coq.conf +*.glob +*.d +*.d.raw +*.vio +*.vo +*.cm* +*.annot +*.spit +*.spot +*.o +*.a +*.aux diff --git a/Array.v b/Array.v deleted file mode 100644 index be4ab025ae..0000000000 --- a/Array.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> 'a array := "ltac2" "array_make". -Ltac2 @external length : 'a array -> int := "ltac2" "array_length". -Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". -Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/Constr.v b/Constr.v deleted file mode 100644 index 9e5833a778..0000000000 --- a/Constr.v +++ /dev/null @@ -1,43 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr := "ltac2" "constr_type". -(** Return the type of a term *) - -Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". -(** Strict syntactic equality: only up to α-conversion and evar expansion *) - -Module Unsafe. - -(** Low-level access to kernel term. Use with care! *) - -Ltac2 Type kind := [ -| Rel (int) -| Var (ident) -| Meta (meta) -| Evar (evar, constr list) -| Sort (sort) -| Cast (constr, cast, constr) -| Prod (ident option, constr, constr) -| Lambda (ident option, constr, constr) -| LetIn (ident option, constr, constr, constr) -| App (constr, constr list) -| Constant (constant, instance) -| Ind (inductive, instance) -| Constructor (inductive, instance) -(* - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint -*) -| Proj (projection, constr) -]. - -End Unsafe. diff --git a/Control.v b/Control.v deleted file mode 100644 index 6b3b360abb..0000000000 --- a/Control.v +++ /dev/null @@ -1,49 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a := "ltac2" "throw". -(** Fatal exception throwing. This does not induce backtracking. *) - -(** Generic backtracking control *) - -Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". -Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". -Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". -Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". -Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". -Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". - -(** Proof state manipulation *) - -Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". -Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". -Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". - -Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". -(** Adds the given evar to the list of goals as the last one. If it is - already defined in the current state, don't do anything. Panics if the - evar is not in the current state. *) - -(** Goal inspection *) - -Ltac2 @ external goal : unit -> constr := "ltac2" "goal". -(** Panics if there is not exactly one goal under focus. Otherwise returns - the conclusion of this goal. *) - -Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". -(** Panics if there is more than one goal under focus. If there is no - goal under focus, looks for the section variable with the given name. - If there is one, looks for the hypothesis with the given name. *) - -(** Refinement *) - -Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". diff --git a/Init.v b/Init.v deleted file mode 100644 index 1d2d40f5c0..0000000000 --- a/Init.v +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* int -> bool := "ltac2" "int_equal". -Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". -Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". -Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". -Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". -Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000000..27950e8d20 --- /dev/null +++ b/LICENSE @@ -0,0 +1,458 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/Ltac2.v b/Ltac2.v deleted file mode 100644 index 625d4ac513..0000000000 --- a/Ltac2.v +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit := "ltac2" "print". - -Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". - -Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". - -Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". -(** Panics if there is more than one goal under focus. *) - -Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/README.md b/README.md new file mode 100644 index 0000000000..e69de29bb2 diff --git a/String.v b/String.v deleted file mode 100644 index 3a4a178878..0000000000 --- a/String.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* char -> string := "ltac2" "string_make". -Ltac2 @external length : string -> int := "ltac2" "string_length". -Ltac2 @external get : string -> int -> char := "ltac2" "string_get". -Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/_CoqProject b/_CoqProject new file mode 100644 index 0000000000..90338abbfb --- /dev/null +++ b/_CoqProject @@ -0,0 +1,28 @@ +-R theories/ Ltac2 +-I src/ +-bypass-API + +src/tac2expr.mli +src/tac2env.ml +src/tac2env.mli +src/tac2print.ml +src/tac2print.mli +src/tac2intern.ml +src/tac2intern.mli +src/tac2interp.ml +src/tac2interp.mli +src/tac2entries.ml +src/tac2entries.mli +src/tac2core.ml +src/tac2core.mli +src/g_ltac2.ml4 +src/ltac2_plugin.mlpack + +theories/Init.v +theories/Int.v +theories/String.v +theories/Array.v +theories/Control.v +theories/Message.v +theories/Constr.v +theories/Ltac2.v diff --git a/g_ltac2.ml4 b/g_ltac2.ml4 deleted file mode 100644 index 51919addf2..0000000000 --- a/g_ltac2.ml4 +++ /dev/null @@ -1,278 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* CPatRef (!@loc, RelId id, pl) - | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) ] - | "0" - [ "_" -> CPatAny (!@loc) - | "()" -> CPatTup (!@loc, []) - | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) - | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> CPatTup (!@loc, pl) ] - ] - ; - tac2expr: - [ "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "5" -> CTacFun (!@loc, it, body) - | "let"; isrec = rec_flag; - lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "5" -> CTacLet (!@loc, isrec, lc, e) - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches ;"end" -> - CTacCse (!@loc, e, bl) - ] - | "2" LEFTA - [ e1 = tac2expr; ";"; e2 = tac2expr -> CTacSeq (!@loc, e1, e2) ] - | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) - | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, RelId qid, r) - | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> CTacTup (!@loc, e0 :: el) ] - | "0" - [ "("; a = tac2expr LEVEL "5"; ")" -> a - | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) - | "()" -> CTacTup (!@loc, []) - | "("; ")" -> CTacTup (!@loc, []) - | "["; a = LIST0 tac2expr LEVEL "1" SEP ";"; "]" -> CTacLst (!@loc, a) - | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) - | a = tactic_atom -> a ] - ] - ; - branches: - [ [ -> [] - | "|"; bl = LIST1 branch SEP "|" -> bl - | bl = LIST1 branch SEP "|" -> bl ] - ] - ; - branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "5" -> (pat, e) ] ] - ; - rec_flag: - [ [ IDENT "rec" -> true - | -> false ] ] - ; - typ_param: - [ [ "'"; id = Prim.ident -> id ] ] - ; - tactic_atom: - [ [ n = Prim.integer -> CTacAtm (!@loc, AtmInt n) - | s = Prim.string -> CTacAtm (!@loc, AtmStr s) - | id = Prim.qualid -> CTacRef (RelId id) - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c - | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c - | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c - ] ] - ; - let_clause: - [ [ id = binder; ":="; te = tac2expr -> - (id, None, te) - | id = binder; args = LIST1 input_fun; ":="; te = tac2expr -> - (id, None, CTacFun (!@loc, args, te)) ] ] - ; - tac2type: - [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] - | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type SEP "*" -> CTypTuple (!@loc, t :: tl) ] - | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, RelId qid, [t]) ] - | "0" - [ "("; t = tac2type LEVEL "5"; ")" -> t - | id = typ_param -> CTypVar (!@loc, Name id) - | "_" -> CTypVar (!@loc, Anonymous) - | qid = Prim.qualid -> CTypRef (!@loc, RelId qid, []) - | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - CTypRef (!@loc, RelId qid, p) ] - ]; - locident: - [ [ id = Prim.ident -> (!@loc, id) ] ] - ; - binder: - [ [ "_" -> (!@loc, Anonymous) - | l = Prim.ident -> (!@loc, Name l) ] ] - ; - input_fun: - [ [ b = binder -> (b, None) - | "("; b = binder; ":"; t = tac2type; ")" -> (b, Some t) ] ] - ; - tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> - let e = if List.is_empty it then e else CTacFun (!@loc, it, e) in - (name, e) - ] ] - ; - tac2def_val: - [ [ isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> - StrVal (isrec, l) - ] ] - ; - tac2typ_knd: - [ [ t = tac2type -> CTydDef (Some t) - | "["; ".."; "]" -> CTydOpn - | "["; t = tac2alg_constructors; "]" -> CTydAlg t - | "{"; t = tac2rec_fields; "}"-> CTydRec t ] ] - ; - tac2alg_constructors: - [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> cs - | cs = LIST0 tac2alg_constructor SEP "|" -> cs ] ] - ; - tac2alg_constructor: - [ [ c = Prim.ident -> (c, []) - | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> (c, args) ] ] - ; - tac2rec_fields: - [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> f :: l - | f = tac2rec_field; ";" -> [f] - | f = tac2rec_field -> [f] - | -> [] ] ] - ; - tac2rec_field: - [ [ mut = [ -> false | IDENT "mutable" -> true]; id = Prim.ident; ":"; t = tac2type -> (id, mut, t) ] ] - ; - tac2rec_fieldexprs: - [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> f :: l - | f = tac2rec_fieldexpr; ";" -> [f] - | f = tac2rec_fieldexpr-> [f] - | -> [] ] ] - ; - tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> RelId qid, e ] ] - ; - tac2typ_prm: - [ [ -> [] - | id = typ_param -> [!@loc, id] - | "("; ids = LIST1 [ id = typ_param -> (!@loc, id) ] SEP "," ;")" -> ids - ] ] - ; - tac2typ_def: - [ [ prm = tac2typ_prm; id = Prim.qualid; (r, e) = tac2type_body -> (id, r, (prm, e)) ] ] - ; - tac2type_body: - [ [ -> false, CTydDef None - | ":="; e = tac2typ_knd -> false, e - | "::="; e = tac2typ_knd -> true, e - ] ] - ; - tac2def_typ: - [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> - StrTyp (isrec, l) - ] ] - ; - tac2def_ext: - [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; - plugin = Prim.string; name = Prim.string -> - let ml = { mltac_plugin = plugin; mltac_tactic = name } in - StrPrm (id, t, ml) - ] ] - ; - syn_node: - [ [ "_" -> (!@loc, None) - | id = Prim.ident -> (!@loc, Some id) - ] ] - ; - sexpr: - [ [ s = Prim.string -> SexprStr (!@loc, s) - | n = Prim.integer -> SexprInt (!@loc, n) - | id = syn_node -> SexprRec (!@loc, id, []) - | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> - SexprRec (!@loc, id, tok) - ] ] - ; - syn_level: - [ [ -> None - | ":"; n = Prim.integer -> Some n - ] ] - ; - tac2def_syn: - [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; - e = tac2expr -> - StrSyn (toks, n, e) - ] ] - ; -END - -GEXTEND Gram - Pcoq.Constr.operconstr: LEVEL "0" - [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CHole (!@loc, None, IntroAnonymous, Some arg) ] ] - ; -END - -let pr_ltac2entry _ = mt () (** FIXME *) -let pr_ltac2expr _ = mt () (** FIXME *) - -VERNAC ARGUMENT EXTEND ltac2_entry -PRINTED BY pr_ltac2entry -| [ tac2def_val(v) ] -> [ v ] -| [ tac2def_typ(t) ] -> [ t ] -| [ tac2def_ext(e) ] -> [ e ] -| [ tac2def_syn(e) ] -> [ e ] -END - -VERNAC COMMAND EXTEND VernacDeclareTactic2Definition CLASSIFIED AS SIDEFF -| [ "Ltac2" ltac2_entry(e) ] -> [ - let local = Locality.LocalityFixme.consume () in - Tac2entries.register_struct ?local e - ] -END - -let _ = - let mode = { - Proof_global.name = "Ltac2"; - set = (fun () -> set_command_entry tac2mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); - } in - Proof_global.register_proof_mode mode - -VERNAC ARGUMENT EXTEND ltac2_expr -PRINTED BY pr_ltac2expr -| [ tac2expr(e) ] -> [ e ] -END - -open G_ltac -open Vernac_classifier - -VERNAC tac2mode EXTEND VernacLtac2 -| [ - ltac2_expr(t) ltac_use_default(default) ] => - [ classify_as_proofstep ] -> [ -(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - Tac2entries.call ~default t - ] -END - -open Stdarg - -VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF -| [ "Print" "Ltac2" reference(tac) ] -> [ Tac2entries.print_ltac tac ] -END - diff --git a/ltac2_plugin.mlpack b/ltac2_plugin.mlpack deleted file mode 100644 index 3d87a8cddb..0000000000 --- a/ltac2_plugin.mlpack +++ /dev/null @@ -1,7 +0,0 @@ -Tac2env -Tac2print -Tac2intern -Tac2interp -Tac2entries -Tac2core -G_ltac2 diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 new file mode 100644 index 0000000000..36057b3a67 --- /dev/null +++ b/src/g_ltac2.ml4 @@ -0,0 +1,278 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* CPatRef (!@loc, RelId id, pl) + | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) ] + | "0" + [ "_" -> CPatAny (!@loc) + | "()" -> CPatTup (Loc.tag ~loc:!@loc []) + | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) + | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> CPatTup (Loc.tag ~loc:!@loc pl) ] + ] + ; + tac2expr: + [ "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "5" -> CTacFun (!@loc, it, body) + | "let"; isrec = rec_flag; + lc = LIST1 let_clause SEP "with"; "in"; + e = tac2expr LEVEL "5" -> CTacLet (!@loc, isrec, lc, e) + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches ;"end" -> + CTacCse (!@loc, e, bl) + ] + | "2" LEFTA + [ e1 = tac2expr; ";"; e2 = tac2expr -> CTacSeq (!@loc, e1, e2) ] + | "1" LEFTA + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) + | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, RelId qid, r) + | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> CTacTup (Loc.tag ~loc:!@loc (e0 :: el)) ] + | "0" + [ "("; a = tac2expr LEVEL "5"; ")" -> a + | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) + | "()" -> CTacTup (Loc.tag ~loc:!@loc []) + | "("; ")" -> CTacTup (Loc.tag ~loc:!@loc []) + | "["; a = LIST0 tac2expr LEVEL "1" SEP ";"; "]" -> CTacLst (Loc.tag ~loc:!@loc a) + | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) + | a = tactic_atom -> a ] + ] + ; + branches: + [ [ -> [] + | "|"; bl = LIST1 branch SEP "|" -> bl + | bl = LIST1 branch SEP "|" -> bl ] + ] + ; + branch: + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "5" -> (pat, e) ] ] + ; + rec_flag: + [ [ IDENT "rec" -> true + | -> false ] ] + ; + typ_param: + [ [ "'"; id = Prim.ident -> id ] ] + ; + tactic_atom: + [ [ n = Prim.integer -> CTacAtm (Loc.tag ~loc:!@loc (AtmInt n)) + | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) + | id = Prim.qualid -> CTacRef (RelId id) + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c + | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c + ] ] + ; + let_clause: + [ [ id = binder; ":="; te = tac2expr -> + (id, None, te) + | id = binder; args = LIST1 input_fun; ":="; te = tac2expr -> + (id, None, CTacFun (!@loc, args, te)) ] ] + ; + tac2type: + [ "5" RIGHTA + [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] + | "2" + [ t = tac2type; "*"; tl = LIST1 tac2type SEP "*" -> CTypTuple (!@loc, t :: tl) ] + | "1" LEFTA + [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, RelId qid, [t]) ] + | "0" + [ "("; t = tac2type LEVEL "5"; ")" -> t + | id = typ_param -> CTypVar (Loc.tag ~loc:!@loc (Name id)) + | "_" -> CTypVar (Loc.tag ~loc:!@loc Anonymous) + | qid = Prim.qualid -> CTypRef (!@loc, RelId qid, []) + | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> + CTypRef (!@loc, RelId qid, p) ] + ]; + locident: + [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] + ; + binder: + [ [ "_" -> Loc.tag ~loc:!@loc Anonymous + | l = Prim.ident -> Loc.tag ~loc:!@loc (Name l) ] ] + ; + input_fun: + [ [ b = binder -> (b, None) + | "("; b = binder; ":"; t = tac2type; ")" -> (b, Some t) ] ] + ; + tac2def_body: + [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + let e = if List.is_empty it then e else CTacFun (!@loc, it, e) in + (name, e) + ] ] + ; + tac2def_val: + [ [ isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + StrVal (isrec, l) + ] ] + ; + tac2typ_knd: + [ [ t = tac2type -> CTydDef (Some t) + | "["; ".."; "]" -> CTydOpn + | "["; t = tac2alg_constructors; "]" -> CTydAlg t + | "{"; t = tac2rec_fields; "}"-> CTydRec t ] ] + ; + tac2alg_constructors: + [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> cs + | cs = LIST0 tac2alg_constructor SEP "|" -> cs ] ] + ; + tac2alg_constructor: + [ [ c = Prim.ident -> (c, []) + | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> (c, args) ] ] + ; + tac2rec_fields: + [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> f :: l + | f = tac2rec_field; ";" -> [f] + | f = tac2rec_field -> [f] + | -> [] ] ] + ; + tac2rec_field: + [ [ mut = [ -> false | IDENT "mutable" -> true]; id = Prim.ident; ":"; t = tac2type -> (id, mut, t) ] ] + ; + tac2rec_fieldexprs: + [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> f :: l + | f = tac2rec_fieldexpr; ";" -> [f] + | f = tac2rec_fieldexpr-> [f] + | -> [] ] ] + ; + tac2rec_fieldexpr: + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> RelId qid, e ] ] + ; + tac2typ_prm: + [ [ -> [] + | id = typ_param -> [Loc.tag ~loc:!@loc id] + | "("; ids = LIST1 [ id = typ_param -> Loc.tag ~loc:!@loc id ] SEP "," ;")" -> ids + ] ] + ; + tac2typ_def: + [ [ prm = tac2typ_prm; id = Prim.qualid; (r, e) = tac2type_body -> (id, r, (prm, e)) ] ] + ; + tac2type_body: + [ [ -> false, CTydDef None + | ":="; e = tac2typ_knd -> false, e + | "::="; e = tac2typ_knd -> true, e + ] ] + ; + tac2def_typ: + [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> + StrTyp (isrec, l) + ] ] + ; + tac2def_ext: + [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + plugin = Prim.string; name = Prim.string -> + let ml = { mltac_plugin = plugin; mltac_tactic = name } in + StrPrm (id, t, ml) + ] ] + ; + syn_node: + [ [ "_" -> Loc.tag ~loc:!@loc None + | id = Prim.ident -> Loc.tag ~loc:!@loc (Some id) + ] ] + ; + sexpr: + [ [ s = Prim.string -> SexprStr (Loc.tag ~loc:!@loc s) + | n = Prim.integer -> SexprInt (Loc.tag ~loc:!@loc n) + | id = syn_node -> SexprRec (!@loc, id, []) + | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + SexprRec (!@loc, id, tok) + ] ] + ; + syn_level: + [ [ -> None + | ":"; n = Prim.integer -> Some n + ] ] + ; + tac2def_syn: + [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; + e = tac2expr -> + StrSyn (toks, n, e) + ] ] + ; +END + +GEXTEND Gram + Pcoq.Constr.operconstr: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) ] ] + ; +END + +let pr_ltac2entry _ = mt () (** FIXME *) +let pr_ltac2expr _ = mt () (** FIXME *) + +VERNAC ARGUMENT EXTEND ltac2_entry +PRINTED BY pr_ltac2entry +| [ tac2def_val(v) ] -> [ v ] +| [ tac2def_typ(t) ] -> [ t ] +| [ tac2def_ext(e) ] -> [ e ] +| [ tac2def_syn(e) ] -> [ e ] +END + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition CLASSIFIED AS SIDEFF +| [ "Ltac2" ltac2_entry(e) ] -> [ + let local = Locality.LocalityFixme.consume () in + Tac2entries.register_struct ?local e + ] +END + +let _ = + let mode = { + Proof_global.name = "Ltac2"; + set = (fun () -> set_command_entry tac2mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY pr_ltac2expr +| [ tac2expr(e) ] -> [ e ] +END + +open G_ltac +open Vernac_classifier + +VERNAC tac2mode EXTEND VernacLtac2 +| [ - ltac2_expr(t) ltac_use_default(default) ] => + [ classify_as_proofstep ] -> [ +(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) + Tac2entries.call ~default t + ] +END + +open Stdarg + +VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF +| [ "Print" "Ltac2" reference(tac) ] -> [ Tac2entries.print_ltac tac ] +END + diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack new file mode 100644 index 0000000000..3d87a8cddb --- /dev/null +++ b/src/ltac2_plugin.mlpack @@ -0,0 +1,7 @@ +Tac2env +Tac2print +Tac2intern +Tac2interp +Tac2entries +Tac2core +G_ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml new file mode 100644 index 0000000000..91a3bfa168 --- /dev/null +++ b/src/tac2core.ml @@ -0,0 +1,648 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t +| _ -> assert false + +let val_constr = val_tag (topwit Stdarg.wit_constr) +let val_ident = val_tag (topwit Stdarg.wit_ident) +let val_pp = Val.create "ltac2:pp" + +let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v + +module Core = +struct + +let t_int = coq_core "int" +let t_string = coq_core "string" +let t_array = coq_core "array" +let t_unit = coq_core "unit" +let t_list = coq_core "list" +let t_constr = coq_core "constr" +let t_ident = coq_core "ident" +let t_option = coq_core "option" + +let c_nil = coq_core "[]" +let c_cons = coq_core "::" + +let c_none = coq_core "None" +let c_some = coq_core "Some" + +end + +open Core + +let v_unit = ValInt 0 +let v_nil = ValInt 0 +let v_cons v vl = ValBlk (0, [|v; vl|]) + +module Value = +struct + +let of_unit () = v_unit + +let to_unit = function +| ValInt 0 -> () +| _ -> assert false + +let of_int n = ValInt n +let to_int = function +| ValInt n -> n +| _ -> assert false + +let of_bool b = if b then ValInt 0 else ValInt 1 + +let to_bool = function +| ValInt 0 -> true +| ValInt 1 -> false +| _ -> assert false + +let of_char n = ValInt (Char.code n) +let to_char = function +| ValInt n -> Char.chr n +| _ -> assert false + +let of_string s = ValStr s +let to_string = function +| ValStr s -> s +| _ -> assert false + +let rec of_list = function +| [] -> v_nil +| x :: l -> v_cons x (of_list l) + +let rec to_list = function +| ValInt 0 -> [] +| ValBlk (0, [|v; vl|]) -> v :: to_list vl +| _ -> assert false + +let of_ext tag c = + ValExt (Val.Dyn (tag, c)) + +let to_ext tag = function +| ValExt e -> extract_val tag e +| _ -> assert false + +let of_constr c = of_ext val_constr c +let to_constr c = to_ext val_constr c + +let of_ident c = of_ext val_ident c +let to_ident c = to_ext val_ident c + +(** FIXME: handle backtrace in Ltac2 exceptions *) +let of_exn c = match fst c with +| LtacError (kn, c) -> ValOpn (kn, c) +| _ -> of_ext val_exn c + +let to_exn c = match c with +| ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) +| _ -> to_ext val_exn c + +let of_pp c = of_ext val_pp c +let to_pp c = to_ext val_pp c + +end + +let val_valexpr = Val.create "ltac2:valexpr" + +(** Stdlib exceptions *) + +let err_notfocussed = + LtacError (coq_core "Not_focussed", [||]) + +let err_outofbounds = + LtacError (coq_core "Out_of_bounds", [||]) + +let err_notfound = + LtacError (coq_core "Not_found", [||]) + +(** Helper functions *) + +let thaw f = interp_app f [v_unit] +let throw e = Proofview.tclLIFT (Proofview.NonLogical.raise e) + +let return x = Proofview.tclUNIT x +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let wrap f = + return () >>= fun () -> return (f ()) + +let wrap_unit f = + return () >>= fun () -> f (); return v_unit + +let pf_apply f = + Proofview.Goal.goals >>= function + | [] -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + f env sigma + | [gl] -> + gl >>= fun gl -> + f (Proofview.Goal.env gl) (Tacmach.New.project gl) + | _ :: _ :: _ -> + throw err_notfocussed + +(** Primitives *) + +(** Printing *) + +let prm_print : ml_tactic = function +| [pp] -> wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) +| _ -> assert false + +let prm_message_of_int : ml_tactic = function +| [ValInt s] -> return (ValExt (Val.Dyn (val_pp, int s))) +| _ -> assert false + +let prm_message_of_string : ml_tactic = function +| [ValStr s] -> return (ValExt (Val.Dyn (val_pp, str (Bytes.to_string s)))) +| _ -> assert false + +let prm_message_of_constr : ml_tactic = function +| [c] -> + pf_apply begin fun env sigma -> + let c = Value.to_constr c in + let pp = Printer.pr_econstr_env env sigma c in + return (ValExt (Val.Dyn (val_pp, pp))) + end +| _ -> assert false + +let prm_message_concat : ml_tactic = function +| [m1; m2] -> + let m1 = Value.to_pp m1 in + let m2 = Value.to_pp m2 in + return (Value.of_pp (Pp.app m1 m2)) +| _ -> assert false + +(** Array *) + +let prm_array_make : ml_tactic = function +| [ValInt n; x] -> + if n < 0 || n > Sys.max_array_length then throw err_outofbounds + else wrap (fun () -> ValBlk (0, Array.make n x)) +| _ -> assert false + +let prm_array_length : ml_tactic = function +| [ValBlk (_, v)] -> return (ValInt (Array.length v)) +| _ -> assert false + +let prm_array_set : ml_tactic = function +| [ValBlk (_, v); ValInt n; x] -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap_unit (fun () -> v.(n) <- x) +| _ -> assert false + +let prm_array_get : ml_tactic = function +| [ValBlk (_, v); ValInt n] -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap (fun () -> v.(n)) +| _ -> assert false + +(** Int *) + +let prm_int_equal : ml_tactic = function +| [m; n] -> + return (Value.of_bool (Value.to_int m == Value.to_int n)) +| _ -> assert false + +let binop f : ml_tactic = function +| [m; n] -> return (Value.of_int (f (Value.to_int m) (Value.to_int n))) +| _ -> assert false + +let prm_int_compare args = binop Int.compare args +let prm_int_add args = binop (+) args +let prm_int_sub args = binop (-) args +let prm_int_mul args = binop ( * ) args + +let prm_int_neg : ml_tactic = function +| [m] -> return (Value.of_int (~- (Value.to_int m))) +| _ -> assert false + +(** String *) + +let prm_string_make : ml_tactic = function +| [n; c] -> + let n = Value.to_int n in + let c = Value.to_char c in + if n < 0 || n > Sys.max_string_length then throw err_outofbounds + else wrap (fun () -> Value.of_string (Bytes.make n c)) +| _ -> assert false + +let prm_string_length : ml_tactic = function +| [s] -> + return (Value.of_int (Bytes.length (Value.to_string s))) +| _ -> assert false + +let prm_string_set : ml_tactic = function +| [s; n; c] -> + let s = Value.to_string s in + let n = Value.to_int n in + let c = Value.to_char c in + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap_unit (fun () -> Bytes.set s n c) +| _ -> assert false + +let prm_string_get : ml_tactic = function +| [s; n] -> + let s = Value.to_string s in + let n = Value.to_int n in + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap (fun () -> Value.of_char (Bytes.get s n)) +| _ -> assert false + +(** Terms *) + +(** constr -> constr *) +let prm_constr_type : ml_tactic = function +| [c] -> + let c = Value.to_constr c in + let get_type env sigma = + Proofview.V82.wrap_exceptions begin fun () -> + let (sigma, t) = Typing.type_of env sigma c in + let t = Value.of_constr t in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t + end in + pf_apply get_type +| _ -> assert false + +(** constr -> constr *) +let prm_constr_equal : ml_tactic = function +| [c1; c2] -> + let c1 = Value.to_constr c1 in + let c2 = Value.to_constr c2 in + Proofview.tclEVARMAP >>= fun sigma -> + let b = EConstr.eq_constr sigma c1 c2 in + Proofview.tclUNIT (Value.of_bool b) +| _ -> assert false + +(** Error *) + +let prm_throw : ml_tactic = function +| [e] -> + let (e, info) = Value.to_exn e in + Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) +| _ -> assert false + +(** Control *) + +(** exn -> 'a *) +let prm_zero : ml_tactic = function +| [e] -> + let (e, info) = Value.to_exn e in + Proofview.tclZERO ~info e +| _ -> assert false + +(** exn -> 'a *) +let prm_plus : ml_tactic = function +| [x; k] -> + Proofview.tclOR (thaw x) (fun e -> interp_app k [Value.of_exn e]) +| _ -> assert false + +(** (unit -> 'a) -> 'a *) +let prm_once : ml_tactic = function +| [f] -> Proofview.tclONCE (thaw f) +| _ -> assert false + +(** (unit -> unit) list -> unit *) +let prm_dispatch : ml_tactic = function +| [l] -> + let l = Value.to_list l in + let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in + Proofview.tclDISPATCH l >>= fun () -> return v_unit +| _ -> assert false + +(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) +let prm_extend : ml_tactic = function +| [lft; tac; rgt] -> + let lft = Value.to_list lft in + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let tac = Proofview.tclIGNORE (thaw tac) in + let rgt = Value.to_list rgt in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in + Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit +| _ -> assert false + +(** (unit -> unit) -> unit *) +let prm_enter : ml_tactic = function +| [f] -> + let f = Proofview.tclIGNORE (thaw f) in + Proofview.tclINDEPENDENT f >>= fun () -> return v_unit +| _ -> assert false + +(** int -> int -> (unit -> 'a) -> 'a *) +let prm_focus : ml_tactic = function +| [i; j; tac] -> + let i = Value.to_int i in + let j = Value.to_int j in + Proofview.tclFOCUS i j (thaw tac) +| _ -> assert false + +(** unit -> unit *) +let prm_shelve : ml_tactic = function +| [_] -> Proofview.shelve >>= fun () -> return v_unit +| _ -> assert false + +(** unit -> unit *) +let prm_shelve_unifiable : ml_tactic = function +| [_] -> Proofview.shelve_unifiable >>= fun () -> return v_unit +| _ -> assert false + +let prm_new_goal : ml_tactic = function +| [ev] -> + let ev = Evar.unsafe_of_int (Value.to_int ev) in + Proofview.tclEVARMAP >>= fun sigma -> + if Evd.mem sigma ev then + Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit + else throw err_notfound +| _ -> assert false + +(** unit -> constr *) +let prm_goal : ml_tactic = function +| [_] -> + Proofview.Goal.enter_one begin fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + return (Value.of_constr concl) + end +| _ -> assert false + +(** ident -> constr *) +let prm_hyp : ml_tactic = function +| [id] -> + let id = Value.to_ident id in + pf_apply begin fun env _ -> + let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in + if mem then return (Value.of_constr (EConstr.mkVar id)) + else Tacticals.New.tclZEROMSG + (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (** FIXME: Do something more sensible *) + end +| _ -> assert false + +(** (unit -> constr) -> unit *) +let prm_refine : ml_tactic = function +| [c] -> + let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in + Proofview.Goal.nf_enter begin fun gl -> + Refine.generic_refine ~typecheck:true c gl + end >>= fun () -> return v_unit +| _ -> assert false + + +(** Registering *) + +let () = Tac2env.define_primitive (pname "print") prm_print +let () = Tac2env.define_primitive (pname "message_of_string") prm_message_of_string +let () = Tac2env.define_primitive (pname "message_of_int") prm_message_of_int +let () = Tac2env.define_primitive (pname "message_of_constr") prm_message_of_constr +let () = Tac2env.define_primitive (pname "message_concat") prm_message_concat + +let () = Tac2env.define_primitive (pname "array_make") prm_array_make +let () = Tac2env.define_primitive (pname "array_length") prm_array_length +let () = Tac2env.define_primitive (pname "array_get") prm_array_get +let () = Tac2env.define_primitive (pname "array_set") prm_array_set + +let () = Tac2env.define_primitive (pname "string_make") prm_string_make +let () = Tac2env.define_primitive (pname "string_length") prm_string_length +let () = Tac2env.define_primitive (pname "string_get") prm_string_get +let () = Tac2env.define_primitive (pname "string_set") prm_string_set + +let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type +let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal + +let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal +let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare +let () = Tac2env.define_primitive (pname "int_neg") prm_int_neg +let () = Tac2env.define_primitive (pname "int_add") prm_int_add +let () = Tac2env.define_primitive (pname "int_sub") prm_int_sub +let () = Tac2env.define_primitive (pname "int_mul") prm_int_mul + +let () = Tac2env.define_primitive (pname "throw") prm_throw + +let () = Tac2env.define_primitive (pname "zero") prm_zero +let () = Tac2env.define_primitive (pname "plus") prm_plus +let () = Tac2env.define_primitive (pname "once") prm_once +let () = Tac2env.define_primitive (pname "dispatch") prm_dispatch +let () = Tac2env.define_primitive (pname "extend") prm_extend +let () = Tac2env.define_primitive (pname "enter") prm_enter + +let () = Tac2env.define_primitive (pname "focus") prm_focus +let () = Tac2env.define_primitive (pname "shelve") prm_shelve +let () = Tac2env.define_primitive (pname "shelve_unifiable") prm_shelve_unifiable +let () = Tac2env.define_primitive (pname "new_goal") prm_new_goal +let () = Tac2env.define_primitive (pname "goal") prm_goal +let () = Tac2env.define_primitive (pname "hyp") prm_hyp +let () = Tac2env.define_primitive (pname "refine") prm_refine + +(** ML types *) + +let constr_flags () = + let open Pretyping in + { + use_typeclasses = true; + solve_unification_constraints = true; + use_hook = Pfedit.solve_by_implicit_tactic (); + fail_evar = true; + expand_evars = true + } + +let open_constr_no_classes_flags () = + let open Pretyping in + { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Pfedit.solve_by_implicit_tactic (); + fail_evar = false; + expand_evars = true + } + +(** Embed all Ltac2 data into Values *) +let to_lvar ist = + let open Glob_ops in + let map e = Val.Dyn (val_valexpr, e) in + let lfun = Id.Map.map map ist in + { empty_lvar with Glob_term.ltac_genargs = lfun } + +let interp_constr flags ist (c, _) = + let open Pretyping in + pf_apply begin fun env sigma -> + Proofview.V82.wrap_exceptions begin fun () -> + let ist = to_lvar ist in + let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in + let c = Val.Dyn (val_constr, c) in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT c + end + end + +let () = + let interp ist c = interp_constr (constr_flags ()) ist c in + let obj = { + ml_type = t_constr; + ml_interp = interp; + } in + define_ml_object Stdarg.wit_constr obj + +let () = + let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let obj = { + ml_type = t_constr; + ml_interp = interp; + } in + define_ml_object Stdarg.wit_open_constr obj + +let () = + let interp _ id = return (Val.Dyn (val_ident, id)) in + let obj = { + ml_type = t_ident; + ml_interp = interp; + } in + define_ml_object Stdarg.wit_ident obj + +let () = + let interp ist env sigma concl tac = + let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = + match Val.eq tag val_valexpr with + | None -> accu + | Some Refl -> Id.Map.add id v accu + in + let ist = Id.Map.fold fold ist Id.Map.empty in + let tac = Proofview.tclIGNORE (interp ist tac) in + let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in + (EConstr.of_constr c, sigma) + in + Pretyping.register_constr_interp0 wit_ltac2 interp + +(** Built-in notation scopes *) + +let add_scope s f = + Tac2entries.register_scope (Id.of_string s) f + +let scope_fail () = CErrors.user_err (str "Invalid parsing token") + +let dummy_loc = Loc.make_loc (-1, -1) + +let rthunk e = + let loc = Tac2intern.loc_of_tacexpr e in + let var = [Loc.tag ~loc Anonymous, Some (CTypRef (loc, AbsKn Core.t_unit, []))] in + CTacFun (loc, var, e) + +let add_generic_scope s entry arg = + let parse = function + | [] -> + let scope = Extend.Aentry entry in + let act x = rthunk (CTacExt (dummy_loc, in_gen (rawwit arg) x)) in + Tac2entries.ScopeRule (scope, act) + | _ -> scope_fail () + in + add_scope s parse + +let () = add_scope "list0" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist0 scope in + let act l = + let l = List.map act l in + CTacLst (None, l) + in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr (_, str)] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist0sep (scope, sep) in + let act l = + let l = List.map act l in + CTacLst (None, l) + in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "list1" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist1 scope in + let act l = + let l = List.map act l in + CTacLst (None, l) + in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr (_, str)] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist1sep (scope, sep) in + let act l = + let l = List.map act l in + CTacLst (None, l) + in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "opt" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Aopt scope in + let act opt = match opt with + | None -> + CTacRef (AbsKn (TacConstructor Core.c_none)) + | Some x -> + CTacApp (dummy_loc, CTacRef (AbsKn (TacConstructor Core.c_some)), [act x]) + in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "self" begin function +| [] -> + let scope = Extend.Aself in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "next" begin function +| [] -> + let scope = Extend.Anext in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "tactic" begin function +| [] -> + (** Default to level 5 parsing *) + let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, 5) in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| [SexprInt (loc, n)] -> + let () = if n < 0 || n > 5 then scope_fail () in + let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, n) in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_generic_scope "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr diff --git a/src/tac2core.mli b/src/tac2core.mli new file mode 100644 index 0000000000..fc90499ac6 --- /dev/null +++ b/src/tac2core.mli @@ -0,0 +1,62 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr +val to_unit : valexpr -> unit + +val of_int : int -> valexpr +val to_int : valexpr -> int + +val of_bool : bool -> valexpr +val to_bool : valexpr -> bool + +val of_char : char -> valexpr +val to_char : valexpr -> char + +val of_list : valexpr list -> valexpr +val to_list : valexpr -> valexpr list + +val of_constr : EConstr.t -> valexpr +val to_constr : valexpr -> EConstr.t + +val of_exn : Exninfo.iexn -> valexpr +val to_exn : valexpr -> Exninfo.iexn + +val of_ident : Id.t -> valexpr +val to_ident : valexpr -> Id.t + +end diff --git a/src/tac2entries.ml b/src/tac2entries.ml new file mode 100644 index 0000000000..46f390a6d4 --- /dev/null +++ b/src/tac2entries.ml @@ -0,0 +1,648 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object {(default_object "TAC2-DEFINITION") with + cache_function = cache_tacdef; + load_function = load_tacdef; + open_function = open_tacdef; + subst_function = subst_tacdef; + classify_function = classify_tacdef} + +(** Type definition *) + +type typdef = { + typdef_local : bool; + typdef_expr : glb_quant_typedef; +} + +let change_kn_label kn id = + let (mp, dp, _) = KerName.repr kn in + KerName.make mp dp (Label.of_id id) + +let change_sp_label sp id = + let (dp, _) = Libnames.repr_path sp in + Libnames.make_path dp id + +let push_typedef visibility sp kn (_, def) = match def with +| GTydDef _ -> + Tac2env.push_type visibility sp kn +| GTydAlg cstrs -> + (** Register constructors *) + let iter (c, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_ltac visibility spc (TacConstructor knc) + in + Tac2env.push_type visibility sp kn; + List.iter iter cstrs +| GTydRec fields -> + (** Register fields *) + let iter (c, _, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_projection visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter fields +| GTydOpn -> + Tac2env.push_type visibility sp kn + +let next i = + let ans = !i in + let () = incr i in + ans + +let define_typedef kn (params, def as qdef) = match def with +| GTydDef _ -> + Tac2env.define_type kn qdef +| GTydAlg cstrs -> + (** Define constructors *) + let constant = ref 0 in + let nonconstant = ref 0 in + let iter (c, args) = + let knc = change_kn_label kn c in + let tag = if List.is_empty args then next constant else next nonconstant in + let data = { + Tac2env.cdata_prms = params; + cdata_type = kn; + cdata_args = args; + cdata_indx = Some tag; + } in + Tac2env.define_constructor knc data + in + Tac2env.define_type kn qdef; + List.iter iter cstrs +| GTydRec fs -> + (** Define projections *) + let iter i (id, mut, t) = + let knp = change_kn_label kn id in + let proj = { + Tac2env.pdata_prms = params; + pdata_type = kn; + pdata_ptyp = t; + pdata_mutb = mut; + pdata_indx = i; + } in + Tac2env.define_projection knp proj + in + Tac2env.define_type kn qdef; + List.iteri iter fs +| GTydOpn -> + Tac2env.define_type kn qdef + +let perform_typdef vs ((sp, kn), def) = + let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let load_typdef i obj = perform_typdef (Until i) obj +let open_typdef i obj = perform_typdef (Exactly i) obj + +let cache_typdef ((sp, kn), def) = + let () = push_typedef (Until 1) sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let subst_typdef (subst, def) = + let expr' = subst_quant_typedef subst def.typdef_expr in + if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } + +let classify_typdef o = Substitute o + +let inTypDef : typdef -> obj = + declare_object {(default_object "TAC2-TYPE-DEFINITION") with + cache_function = cache_typdef; + load_function = load_typdef; + open_function = open_typdef; + subst_function = subst_typdef; + classify_function = classify_typdef} + +(** Type extension *) + +type extension_data = { + edata_name : Id.t; + edata_args : int glb_typexpr list; +} + +type typext = { + typext_local : bool; + typext_prms : int; + typext_type : type_constant; + typext_expr : extension_data list; +} + +let push_typext vis sp kn def = + let iter data = + let spc = change_sp_label sp data.edata_name in + let knc = change_kn_label kn data.edata_name in + Tac2env.push_ltac vis spc (TacConstructor knc) + in + List.iter iter def.typext_expr + +let define_typext kn def = + let iter data = + let knc = change_kn_label kn data.edata_name in + let cdata = { + Tac2env.cdata_prms = def.typext_prms; + cdata_type = def.typext_type; + cdata_args = data.edata_args; + cdata_indx = None; + } in + Tac2env.define_constructor knc cdata + in + List.iter iter def.typext_expr + +let cache_typext ((sp, kn), def) = + let () = define_typext kn def in + push_typext (Until 1) sp kn def + +let perform_typext vs ((sp, kn), def) = + let () = if not def.typext_local then push_typext vs sp kn def in + define_typext kn def + +let load_typext i obj = perform_typext (Until i) obj +let open_typext i obj = perform_typext (Exactly i) obj + +let subst_typext (subst, e) = + let open Mod_subst in + let subst_data data = + let edata_args = List.smartmap (fun e -> subst_type subst e) data.edata_args in + if edata_args == data.edata_args then data + else { data with edata_args } + in + let typext_type = subst_kn subst e.typext_type in + let typext_expr = List.smartmap subst_data e.typext_expr in + if typext_type == e.typext_type && typext_expr == e.typext_expr then + e + else + { e with typext_type; typext_expr } + +let classify_typext o = Substitute o + +let inTypExt : typext -> obj = + declare_object {(default_object "TAC2-TYPE-EXTENSION") with + cache_function = cache_typext; + load_function = load_typext; + open_function = open_typext; + subst_function = subst_typext; + classify_function = classify_typext} + +(** Toplevel entries *) + +let dummy_loc = Loc.make_loc (-1, -1) + +let register_ltac ?(local = false) isrec tactics = + if isrec then + let map (na, e) = (na, None, e) in + let bindings = List.map map tactics in + let map ((loc, na), e) = match na with + | Anonymous -> None + | Name id -> + let qid = Libnames.qualid_of_ident id in + let e = CTacLet (dummy_loc, true, bindings, CTacRef (RelId (loc, qid))) in + let (e, t) = intern e in + let e = match e with + | GTacLet (true, _, e) -> assert false + | _ -> assert false + in + Some (e, t) + in + let tactics = List.map map tactics in + assert false (** FIXME *) + else + let map ((loc, na), e) = + let (e, t) = intern e in + let () = + if not (is_value e) then + user_err ?loc (str "Tactic definition must be a syntactical value") + in + let id = match na with + | Anonymous -> + user_err ?loc (str "Tactic definition must have a name") + | Name id -> id + in + let kn = Lib.make_kn id in + let exists = + try let _ = Tac2env.interp_global kn in true with Not_found -> false + in + let () = + if exists then + user_err ?loc (str "Tactic " ++ Nameops.pr_id id ++ str " already exists") + in + (id, e, t) + in + let defs = List.map map tactics in + let iter (id, e, t) = + let def = { + tacdef_local = local; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + in + List.iter iter defs + +let qualid_to_ident (loc, qid) = + let (dp, id) = Libnames.repr_qualid qid in + if DirPath.is_empty dp then (loc, id) + else user_err ?loc (str "Identifier expected") + +let register_typedef ?(local = false) isrec types = + let same_name ((_, id1), _) ((_, id2), _) = Id.equal id1 id2 in + let () = match List.duplicates same_name types with + | [] -> () + | ((loc, id), _) :: _ -> + user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) + in + let check ((loc, id), (params, def)) = + let same_name (_, id1) (_, id2) = Id.equal id1 id2 in + let () = match List.duplicates same_name params with + | [] -> () + | (loc, id) :: _ -> + user_err ?loc (str "The type parameter " ++ Id.print id ++ + str " occurs several times") + in + match def with + | CTydDef _ -> + if isrec then + user_err ?loc (str "The type abbreviation " ++ Id.print id ++ + str " cannot be recursive") + | CTydAlg cs -> + let same_name (id1, _) (id2, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name cs with + | [] -> () + | (id, _) :: _ -> + user_err (str "Multiple definitions of the constructor " ++ Id.print id) + in + () + | CTydRec ps -> + let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name ps with + | [] -> () + | (id, _, _) :: _ -> + user_err (str "Multiple definitions of the projection " ++ Id.print id) + in + () + | CTydOpn -> + if isrec then + user_err ?loc (str "The open type declaration " ++ Id.print id ++ + str " cannot be recursive") + in + let () = List.iter check types in + let self = + if isrec then + let fold accu ((_, id), (params, _)) = + Id.Map.add id (Lib.make_kn id, List.length params) accu + in + List.fold_left fold Id.Map.empty types + else Id.Map.empty + in + let map ((_, id), def) = + let typdef = { + typdef_local = local; + typdef_expr = intern_typedef self def; + } in + (id, typdef) + in + let types = List.map map types in + let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in + List.iter iter types + +let register_primitive ?(local = false) (loc, id) t ml = + let t = intern_open_type t in + let rec count_arrow = function + | GTypArrow (_, t) -> 1 + count_arrow t + | _ -> 0 + in + let arrows = count_arrow (snd t) in + let () = if Int.equal arrows 0 then + user_err ?loc (str "External tactic must have at least one argument") in + let () = + try let _ = Tac2env.interp_primitive ml in () with Not_found -> + user_err ?loc (str "Unregistered primitive " ++ + quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) + in + let init i = Id.of_string (Printf.sprintf "x%i" i) in + let names = List.init arrows init in + let bnd = List.map (fun id -> Name id) names in + let arg = List.map (fun id -> GTacVar id) names in + let e = GTacFun (bnd, GTacPrm (ml, arg)) in + let def = { + tacdef_local = local; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + +let register_open ?(local = false) (loc, qid) (params, def) = + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc (str "Unbound type " ++ pr_qualid qid) + in + let (tparams, t) = Tac2env.interp_type kn in + let () = match t with + | GTydOpn -> () + | GTydAlg _ | GTydRec _ | GTydDef _ -> + user_err ?loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") + in + let () = + let loc = Option.default dummy_loc loc in + if not (Int.equal (List.length params) tparams) then + Tac2intern.error_nparams_mismatch loc (List.length params) tparams + in + match def with + | CTydOpn -> () + | CTydAlg def -> + let intern_type t = + let tpe = CTydDef (Some t) in + let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in + match ans with + | GTydDef (Some t) -> t + | _ -> assert false + in + let map (id, tpe) = + let tpe = List.map intern_type tpe in + { edata_name = id; edata_args = tpe } + in + let def = List.map map def in + let def = { + typext_local = local; + typext_type = kn; + typext_prms = tparams; + typext_expr = def; + } in + Lib.add_anonymous_leaf (inTypExt def) + | CTydRec _ | CTydDef _ -> + user_err ?loc (str "Extensions only accept inductive constructors") + +let register_type ?local isrec types = match types with +| [qid, true, def] -> + let (loc, _) = qid in + let () = if isrec then user_err ?loc (str "Extensions cannot be recursive") in + register_open ?local qid def +| _ -> + let map (qid, redef, def) = + let (loc, _) = qid in + let () = if redef then + user_err ?loc (str "Types can only be extended one by one") + in + (qualid_to_ident qid, def) + in + let types = List.map map types in + register_typedef ?local isrec types + +(** Parsing *) + +type 'a token = +| TacTerm of string +| TacNonTerm of Name.t * 'a + +type scope_rule = +| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty + +let register_scope id s = + scope_table := Id.Map.add id s !scope_table + +module ParseToken = +struct + +let loc_of_token = function +| SexprStr (loc, _) -> Option.default dummy_loc loc +| SexprInt (loc, _) -> Option.default dummy_loc loc +| SexprRec (loc, _, _) -> loc + +let parse_scope = function +| SexprRec (_, (loc, Some id), toks) -> + if Id.Map.mem id !scope_table then + Id.Map.find id !scope_table toks + else + CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Nameops.pr_id id) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ~loc (str "Invalid parsing token") + +let parse_token = function +| SexprStr (_, s) -> TacTerm s +| SexprRec (_, (_, na), [tok]) -> + let na = match na with None -> Anonymous | Some id -> Name id in + let scope = parse_scope tok in + TacNonTerm (na, scope) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ~loc (str "Invalid parsing token") + +end + +let parse_scope = ParseToken.parse_scope + +type synext = { + synext_tok : sexpr list; + synext_exp : raw_tacexpr; + synext_lev : int option; + synext_loc : bool; +} + +type krule = +| KRule : + (raw_tacexpr, 'act, Loc.t -> raw_tacexpr) Extend.rule * + ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule + +let rec get_rule (tok : scope_rule token list) : krule = match tok with +| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, scope) in + let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in + KRule (rule, act) +| TacTerm t :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let act k _ = act k in + KRule (rule, act) + +let perform_notation syn st = + let tok = List.rev_map ParseToken.parse_token syn.synext_tok in + let KRule (rule, act) = get_rule tok in + let mk loc args = + let map (na, e) = + let loc = loc_of_tacexpr e in + (Loc.tag ~loc na, None, e) + in + let bnd = List.map map args in + CTacLet (loc, false, bnd, syn.synext_exp) + in + let rule = Extend.Rule (rule, act mk) in + let lev = match syn.synext_lev with + | None -> None + | Some lev -> Some (string_of_int lev) + in + let rule = (lev, None, [rule]) in + ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) + +let ltac2_notation = + Pcoq.create_grammar_command "ltac2-notation" perform_notation + +let cache_synext (_, syn) = + Pcoq.extend_grammar_command ltac2_notation syn + +let open_synext i (_, syn) = + if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn + +let subst_synext (subst, syn) = + let e = Tac2intern.subst_rawexpr subst syn.synext_exp in + if e == syn.synext_exp then syn else { syn with synext_exp = e } + +let classify_synext o = + if o.synext_loc then Dispose else Substitute o + +let inTac2Notation : synext -> obj = + declare_object {(default_object "TAC2-NOTATION") with + cache_function = cache_synext; + open_function = open_synext; + subst_function = subst_synext; + classify_function = classify_synext} + +let register_notation ?(local = false) tkn lev body = + (** Check that the tokens make sense *) + let entries = List.map ParseToken.parse_token tkn in + let fold accu tok = match tok with + | TacTerm _ -> accu + | TacNonTerm (Name id, _) -> Id.Set.add id accu + | TacNonTerm (Anonymous, _) -> accu + in + let ids = List.fold_left fold Id.Set.empty entries in + (** Globalize so that names are absolute *) + let body = Tac2intern.globalize ids body in + let ext = { + synext_tok = tkn; + synext_exp = body; + synext_lev = lev; + synext_loc = local; + } in + Lib.add_anonymous_leaf (inTac2Notation ext) + +(** Toplevel entries *) + +let register_struct ?local str = match str with +| StrVal (isrec, e) -> register_ltac ?local isrec e +| StrTyp (isrec, t) -> register_type ?local isrec t +| StrPrm (id, t, ml) -> register_primitive ?local id t ml +| StrSyn (tok, lev, e) -> register_notation ?local tok lev e + +(** Printing *) + +let print_ltac ref = + let (loc, qid) = qualid_of_reference ref in + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) + in + match kn with + | TacConstant kn -> + let (e, _, (_, t)) = Tac2env.interp_global kn in + let name = int_name () in + Feedback.msg_notice ( + hov 0 ( + hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ + hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + ) + ) + | TacConstructor kn -> + let _ = Tac2env.interp_constructor kn in + Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) + +(** Calling tactics *) + +let solve default tac = + let status = Proof_global.with_current_proof begin fun etac p -> + let with_end_tac = if default then Some etac else None in + let (p, status) = Pfedit.solve SelectAll None tac ?with_end_tac p in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p, status + end in + if not status then Feedback.feedback Feedback.AddedAxiom + +let call ~default e = + let loc = loc_of_tacexpr e in + let (e, (_, t)) = intern e in + let () = check_unit ~loc t in + let tac = Tac2interp.interp Id.Map.empty e in + solve default (Proofview.tclIGNORE tac) + +(** Primitive algebraic types than can't be defined Coq-side *) + +let register_prim_alg name params def = + let id = Id.of_string name in + let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in + let def = (params, GTydAlg def) in + let def = { typdef_local = false; typdef_expr = def } in + ignore (Lib.add_leaf id (inTypDef def)) + +let coq_def n = KerName.make2 Tac2env.coq_prefix (Label.make n) + +let t_list = coq_def "list" + +let _ = Mltop.declare_cache_obj begin fun () -> + register_prim_alg "unit" 0 ["()", []]; + register_prim_alg "list" 1 [ + ("[]", []); + ("::", [GTypVar 0; GTypRef (t_list, [GTypVar 0])]); + ]; +end "ltac2_plugin" diff --git a/src/tac2entries.mli b/src/tac2entries.mli new file mode 100644 index 0000000000..71e8150057 --- /dev/null +++ b/src/tac2entries.mli @@ -0,0 +1,57 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* rec_flag -> + (Name.t located * raw_tacexpr) list -> unit + +val register_type : ?local:bool -> rec_flag -> + (qualid located * redef_flag * raw_quant_typedef) list -> unit + +val register_primitive : ?local:bool -> + Id.t located -> raw_typexpr -> ml_tactic_name -> unit + +val register_struct : ?local:bool -> strexpr -> unit + +val register_notation : ?local:bool -> sexpr list -> int option -> + raw_tacexpr -> unit + +(** {5 Notations} *) + +type scope_rule = +| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +val register_scope : Id.t -> scope_interpretation -> unit +(** Create a new scope with the provided name *) + +val parse_scope : sexpr -> scope_rule +(** Use this to interpret the subscopes for interpretation functions *) + +(** {5 Inspecting} *) + +val print_ltac : Libnames.reference -> unit + +(** {5 Eval loop} *) + +(** Evaluate a tactic expression in the current environment *) +val call : default:bool -> raw_tacexpr -> unit + +(** {5 Parsing entries} *) + +module Pltac : +sig +val tac2expr : raw_tacexpr Pcoq.Gram.entry +end diff --git a/src/tac2env.ml b/src/tac2env.ml new file mode 100644 index 0000000000..5ccdd018ee --- /dev/null +++ b/src/tac2env.ml @@ -0,0 +1,242 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ValInt n +| GTacRef kn -> + let (e, _) = + try KNmap.find kn ltac_state.contents.ltac_tactics + with Not_found -> assert false + in + eval_pure e +| GTacFun (na, e) -> + ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e } +| GTacCst (_, n, []) -> ValInt n +| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) +| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_pure el) +| GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ | GTacSet _ +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> + anomaly (Pp.str "Term is not a syntactical value") + +let define_global kn e = + let state = !ltac_state in + ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } + +let interp_global kn = + let (e, t) = KNmap.find kn ltac_state.contents.ltac_tactics in + (e, eval_pure e, t) + +let define_constructor kn t = + let state = !ltac_state in + ltac_state := { state with ltac_constructors = KNmap.add kn t state.ltac_constructors } + +let interp_constructor kn = KNmap.find kn ltac_state.contents.ltac_constructors + +let define_projection kn t = + let state = !ltac_state in + ltac_state := { state with ltac_projections = KNmap.add kn t state.ltac_projections } + +let interp_projection kn = KNmap.find kn ltac_state.contents.ltac_projections + +let define_type kn e = + let state = !ltac_state in + ltac_state := { state with ltac_types = KNmap.add kn e state.ltac_types } + +let interp_type kn = KNmap.find kn ltac_state.contents.ltac_types + +module ML = +struct + type t = ml_tactic_name + let compare n1 n2 = + let c = String.compare n1.mltac_plugin n2.mltac_plugin in + if Int.equal c 0 then String.compare n1.mltac_tactic n2.mltac_tactic + else c +end + +module MLMap = Map.Make(ML) + +let primitive_map = ref MLMap.empty + +let define_primitive name f = primitive_map := MLMap.add name f !primitive_map +let interp_primitive name = MLMap.find name !primitive_map + +(** Name management *) + +module FullPath = +struct + type t = full_path + let equal = eq_full_path + let to_string = string_of_path + let repr sp = + let dir,id = repr_path sp in + id, (DirPath.repr dir) +end + +type tacref = Tac2expr.tacref = +| TacConstant of ltac_constant +| TacConstructor of ltac_constructor + +module TacRef = +struct +type t = tacref +let equal r1 r2 = match r1, r2 with +| TacConstant c1, TacConstant c2 -> KerName.equal c1 c2 +| TacConstructor c1, TacConstructor c2 -> KerName.equal c1 c2 +| _ -> false +end + +module KnTab = Nametab.Make(FullPath)(KerName) +module RfTab = Nametab.Make(FullPath)(TacRef) + +type nametab = { + tab_ltac : RfTab.t; + tab_ltac_rev : full_path KNmap.t * full_path KNmap.t; + tab_type : KnTab.t; + tab_type_rev : full_path KNmap.t; + tab_proj : KnTab.t; + tab_proj_rev : full_path KNmap.t; +} + +let empty_nametab = { + tab_ltac = RfTab.empty; + tab_ltac_rev = (KNmap.empty, KNmap.empty); + tab_type = KnTab.empty; + tab_type_rev = KNmap.empty; + tab_proj = KnTab.empty; + tab_proj_rev = KNmap.empty; +} + +let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" + +let push_ltac vis sp kn = + let tab = !nametab in + let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in + let (constant_map, constructor_map) = tab.tab_ltac_rev in + let tab_ltac_rev = match kn with + | TacConstant c -> (KNmap.add c sp constant_map, constructor_map) + | TacConstructor c -> (constant_map, KNmap.add c sp constructor_map) + in + nametab := { tab with tab_ltac; tab_ltac_rev } + +let locate_ltac qid = + let tab = !nametab in + RfTab.locate qid tab.tab_ltac + +let locate_extended_all_ltac qid = + let tab = !nametab in + RfTab.find_prefixes qid tab.tab_ltac + +let shortest_qualid_of_ltac kn = + let tab = !nametab in + let sp = match kn with + | TacConstant c -> KNmap.find c (fst tab.tab_ltac_rev) + | TacConstructor c -> KNmap.find c (snd tab.tab_ltac_rev) + in + RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + +let push_type vis sp kn = + let tab = !nametab in + let tab_type = KnTab.push vis sp kn tab.tab_type in + let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in + nametab := { tab with tab_type; tab_type_rev } + +let locate_type qid = + let tab = !nametab in + KnTab.locate qid tab.tab_type + +let locate_extended_all_type qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_type + +let shortest_qualid_of_type kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_type_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_type + +let push_projection vis sp kn = + let tab = !nametab in + let tab_proj = KnTab.push vis sp kn tab.tab_proj in + let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in + nametab := { tab with tab_proj; tab_proj_rev } + +let locate_projection qid = + let tab = !nametab in + KnTab.locate qid tab.tab_proj + +let locate_extended_all_projection qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_proj + +let shortest_qualid_of_projection kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_proj_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj + +type 'a ml_object = { + ml_type : type_constant; + ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; +} + +module MLTypeObj = +struct + type ('a, 'b, 'c) obj = 'b ml_object + let name = "ltac2_ml_type" + let default _ = None +end + +module MLType = Genarg.Register(MLTypeObj) + +let define_ml_object t tpe = MLType.register0 t tpe +let interp_ml_object t = MLType.obj t + +(** Absolute paths *) + +let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "ltac2"; "Coq"])) + +(** Generic arguments *) + +let wit_ltac2 = Genarg.make0 "ltac2" diff --git a/src/tac2env.mli b/src/tac2env.mli new file mode 100644 index 0000000000..c4b8c1e0ca --- /dev/null +++ b/src/tac2env.mli @@ -0,0 +1,106 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (glb_tacexpr * type_scheme) -> unit +val interp_global : ltac_constant -> (glb_tacexpr * valexpr * type_scheme) + +(** {5 Toplevel definition of types} *) + +val define_type : type_constant -> glb_quant_typedef -> unit +val interp_type : type_constant -> glb_quant_typedef + +(** {5 Toplevel definition of algebraic constructors} *) + +type constructor_data = { + cdata_prms : int; + (** Type parameters *) + cdata_type : type_constant; + (** Inductive definition to which the constructor pertains *) + cdata_args : int glb_typexpr list; + (** Types of the constructor arguments *) + cdata_indx : int option; + (** Index of the constructor in the ADT. Numbering is duplicated between + argumentless and argument-using constructors, e.g. in type ['a option] + [None] and [Some] have both index 0. This field is empty whenever the + constructor is a member of an open type. *) +} + +val define_constructor : ltac_constructor -> constructor_data -> unit +val interp_constructor : ltac_constructor -> constructor_data + +(** {5 Toplevel definition of projections} *) + +type projection_data = { + pdata_prms : int; + (** Type parameters *) + pdata_type : type_constant; + (** Record definition to which the projection pertains *) + pdata_ptyp : int glb_typexpr; + (** Type of the projection *) + pdata_mutb : bool; + (** Whether the field is mutable *) + pdata_indx : int; + (** Index of the projection *) +} + +val define_projection : ltac_projection -> projection_data -> unit +val interp_projection : ltac_projection -> projection_data + +(** {5 Name management} *) + +val push_ltac : visibility -> full_path -> tacref -> unit +val locate_ltac : qualid -> tacref +val locate_extended_all_ltac : qualid -> tacref list +val shortest_qualid_of_ltac : tacref -> qualid + +val push_type : visibility -> full_path -> type_constant -> unit +val locate_type : qualid -> type_constant +val locate_extended_all_type : qualid -> type_constant list +val shortest_qualid_of_type : type_constant -> qualid + +val push_projection : visibility -> full_path -> ltac_projection -> unit +val locate_projection : qualid -> ltac_projection +val locate_extended_all_projection : qualid -> ltac_projection list +val shortest_qualid_of_projection : ltac_projection -> qualid + +(** {5 Toplevel definitions of ML tactics} *) + +(** This state is not part of the summary, contrarily to the ones above. It is + intended to be used from ML plugins to register ML-side functions. *) + +val define_primitive : ml_tactic_name -> ml_tactic -> unit +val interp_primitive : ml_tactic_name -> ml_tactic + +(** {5 ML primitive types} *) + +type 'a ml_object = { + ml_type : type_constant; + ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; +} + +val define_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object -> unit +val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object + +(** {5 Absolute paths} *) + +val coq_prefix : ModPath.t +(** Path where primitive datatypes are defined in Ltac2 plugin. *) + +(** {5 Generic arguments} *) + +val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type diff --git a/src/tac2expr.mli b/src/tac2expr.mli new file mode 100644 index 0000000000..acdad9bab4 --- /dev/null +++ b/src/tac2expr.mli @@ -0,0 +1,195 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr Proofview.tactic + +type environment = valexpr Id.Map.t diff --git a/src/tac2intern.ml b/src/tac2intern.ml new file mode 100644 index 0000000000..b63e6a0cd8 --- /dev/null +++ b/src/tac2intern.ml @@ -0,0 +1,1454 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* elt -> bool +val create : unit -> 'a t +val fresh : 'a t -> elt +val find : elt -> 'a t -> (elt * 'a option) +val union : elt -> elt -> 'a t -> unit +val set : elt -> 'a -> 'a t -> unit +module Map : +sig + type key = elt + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val exists : (key -> 'a -> bool) -> 'a t -> bool +end +end += +struct +type elt = int +let equal = Int.equal +module Map = Int.Map + +type 'a node = +| Canon of int * 'a option +| Equiv of elt + +type 'a t = { + mutable uf_data : 'a node array; + mutable uf_size : int; +} + +let resize p = + if Int.equal (Array.length p.uf_data) p.uf_size then begin + let nsize = 2 * p.uf_size + 1 in + let v = Array.make nsize (Equiv 0) in + Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); + p.uf_data <- v; + end + +let create () = { uf_data = [||]; uf_size = 0 } + +let fresh p = + resize p; + let n = p.uf_size in + p.uf_data.(n) <- (Canon (1, None)); + p.uf_size <- n + 1; + n + +let rec lookup n p = + let node = Array.get p.uf_data n in + match node with + | Canon (size, v) -> n, size, v + | Equiv y -> + let ((z, _, _) as res) = lookup y p in + if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); + res + +let find n p = + let (x, _, v) = lookup n p in (x, v) + +let union x y p = + let ((x, size1, _) as xcan) = lookup x p in + let ((y, size2, _) as ycan) = lookup y p in + let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in + let x, _, xnode = xcan in + let y, _, ynode = ycan in + assert (Option.is_empty xnode); + assert (Option.is_empty ynode); + p.uf_data.(x) <- Equiv y; + p.uf_data.(y) <- Canon (size1 + size2, None) + +let set x v p = + let (x, s, v') = lookup x p in + assert (Option.is_empty v'); + p.uf_data.(x) <- Canon (s, Some v) + +end + +type mix_var = +| GVar of UF.elt +| LVar of int + +type mix_type_scheme = int * mix_var glb_typexpr + +type environment = { + env_var : mix_type_scheme Id.Map.t; + (** Type schemes of bound variables *) + env_cst : UF.elt glb_typexpr UF.t; + (** Unification state *) + env_als : UF.elt Id.Map.t ref; + (** Map user-facing type variables to unification variables *) + env_opn : bool; + (** Accept unbound type variables *) + env_rec : (KerName.t * int) Id.Map.t; + (** Recursive type definitions *) +} + +let empty_env () = { + env_var = Id.Map.empty; + env_cst = UF.create (); + env_als = ref Id.Map.empty; + env_opn = true; + env_rec = Id.Map.empty; +} + +let env_name env = + (** Generate names according to a provided environment *) + let mk num = + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + name + in + let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in + let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in + let vars = ref vars in + let rec fresh n = + let name = mk n in + if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) + else name + in + fun n -> + if UF.Map.mem n !vars then UF.Map.find n !vars + else + let ans = fresh 0 in + let () = vars := UF.Map.add n ans !vars in + ans + +let ltac2_env : environment Genintern.Store.field = + Genintern.Store.field () + +let fresh_id env = UF.fresh env.env_cst + +let get_alias (loc, id) env = + try Id.Map.find id env.env_als.contents + with Not_found -> + if env.env_opn then + let n = fresh_id env in + let () = env.env_als := Id.Map.add id n env.env_als.contents in + n + else user_err ?loc (str "Unbound type parameter " ++ Id.print id) + +let push_name id t env = match id with +| Anonymous -> env +| Name id -> { env with env_var = Id.Map.add id t env.env_var } + +let dummy_loc = Loc.make_loc (-1, -1) + +let loc_of_tacexpr = function +| CTacAtm (loc, _) -> Option.default dummy_loc loc +| CTacRef (RelId (loc, _)) -> Option.default dummy_loc loc +| CTacRef (AbsKn _) -> dummy_loc +| CTacFun (loc, _, _) -> loc +| CTacApp (loc, _, _) -> loc +| CTacLet (loc, _, _, _) -> loc +| CTacTup (loc, _) -> Option.default dummy_loc loc +| CTacArr (loc, _) -> Option.default dummy_loc loc +| CTacLst (loc, _) -> Option.default dummy_loc loc +| CTacCnv (loc, _, _) -> loc +| CTacSeq (loc, _, _) -> loc +| CTacCse (loc, _, _) -> loc +| CTacRec (loc, _) -> loc +| CTacPrj (loc, _, _) -> loc +| CTacSet (loc, _, _, _) -> loc +| CTacExt (loc, _) -> loc + +let loc_of_patexpr = function +| CPatAny loc -> loc +| CPatRef (loc, _, _) -> loc +| CPatTup (loc, _) -> Option.default dummy_loc loc + +let error_nargs_mismatch loc nargs nfound = + user_err ~loc (str "Constructor expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let error_nparams_mismatch loc nargs nfound = + user_err ~loc (str "Type expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst id +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypTuple tl -> GTypTuple (List.map (fun t -> subst_type subst t) tl) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (loc, Name id) -> GTypVar (get_alias (Loc.tag ?loc id) env) +| CTypVar (_, Anonymous) -> GTypVar (fresh_id env) +| CTypRef (loc, rel, args) -> + let (kn, nparams) = match rel with + | RelId (loc, qid) -> + let (dp, id) = repr_qualid qid in + if DirPath.is_empty dp && Id.Map.mem id env.env_rec then + Id.Map.find id env.env_rec + else + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) + in + let (nparams, _) = Tac2env.interp_type kn in + (kn, nparams) + | AbsKn kn -> + let (nparams, _) = Tac2env.interp_type kn in + (kn, nparams) + in + let nargs = List.length args in + let () = + if not (Int.equal nparams nargs) then + let loc, qid = match rel with + | RelId lid -> lid + | AbsKn kn -> Some loc, shortest_qualid_of_type kn + in + user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ + strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ + applied to " ++ int nargs ++ strbrk "argument(s)") + in + GTypRef (kn, List.map (fun t -> intern_type env t) args) +| CTypArrow (loc, t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) +| CTypTuple (loc, tl) -> GTypTuple (List.map (fun t -> intern_type env t) tl) + +let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + subst_type substf t + +let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf = function + | LVar i -> GTypVar subst.(i) + | GVar n -> GTypVar n + in + subst_type substf t + +let fresh_reftype env (kn : KerName.t) = + let (n, _) = Tac2env.interp_type kn in + let subst = Array.init n (fun _ -> fresh_id env) in + let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in + (subst, t) + +(** First-order unification algorithm *) + +let is_unfoldable kn = match snd (Tac2env.interp_type kn) with +| GTydDef (Some _) -> true +| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false + +let unfold env kn args = + let (nparams, def) = Tac2env.interp_type kn in + let def = match def with + | GTydDef (Some t) -> t + | _ -> assert false + in + let args = Array.of_list args in + let subst n = args.(n) in + subst_type subst def + +(** View function, allows to ensure head normal forms *) +let rec kind env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> kind env t + end +| GTypRef (kn, tl) -> + if is_unfoldable kn then kind env (unfold env kn tl) else t +| GTypArrow _ | GTypTuple _ -> t + +exception Occur + +let rec occur_check env id t = match kind env t with +| GTypVar id' -> if UF.equal id id' then raise Occur +| GTypArrow (t1, t2) -> + let () = occur_check env id t1 in + occur_check env id t2 +| GTypTuple tl -> + List.iter (fun t -> occur_check env id t) tl +| GTypRef (kn, tl) -> + List.iter (fun t -> occur_check env id t) tl + +exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr + +let unify_var env id t = match kind env t with +| GTypVar id' -> + if not (UF.equal id id') then UF.union id id' env.env_cst +| GTypArrow _ | GTypRef _ | GTypTuple _ -> + try + let () = occur_check env id t in + UF.set id t env.env_cst + with Occur -> raise (CannotUnify (GTypVar id, t)) + +let rec unify env t1 t2 = match kind env t1, kind env t2 with +| GTypVar id, t | t, GTypVar id -> + unify_var env id t +| GTypArrow (t1, u1), GTypArrow (t2, u2) -> + let () = unify env t1 t2 in + unify env u1 u2 +| GTypTuple tl1, GTypTuple tl2 -> + if Int.equal (List.length tl1) (List.length tl2) then + List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> + if KerName.equal kn1 kn2 then + List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| _ -> raise (CannotUnify (t1, t2)) + +let unify ?loc env t1 t2 = + try unify env t1 t2 + with CannotUnify (u1, u2) -> + let name = env_name env in + user_err ?loc (str "This expression has type " ++ pr_glbtype name t1 ++ + str " but an expression what expected of type " ++ pr_glbtype name t2) + +(** Term typing *) + +let is_pure_constructor kn = + match snd (Tac2env.interp_type kn) with + | GTydAlg _ | GTydOpn -> true + | GTydRec fields -> + let is_pure (_, mut, _) = not mut in + List.for_all is_pure fields + | GTydDef _ -> assert false (** Type definitions have no constructors *) + +let rec is_value = function +| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true +| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false +| GTacCst (GCaseTuple _, _, el) -> List.for_all is_value el +| GTacCst (_, _, []) -> true +| GTacOpn (_, el) -> List.for_all is_value el +| GTacCst (GCaseAlg kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ +| GTacWth _ -> false + +let is_rec_rhs = function +| GTacFun _ -> true +| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ +| GTacSet _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacCse _ | GTacOpn _ | GTacWth _ -> false + +let rec fv_type f t accu = match t with +| GTypVar id -> f id accu +| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) +| GTypTuple tl -> List.fold_left (fun accu t -> fv_type f t accu) accu tl +| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl + +let fv_env env = + let rec f id accu = match UF.find id env.env_cst with + | id, None -> UF.Map.add id () accu + | _, Some t -> fv_type f t accu + in + let fold_var id (_, t) accu = + let fmix id accu = match id with + | LVar _ -> accu + | GVar id -> f id accu + in + fv_type fmix t accu + in + let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in + let fold_als _ id accu = f id accu in + Id.Map.fold fold_als !(env.env_als) fv_var + +let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = + let fv = fv_env env in + let count = ref 0 in + let vars = ref UF.Map.empty in + let rec subst id = + let (id, t) = UF.find id env.env_cst in + match t with + | None -> + if UF.Map.mem id fv then GTypVar (GVar id) + else + begin try UF.Map.find id !vars + with Not_found -> + let n = !count in + let var = GTypVar (LVar n) in + let () = incr count in + let () = vars := UF.Map.add id var !vars in + var + end + | Some t -> subst_type subst t + in + let t = subst_type subst t in + (!count, t) + +let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = + let subst id = GTypVar (GVar id) in + (0, subst_type subst t) + +let warn_not_unit = + CWarnings.create ~name:"not-unit" ~category:"ltac" + (fun () -> strbrk "The following expression should have type unit.") + +let warn_redundant_clause = + CWarnings.create ~name:"redundant-clause" ~category:"ltac" + (fun () -> strbrk "The following clause is redundant.") + +let check_elt_unit loc env t = + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ | GTypTuple _ -> false + | GTypRef (kn, _) -> KerName.equal kn t_unit + in + if not maybe_unit then warn_not_unit ~loc () + +let check_elt_empty loc env t = match kind env t with +| GTypVar _ -> + user_err ~loc (str "Cannot infer an empty type for this expression") +| GTypArrow _ | GTypTuple _ -> + let name = env_name env in + user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") +| GTypRef (kn, _) -> + let def = Tac2env.interp_type kn in + match def with + | _, GTydAlg [] -> kn + | _ -> + let name = env_name env in + user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") + +let check_unit ?loc t = + let maybe_unit = match t with + | GTypVar _ -> true + | GTypArrow _ | GTypTuple _ -> false + | GTypRef (kn, _) -> KerName.equal kn t_unit + in + if not maybe_unit then warn_not_unit ?loc () + +let check_redundant_clause = function +| [] -> () +| (p, _) :: _ -> warn_redundant_clause ~loc:(loc_of_patexpr p) () + +let get_variable0 mem var = match var with +| RelId (loc, qid) -> + let (dp, id) = repr_qualid qid in + if DirPath.is_empty dp && mem id then ArgVar (loc, id) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> + CErrors.user_err ?loc (str "Unbound value " ++ pr_qualid qid) + in + ArgArg kn +| AbsKn kn -> ArgArg kn + +let get_variable env var = + let mem id = Id.Map.mem id env.env_var in + get_variable0 mem var + +let get_constructor env var = match var with +| RelId (loc, qid) -> + let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in + begin match c with + | Some (TacConstructor knc) -> + let kn = Tac2env.interp_constructor knc in + ArgArg (kn, knc) + | Some (TacConstant _) -> + CErrors.user_err ?loc (str "The term " ++ pr_qualid qid ++ + str " is not the constructor of an inductive type.") + | None -> + let (dp, id) = repr_qualid qid in + if DirPath.is_empty dp then ArgVar (loc, id) + else CErrors.user_err ?loc (str "Unbound constructor " ++ pr_qualid qid) + end +| AbsKn knc -> + let kn = Tac2env.interp_constructor knc in + ArgArg (kn, knc) + +let get_projection var = match var with +| RelId (loc, qid) -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc (pr_qualid qid ++ str " is not a projection") + in + Tac2env.interp_projection kn +| AbsKn kn -> + Tac2env.interp_projection kn + +let intern_atm env = function +| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (t_int, [])) +| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (t_string, [])) + +let invalid_pattern ?loc kn t = + let pt = match t with + | GCaseAlg kn' -> pr_typref kn + | GCaseTuple n -> str "tuple" + in + user_err ?loc (str "Invalid pattern, expected a pattern for type " ++ + pr_typref kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) + +(** Pattern view *) + +type glb_patexpr = +| GPatVar of Name.t +| GPatRef of ltac_constructor * glb_patexpr list +| GPatTup of glb_patexpr list + +let rec intern_patexpr env = function +| CPatAny _ -> GPatVar Anonymous +| CPatRef (_, qid, []) -> + begin match get_constructor env qid with + | ArgVar (_, id) -> GPatVar (Name id) + | ArgArg (_, kn) -> GPatRef (kn, []) + end +| CPatRef (_, qid, pl) -> + begin match get_constructor env qid with + | ArgVar (loc, id) -> + user_err ?loc (str "Unbound constructor " ++ Nameops.pr_id id) + | ArgArg (_, kn) -> GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) + end +| CPatTup (_, pl) -> + GPatTup (List.map (fun p -> intern_patexpr env p) pl) + +type pattern_kind = +| PKind_empty +| PKind_variant of type_constant +| PKind_open of type_constant +| PKind_tuple of int +| PKind_any + +let get_pattern_kind env pl = match pl with +| [] -> PKind_empty +| p :: pl -> + let rec get_kind (p, _) pl = match intern_patexpr env p with + | GPatVar _ -> + begin match pl with + | [] -> PKind_any + | p :: pl -> get_kind p pl + end + | GPatRef (kn, pl) -> + let data = Tac2env.interp_constructor kn in + if Option.is_empty data.cdata_indx then PKind_open data.cdata_type + else PKind_variant data.cdata_type + | GPatTup tp -> PKind_tuple (List.length tp) + in + get_kind p pl + +(** Internalization *) + +let is_constructor env qid = match get_variable env qid with +| ArgArg (TacConstructor _) -> true +| _ -> false + +let rec intern_rec env = function +| CTacAtm (_, atm) -> intern_atm env atm +| CTacRef qid as e -> + begin match get_variable env qid with + | ArgVar (_, id) -> + let sch = Id.Map.find id env.env_var in + (GTacVar id, fresh_mix_type_scheme env sch) + | ArgArg (TacConstant kn) -> + let (_, _, sch) = Tac2env.interp_global kn in + (GTacRef kn, fresh_type_scheme env sch) + | ArgArg (TacConstructor kn) -> + let loc = loc_of_tacexpr e in + intern_constructor env loc kn [] + end +| CTacFun (loc, bnd, e) -> + let fold (env, bnd, tl) ((_, na), t) = + let t = match t with + | None -> GTypVar (fresh_id env) + | Some t -> intern_type env t + in + let env = push_name na (monomorphic t) env in + (env, na :: bnd, t :: tl) + in + let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in + let bnd = List.rev bnd in + let (e, t) = intern_rec env e in + let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in + (GTacFun (bnd, e), t) +| CTacApp (loc, CTacRef qid, args) as e when is_constructor env qid -> + let kn = match get_variable env qid with + | ArgArg (TacConstructor kn) -> kn + | _ -> assert false + in + let loc = loc_of_tacexpr e in + intern_constructor env loc kn args +| CTacApp (loc, f, args) -> + let (f, ft) = intern_rec env f in + let fold arg (args, t) = + let (arg, argt) = intern_rec env arg in + (arg :: args, GTypArrow (argt, t)) + in + let ret = GTypVar (fresh_id env) in + let (args, t) = List.fold_right fold args ([], ret) in + let () = unify ~loc env ft t in + (GTacApp (f, args), ret) +| CTacLet (loc, false, el, e) -> + let fold accu ((loc, na), _, _) = match na with + | Anonymous -> accu + | Name id -> + if Id.Set.mem id accu then + user_err ?loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + else Id.Set.add id accu + in + let _ = List.fold_left fold Id.Set.empty el in + let fold ((loc, na), tc, e) (el, p) = + let (e, t) = intern_rec env e in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify ?loc env t tc + in + let t = if is_value e then abstract_var env t else monomorphic t in + ((na, e) :: el), ((na, t) :: p) + in + let (el, p) = List.fold_right fold el ([], []) in + let nenv = List.fold_left (fun accu (na, t) -> push_name na t env) env p in + let (e, t) = intern_rec nenv e in + (GTacLet (false, el, e), t) +| CTacLet (loc, true, el, e) -> + intern_let_rec env loc el e +| CTacTup (loc, []) -> + (GTacCst (GCaseAlg t_unit, 0, []), GTypRef (t_unit, [])) +| CTacTup (loc, el) -> + let fold e (el, tl) = + let (e, t) = intern_rec env e in + (e :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + (GTacCst (GCaseTuple (List.length el), 0, el), GTypTuple tl) +| CTacArr (loc, []) -> + let id = fresh_id env in + (GTacArr [], GTypRef (t_int, [GTypVar id])) +| CTacArr (loc, e0 :: el) -> + let (e0, t0) = intern_rec env e0 in + let fold e el = intern_rec_with_constraint env e t0 :: el in + let el = e0 :: List.fold_right fold el [] in + (GTacArr el, GTypRef (t_array, [t0])) +| CTacLst (loc, []) -> + let id = fresh_id env in + (c_nil, GTypRef (t_list, [GTypVar id])) +| CTacLst (loc, e0 :: el) -> + let (e0, t0) = intern_rec env e0 in + let fold e el = c_cons (intern_rec_with_constraint env e t0) el in + let el = c_cons e0 (List.fold_right fold el c_nil) in + (el, GTypRef (t_list, [t0])) +| CTacCnv (loc, e, tc) -> + let (e, t) = intern_rec env e in + let tc = intern_type env tc in + let () = unify ~loc env t tc in + (e, tc) +| CTacSeq (loc, e1, e2) -> + let (e1, t1) = intern_rec env e1 in + let (e2, t2) = intern_rec env e2 in + let () = check_elt_unit loc env t1 in + (GTacLet (false, [Anonymous, e1], e2), t2) +| CTacCse (loc, e, pl) -> + intern_case env loc e pl +| CTacRec (loc, fs) -> + intern_record env loc fs +| CTacPrj (loc, e, proj) -> + let pinfo = get_projection proj in + let loc = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (pinfo.pdata_type, params) in + let () = unify ~loc env t exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) +| CTacSet (loc, e, proj, r) -> + let pinfo = get_projection proj in + let () = + if not pinfo.pdata_mutb then + let loc = match proj with + | RelId (loc, _) -> loc + | AbsKn _ -> None + in + user_err ?loc (str "Field is not mutable") + in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (pinfo.pdata_type, params) in + let e = intern_rec_with_constraint env e exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + let r = intern_rec_with_constraint env r ret in + (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (t_unit, [])) +| CTacExt (loc, ext) -> + let open Genintern in + let GenArg (Rawwit tag, _) = ext in + let tpe = interp_ml_object tag in + (** External objects do not have access to the named context because this is + not stable by dynamic semantics. *) + let genv = Global.env_of_context Environ.empty_named_context_val in + let ist = empty_glob_sign genv in + let ist = { ist with extra = Store.set ist.extra ltac2_env env } in + let (_, ext) = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> generic_intern ist ext) () in + (GTacExt ext, GTypRef (tpe.ml_type, [])) + +and intern_rec_with_constraint env e exp = + let loc = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let () = unify ~loc env t exp in + e + +and intern_let_rec env loc el e = + let fold accu ((loc, na), _, _) = match na with + | Anonymous -> accu + | Name id -> + if Id.Set.mem id accu then + user_err ?loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + else Id.Set.add id accu + in + let _ = List.fold_left fold Id.Set.empty el in + let map env ((loc, na), t, e) = + let id = fresh_id env in + let env = push_name na (monomorphic (GTypVar id)) env in + (env, (loc, na, t, e, id)) + in + let (env, el) = List.fold_map map env el in + let fold (loc, na, tc, e, id) (el, tl) = + let loc_e = loc_of_tacexpr e in + let (e, t) = intern_rec env e in + let () = + if not (is_rec_rhs e) then + user_err ~loc:loc_e (str "This kind of expression is not allowed as \ + right-hand side of a recursive binding") + in + let () = unify ?loc env t (GTypVar id) in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify ?loc env t tc + in + ((na, e) :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + let (e, t) = intern_rec env e in + (GTacLet (true, el, e), t) + +(** For now, patterns recognized by the pattern-matching compiling are limited + to depth-one where leaves are either variables or catch-all *) +and intern_case env loc e pl = + let (e', t) = intern_rec env e in + let todo ~loc () = user_err ~loc (str "Pattern not handled yet") in + match get_pattern_kind env pl with + | PKind_any -> + let (pat, b) = List.hd pl in + let na = match intern_patexpr env pat with + | GPatVar na -> na + | _ -> assert false + in + let () = check_redundant_clause (List.tl pl) in + let env = push_name na (monomorphic t) env in + let (b, tb) = intern_rec env b in + (GTacLet (false, [na, e'], b), tb) + | PKind_empty -> + let kn = check_elt_empty loc env t in + let r = fresh_id env in + (GTacCse (e', GCaseAlg kn, [||], [||]), GTypVar r) + | PKind_tuple len -> + begin match pl with + | [] -> assert false + | [CPatTup (_, []), b] -> + let () = unify ~loc:(loc_of_tacexpr e) env t (GTypRef (t_unit, [])) in + let (b, tb) = intern_rec env b in + (GTacCse (e', GCaseAlg t_unit, [|b|], [||]), tb) + | [CPatTup (_, pl), b] -> + let map = function + | CPatAny _ -> Anonymous + | CPatRef (loc, qid, []) -> + begin match get_constructor env qid with + | ArgVar (_, id) -> Name id + | ArgArg _ -> todo ~loc () + end + | p -> todo ~loc:(loc_of_patexpr p) () + in + let ids = Array.map_of_list map pl in + let tc = GTypTuple (List.map (fun _ -> GTypVar (fresh_id env)) pl) in + let () = unify ~loc:(loc_of_tacexpr e) env t tc in + let (b, tb) = intern_rec env b in + (GTacCse (e', GCaseTuple len, [||], [|ids, b|]), tb) + | (p, _) :: _ -> todo ~loc:(loc_of_patexpr p) () + end + | PKind_variant kn -> + let subst, tc = fresh_reftype env kn in + let () = unify ~loc:(loc_of_tacexpr e) env t tc in + let (params, def) = Tac2env.interp_type kn in + let cstrs = match def with + | GTydAlg c -> c + | _ -> assert false + in + let count (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left count (0, 0) cstrs in + let const = Array.make nconst None in + let nonconst = Array.make nnonconst None in + let ret = GTypVar (fresh_id env) in + let rec intern_branch = function + | [] -> () + | (pat, br) :: rem -> + let tbr = match pat with + | CPatAny _ -> + let () = check_redundant_clause rem in + let (br', brT) = intern_rec env br in + (** Fill all remaining branches *) + let fill (ncst, narg) (_, args) = + if List.is_empty args then + let () = + if Option.is_empty const.(ncst) then const.(ncst) <- Some br' + in + (succ ncst, narg) + else + let () = + if Option.is_empty const.(narg) then + let ids = Array.map_of_list (fun _ -> Anonymous) args in + nonconst.(narg) <- Some (ids, br') + in + (ncst, succ narg) + in + let _ = List.fold_left fill (0, 0) cstrs in + brT + | CPatRef (loc, qid, args) -> + let data = match get_constructor env qid with + | ArgVar _ -> todo ~loc () + | ArgArg (data, _) -> + let () = + let kn' = data.cdata_type in + if not (KerName.equal kn kn') then + invalid_pattern ~loc kn (GCaseAlg kn') + in + data + in + let get_id = function + | CPatAny _ -> Anonymous + | CPatRef (loc, qid, []) -> + begin match get_constructor env qid with + | ArgVar (_, id) -> Name id + | ArgArg _ -> todo ~loc () + end + | p -> todo ~loc:(loc_of_patexpr p) () + in + let ids = List.map get_id args in + let nids = List.length ids in + let nargs = List.length data.cdata_args in + let () = + if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids + in + let fold env id tpe = + (** Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids data.cdata_args in + let (br', brT) = intern_rec nenv br in + let () = + let index = match data.cdata_indx with + | Some i -> i + | None -> assert false + in + if List.is_empty args then + if Option.is_empty const.(index) then const.(index) <- Some br' + else warn_redundant_clause ~loc () + else + let ids = Array.of_list ids in + if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') + else warn_redundant_clause ~loc () + in + brT + | CPatTup (loc, tup) -> + invalid_pattern ?loc kn (GCaseTuple (List.length tup)) + in + let () = unify ~loc:(loc_of_tacexpr br) env ret tbr in + intern_branch rem + in + let () = intern_branch pl in + let map = function + | None -> user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) + | Some x -> x + in + let const = Array.map map const in + let nonconst = Array.map map nonconst in + let ce = GTacCse (e', GCaseAlg kn, const, nonconst) in + (ce, ret) + | PKind_open kn -> + let subst, tc = fresh_reftype env kn in + let () = unify ~loc:(loc_of_tacexpr e) env t tc in + let ret = GTypVar (fresh_id env) in + let rec intern_branch map = function + | [] -> + user_err ~loc (str "Missing default case") + | (pat, br) :: rem -> + match intern_patexpr env pat with + | GPatVar na -> + let () = check_redundant_clause rem in + let nenv = push_name na (monomorphic tc) env in + let br' = intern_rec_with_constraint nenv br ret in + let def = (na, br') in + (map, def) + | GPatRef (knc, args) -> + let get = function + | GPatVar na -> na + | GPatRef _ | GPatTup _ -> + user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) + in + let loc = loc_of_patexpr pat in + let ids = List.map get args in + let data = Tac2env.interp_constructor knc in + let () = + if not (KerName.equal kn data.cdata_type) then + invalid_pattern ~loc kn (GCaseAlg data.cdata_type) + in + let nids = List.length ids in + let nargs = List.length data.cdata_args in + let () = + if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids + in + let fold env id tpe = + (** Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids data.cdata_args in + let br' = intern_rec_with_constraint nenv br ret in + let map = + if KNmap.mem knc map then + let () = warn_redundant_clause ~loc () in + map + else + KNmap.add knc (Anonymous, Array.of_list ids, br') map + in + intern_branch map rem + | GPatTup tup -> + invalid_pattern ~loc kn (GCaseTuple (List.length tup)) + in + let (map, def) = intern_branch KNmap.empty pl in + (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) + +and intern_constructor env loc kn args = + let cstr = interp_constructor kn in + let nargs = List.length cstr.cdata_args in + if Int.equal nargs (List.length args) then + let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in + let ans = GTypRef (cstr.cdata_type, List.init cstr.cdata_prms (fun i -> GTypVar subst.(i))) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + match cstr.cdata_indx with + | Some idx -> + (GTacCst (GCaseAlg cstr.cdata_type, idx, args), ans) + | None -> + (GTacOpn (kn, args), ans) + else + error_nargs_mismatch loc nargs (List.length args) + +and intern_record env loc fs = + let map (proj, e) = + let loc = match proj with + | RelId (loc, _) -> loc + | AbsKn _ -> None + in + let proj = get_projection proj in + (loc, proj, e) + in + let fs = List.map map fs in + let kn = match fs with + | [] -> user_err ~loc (str "Cannot infer the corresponding record type") + | (_, proj, _) :: _ -> proj.pdata_type + in + let params, typdef = match Tac2env.interp_type kn with + | n, GTydRec def -> n, def + | _ -> assert false + in + let subst = Array.init params (fun _ -> fresh_id env) in + (** Set the answer [args] imperatively *) + let args = Array.make (List.length typdef) None in + let iter (loc, pinfo, e) = + if KerName.equal kn pinfo.pdata_type then + let index = pinfo.pdata_indx in + match args.(index) with + | None -> + let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in + let e = intern_rec_with_constraint env e exp in + args.(index) <- Some e + | Some _ -> + let (name, _, _) = List.nth typdef pinfo.pdata_indx in + user_err ?loc (str "Field " ++ Id.print name ++ str " is defined \ + several times") + else + user_err ?loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ + pertain to record definition " ++ pr_typref pinfo.pdata_type) + in + let () = List.iter iter fs in + let () = match Array.findi (fun _ o -> Option.is_empty o) args with + | None -> () + | Some i -> + let (field, _, _) = List.nth typdef i in + user_err ~loc (str "Field " ++ Id.print field ++ str " is undefined") + in + let args = Array.map_to_list Option.get args in + let tparam = List.init params (fun i -> GTypVar subst.(i)) in + (GTacCst (GCaseAlg kn, 0, args), GTypRef (kn, tparam)) + +let normalize env (count, vars) (t : UF.elt glb_typexpr) = + let get_var id = + try UF.Map.find id !vars + with Not_found -> + let () = assert env.env_opn in + let n = GTypVar !count in + let () = incr count in + let () = vars := UF.Map.add id n !vars in + n + in + let rec subst id = match UF.find id env.env_cst with + | id, None -> get_var id + | _, Some t -> subst_type subst t + in + subst_type subst t + +let intern e = + let env = empty_env () in + let (e, t) = intern_rec env e in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (e, (!count, t)) + +let intern_typedef self (ids, t) : glb_quant_typedef = + let env = { (empty_env ()) with env_rec = self } in + (** Initialize type parameters *) + let map id = get_alias id env in + let ids = List.map map ids in + let count = ref (List.length ids) in + let vars = ref UF.Map.empty in + let iter n id = vars := UF.Map.add id (GTypVar n) !vars in + let () = List.iteri iter ids in + (** Do not accept unbound type variables *) + let env = { env with env_opn = false } in + let intern t = + let t = intern_type env t in + normalize env (count, vars) t + in + let count = !count in + match t with + | CTydDef None -> (count, GTydDef None) + | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) + | CTydAlg constrs -> + let map (c, t) = (c, List.map intern t) in + let constrs = List.map map constrs in + (count, GTydAlg constrs) + | CTydRec fields -> + let map (c, mut, t) = (c, mut, intern t) in + let fields = List.map map fields in + (count, GTydRec fields) + | CTydOpn -> (count, GTydOpn) + +let intern_open_type t = + let env = empty_env () in + let t = intern_type env t in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (!count, t) + +(** Globalization *) + +let add_name accu = function +| Name id -> Id.Set.add id accu +| Anonymous -> accu + +let get_projection0 var = match var with +| RelId (loc, qid) -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc (pr_qualid qid ++ str " is not a projection") + in + kn +| AbsKn kn -> kn + +let rec globalize ids e = match e with +| CTacAtm _ -> e +| CTacRef ref -> + let mem id = Id.Set.mem id ids in + begin match get_variable0 mem ref with + | ArgVar _ -> e + | ArgArg kn -> CTacRef (AbsKn kn) + end +| CTacFun (loc, bnd, e) -> + let fold accu ((_, na), _) = add_name accu na in + let ids = List.fold_left fold ids bnd in + let e = globalize ids e in + CTacFun (loc, bnd, e) +| CTacApp (loc, e, el) -> + let e = globalize ids e in + let el = List.map (fun e -> globalize ids e) el in + CTacApp (loc, e, el) +| CTacLet (loc, isrec, bnd, e) -> + let fold accu ((_, na), _, _) = add_name accu na in + let ext = List.fold_left fold Id.Set.empty bnd in + let eids = Id.Set.union ext ids in + let e = globalize eids e in + let map (qid, t, e) = + let ids = if isrec then eids else ids in + (qid, t, globalize ids e) + in + let bnd = List.map map bnd in + CTacLet (loc, isrec, bnd, e) +| CTacTup (loc, el) -> + let el = List.map (fun e -> globalize ids e) el in + CTacTup (loc, el) +| CTacArr (loc, el) -> + let el = List.map (fun e -> globalize ids e) el in + CTacArr (loc, el) +| CTacLst (loc, el) -> + let el = List.map (fun e -> globalize ids e) el in + CTacLst (loc, el) +| CTacCnv (loc, e, t) -> + let e = globalize ids e in + CTacCnv (loc, e, t) +| CTacSeq (loc, e1, e2) -> + let e1 = globalize ids e1 in + let e2 = globalize ids e2 in + CTacSeq (loc, e1, e2) +| CTacCse (loc, e, bl) -> + let e = globalize ids e in + let bl = List.map (fun b -> globalize_case ids b) bl in + CTacCse (loc, e, bl) +| CTacRec (loc, r) -> + let map (p, e) = + let p = get_projection0 p in + let e = globalize ids e in + (AbsKn p, e) + in + CTacRec (loc, List.map map r) +| CTacPrj (loc, e, p) -> + let e = globalize ids e in + let p = get_projection0 p in + CTacPrj (loc, e, AbsKn p) +| CTacSet (loc, e, p, e') -> + let e = globalize ids e in + let p = get_projection0 p in + let e' = globalize ids e' in + CTacSet (loc, e, AbsKn p, e') +| CTacExt (loc, arg) -> + let arg = pr_argument_type (genarg_tag arg) in + CErrors.user_err ~loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) + +and globalize_case ids (p, e) = + (globalize_pattern ids p, globalize ids e) + +and globalize_pattern ids p = match p with +| CPatAny _ -> p +| CPatRef (loc, cst, pl) -> + let cst = match get_constructor () cst with + | ArgVar _ -> cst + | ArgArg (_, knc) -> AbsKn knc + in + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CPatRef (loc, cst, pl) +| CPatTup (loc, pl) -> + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CPatTup (loc, pl) + +(** Kernel substitution *) + +open Mod_subst + +let rec subst_type subst t = match t with +| GTypVar _ -> t +| GTypArrow (t1, t2) -> + let t1' = subst_type subst t1 in + let t2' = subst_type subst t2 in + if t1' == t1 && t2' == t2 then t + else GTypArrow (t1', t2') +| GTypTuple tl -> + let tl'= List.smartmap (fun t -> subst_type subst t) tl in + if tl' == tl then t else GTypTuple tl' +| GTypRef (kn, tl) -> + let kn' = subst_kn subst kn in + let tl' = List.smartmap (fun t -> subst_type subst t) tl in + if kn' == kn && tl' == tl then t else GTypRef (kn', tl') + +let subst_case_info subst ci = match ci with +| GCaseAlg kn -> + let kn' = subst_kn subst kn in + if kn' == kn then ci else GCaseAlg kn' +| GCaseTuple _ -> ci + +let rec subst_expr subst e = match e with +| GTacAtm _ | GTacVar _ | GTacPrm _ -> e +| GTacRef kn -> GTacRef (subst_kn subst kn) +| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) +| GTacApp (f, args) -> + GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) +| GTacLet (r, bs, e) -> + let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in + GTacLet (r, bs, subst_expr subst e) +| GTacArr el -> + GTacArr (List.map (fun e -> subst_expr subst e) el) +| GTacCst (t, n, el) as e0 -> + let t' = match t with + | GCaseAlg kn -> + let kn' = subst_kn subst kn in + if kn' == kn then t else GCaseAlg kn' + | GCaseTuple _ -> t + in + let el' = List.smartmap (fun e -> subst_expr subst e) el in + if t' == t && el' == el then e0 else GTacCst (t', n, el') +| GTacCse (e, ci, cse0, cse1) -> + let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in + let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in + let ci' = subst_case_info subst ci in + GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> + let e' = subst_expr subst e in + let def' = subst_expr subst def in + let fold kn (self, vars, p) accu = + let kn' = subst_kn subst kn in + let p' = subst_expr subst p in + if kn' == kn && p' == p then accu + else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) + in + let br' = KNmap.fold fold br br in + if e' == e && br' == br && def' == def then e0 + else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } +| GTacPrj (kn, e, p) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) +| GTacSet (kn, e, p, r) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + let r' = subst_expr subst r in + if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') +| GTacExt ext -> + let ext' = Genintern.generic_substitute subst ext in + if ext' == ext then e else GTacExt ext' +| GTacOpn (kn, el) as e0 -> + let kn' = subst_kn subst kn in + let el' = List.smartmap (fun e -> subst_expr subst e) el in + if kn' == kn && el' == el then e0 else GTacOpn (kn', el') + +let subst_typedef subst e = match e with +| GTydDef t -> + let t' = Option.smartmap (fun t -> subst_type subst t) t in + if t' == t then e else GTydDef t' +| GTydAlg constrs -> + let map (c, tl as p) = + let tl' = List.smartmap (fun t -> subst_type subst t) tl in + if tl' == tl then p else (c, tl') + in + let constrs' = List.smartmap map constrs in + if constrs' == constrs then e else GTydAlg constrs' +| GTydRec fields -> + let map (c, mut, t as p) = + let t' = subst_type subst t in + if t' == t then p else (c, mut, t') + in + let fields' = List.smartmap map fields in + if fields' == fields then e else GTydRec fields' +| GTydOpn -> GTydOpn + +let subst_quant_typedef subst (prm, def as qdef) = + let def' = subst_typedef subst def in + if def' == def then qdef else (prm, def') + +let subst_type_scheme subst (prm, t as sch) = + let t' = subst_type subst t in + if t' == t then sch else (prm, t') + +let subst_or_relid subst ref = match ref with +| RelId _ -> ref +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn kn' + +let rec subst_rawtype subst t = match t with +| CTypVar _ -> t +| CTypArrow (loc, t1, t2) -> + let t1' = subst_rawtype subst t1 in + let t2' = subst_rawtype subst t2 in + if t1' == t1 && t2' == t2 then t else CTypArrow (loc, t1', t2') +| CTypTuple (loc, tl) -> + let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in + if tl' == tl then t else CTypTuple (loc, tl') +| CTypRef (loc, ref, tl) -> + let ref' = subst_or_relid subst ref in + let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in + if ref' == ref && tl' == tl then t else CTypRef (loc, ref', tl') + +let subst_tacref subst ref = match ref with +| RelId _ -> ref +| AbsKn (TacConstant kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstant kn') +| AbsKn (TacConstructor kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstructor kn') + +let subst_projection subst prj = match prj with +| RelId _ -> prj +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then prj else AbsKn kn' + +let rec subst_rawpattern subst p = match p with +| CPatAny _ -> p +| CPatRef (loc, c, pl) -> + let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in + let c' = match c with + | RelId _ -> c + | AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then c else AbsKn kn' + in + if pl' == pl && c' == c then p else CPatRef (loc, c', pl') +| CPatTup (loc, pl) -> + let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in + if pl' == pl then p else CPatTup (loc, pl') + +(** Used for notations *) +let rec subst_rawexpr subst t = match t with +| CTacAtm _ -> t +| CTacRef ref -> + let ref' = subst_tacref subst ref in + if ref' == ref then t else CTacRef ref' +| CTacFun (loc, bnd, e) -> + let map (na, t as p) = + let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in + if t' == t then p else (na, t') + in + let bnd' = List.smartmap map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CTacFun (loc, bnd', e') +| CTacApp (loc, e, el) -> + let e' = subst_rawexpr subst e in + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if e' == e && el' == el then t else CTacApp (loc, e', el') +| CTacLet (loc, isrec, bnd, e) -> + let map (na, t, e as p) = + let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in + let e' = subst_rawexpr subst e in + if t' == t && e' == e then p else (na, t', e') + in + let bnd' = List.smartmap map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CTacLet (loc, isrec, bnd', e') +| CTacTup (loc, el) -> + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if el' == el then t else CTacTup (loc, el') +| CTacArr (loc, el) -> + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if el' == el then t else CTacArr (loc, el') +| CTacLst (loc, el) -> + let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + if el' == el then t else CTacLst (loc, el') +| CTacCnv (loc, e, c) -> + let e' = subst_rawexpr subst e in + let c' = subst_rawtype subst c in + if c' == c && e' == e then t else CTacCnv (loc, e', c') +| CTacSeq (loc, e1, e2) -> + let e1' = subst_rawexpr subst e1 in + let e2' = subst_rawexpr subst e2 in + if e1' == e1 && e2' == e2 then t else CTacSeq (loc, e1', e2') +| CTacCse (loc, e, bl) -> + let map (p, e as x) = + let p' = subst_rawpattern subst p in + let e' = subst_rawexpr subst e in + if p' == p && e' == e then x else (p', e') + in + let e' = subst_rawexpr subst e in + let bl' = List.smartmap map bl in + if e' == e && bl' == bl then t else CTacCse (loc, e', bl') +| CTacRec (loc, el) -> + let map (prj, e as p) = + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then p else (prj', e') + in + let el' = List.smartmap map el in + if el' == el then t else CTacRec (loc, el') +| CTacPrj (loc, e, prj) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then t else CTacPrj (loc, e', prj') +| CTacSet (loc, e, prj, r) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + let r' = subst_rawexpr subst r in + if prj' == prj && e' == e && r' == r then t else CTacSet (loc, e', prj', r') +| CTacExt _ -> assert false (** Should not be generated by gloabalization *) + +(** Registering *) + +let () = + let open Genintern in + let intern ist tac = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> empty_env () + | Some env -> env + in + let loc = loc_of_tacexpr tac in + let (tac, t) = intern_rec env tac in + let () = check_elt_unit loc env t in + (ist, tac) + in + Genintern.register_intern0 wit_ltac2 intern +let () = Genintern.register_subst0 wit_ltac2 subst_expr diff --git a/src/tac2intern.mli b/src/tac2intern.mli new file mode 100644 index 0000000000..3d400a5cdd --- /dev/null +++ b/src/tac2intern.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Loc.t + +val intern : raw_tacexpr -> glb_tacexpr * type_scheme +val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef +val intern_open_type : raw_typexpr -> type_scheme + +(** Check that a term is a value. Only values are safe to marshall between + processes. *) +val is_value : glb_tacexpr -> bool +val check_unit : ?loc:Loc.t -> int glb_typexpr -> unit + +val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr +val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr +val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef +val subst_type_scheme : substitution -> type_scheme -> type_scheme + +val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr + +(** {5 Notations} *) + +val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr +(** Replaces all qualified identifiers by their corresponding kernel name. The + set represents bound variables in the context. *) + +(** Errors *) + +val error_nargs_mismatch : Loc.t -> int -> int -> 'a +val error_nparams_mismatch : Loc.t -> int -> int -> 'a diff --git a/src/tac2interp.ml b/src/tac2interp.ml new file mode 100644 index 0000000000..664b7de3d6 --- /dev/null +++ b/src/tac2interp.ml @@ -0,0 +1,160 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let c = Tac2print.pr_constructor kn in + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) +| _ -> raise Unhandled +end + +let val_exn = Geninterp.Val.create "ltac2:exn" + +type environment = valexpr Id.Map.t + +let empty_environment = Id.Map.empty + +let push_name ist id v = match id with +| Anonymous -> ist +| Name id -> Id.Map.add id v ist + +let get_var ist id = + try Id.Map.find id ist with Not_found -> + anomaly (str "Unbound variable " ++ Id.print id) + +let get_ref ist kn = + try pi2 (Tac2env.interp_global kn) with Not_found -> + anomaly (str "Unbound reference" ++ KerName.print kn) + +let return = Proofview.tclUNIT + +let rec interp ist = function +| GTacAtm (AtmInt n) -> return (ValInt n) +| GTacAtm (AtmStr s) -> return (ValStr (Bytes.of_string s)) +| GTacVar id -> return (get_var ist id) +| GTacRef qid -> return (get_ref ist qid) +| GTacFun (ids, e) -> + let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + return (ValCls cls) +| GTacApp (f, args) -> + interp ist f >>= fun f -> + Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> + interp_app f args +| GTacLet (false, el, e) -> + let fold accu (na, e) = + interp ist e >>= fun e -> + return (push_name accu na e) + in + Proofview.Monad.List.fold_left fold ist el >>= fun ist -> + interp ist e +| GTacLet (true, el, e) -> + let map (na, e) = match e with + | GTacFun (ids, e) -> + let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + na, cls + | _ -> anomaly (str "Ill-formed recursive function") + in + let fixs = List.map map el in + let fold accu (na, cls) = match na with + | Anonymous -> accu + | Name id -> Id.Map.add id (ValCls cls) accu + in + let ist = List.fold_left fold ist fixs in + (** Hack to make a cycle imperatively in the environment *) + let iter (_, e) = e.clos_env <- ist in + let () = List.iter iter fixs in + interp ist e +| GTacArr el -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (ValBlk (0, Array.of_list el)) +| GTacCst (_, n, []) -> return (ValInt n) +| GTacCst (_, n, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (ValBlk (n, Array.of_list el)) +| GTacCse (e, _, cse0, cse1) -> + interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> + interp ist e >>= fun e -> interp_with ist e cse def +| GTacPrj (_, e, p) -> + interp ist e >>= fun e -> interp_proj ist e p +| GTacSet (_, e, p, r) -> + interp ist e >>= fun e -> + interp ist r >>= fun r -> + interp_set ist e p r +| GTacOpn (kn, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (ValOpn (kn, Array.of_list el)) +| GTacPrm (ml, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + Tac2env.interp_primitive ml el +| GTacExt e -> + let GenArg (Glbwit tag, e) = e in + let tpe = Tac2env.interp_ml_object tag in + tpe.Tac2env.ml_interp ist e >>= fun e -> return (ValExt e) + +and interp_app f args = match f with +| ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> + let rec push ist ids args = match ids, args with + | [], [] -> interp ist e + | [], _ :: _ -> interp ist e >>= fun f -> interp_app f args + | _ :: _, [] -> + let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + return (ValCls cls) + | id :: ids, arg :: args -> push (push_name ist id arg) ids args + in + push ist ids args +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> + anomaly (str "Unexpected value shape") + +and interp_case ist e cse0 cse1 = match e with +| ValInt n -> interp ist cse0.(n) +| ValBlk (n, args) -> + let (ids, e) = cse1.(n) in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist e +| ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> + anomaly (str "Unexpected value shape") + +and interp_with ist e cse def = match e with +| ValOpn (kn, args) -> + let br = try Some (KNmap.find kn cse) with Not_found -> None in + begin match br with + | None -> + let (self, def) = def in + let ist = push_name ist self e in + interp ist def + | Some (self, ids, p) -> + let ist = push_name ist self e in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist p + end +| ValInt _ | ValBlk _ | ValExt _ | ValStr _ | ValCls _ -> + anomaly (str "Unexpected value shape") + +and interp_proj ist e p = match e with +| ValBlk (_, args) -> + return args.(p) +| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> + anomaly (str "Unexpected value shape") + +and interp_set ist e p r = match e with +| ValBlk (_, args) -> + let () = args.(p) <- r in + return (ValInt 0) +| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> + anomaly (str "Unexpected value shape") diff --git a/src/tac2interp.mli b/src/tac2interp.mli new file mode 100644 index 0000000000..bf6b2d4dde --- /dev/null +++ b/src/tac2interp.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glb_tacexpr -> valexpr Proofview.tactic + +val interp_app : valexpr -> valexpr list -> valexpr Proofview.tactic + +(** {5 Exceptions} *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) + +val val_exn : Exninfo.iexn Geninterp.Val.typ +(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] + should be put into a value with tag [val_exn]. *) diff --git a/src/tac2print.ml b/src/tac2print.ml new file mode 100644 index 0000000000..e6f0582e3d --- /dev/null +++ b/src/tac2print.ml @@ -0,0 +1,296 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* str "'" ++ str (pr n) + | GTypRef (kn, []) -> pr_typref kn + | GTypRef (kn, [t]) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (pr_glbtype lvl t ++ spc () ++ pr_typref kn) + | GTypRef (kn, tl) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) + | GTypArrow (t1, t2) -> + let paren = match lvl with + | T5_r -> fun x -> x + | T5_l | T2 | T1 | T0 -> paren + in + paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) + | GTypTuple tl -> + let paren = match lvl with + | T5_r | T5_l -> fun x -> x + | T2 | T1 | T0 -> paren + in + paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) + in + hov 0 (pr_glbtype lvl c) + +let pr_glbtype pr c = pr_glbtype_gen pr T5_r c + +let int_name () = + let vars = ref Int.Map.empty in + fun n -> + if Int.Map.mem n !vars then Int.Map.find n !vars + else + let num = Int.Map.cardinal !vars in + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + let () = vars := Int.Map.add n name !vars in + name + +(** Term printing *) + +let pr_constructor kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstructor kn)) + +let pr_projection kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) + +type exp_level = Tac2expr.exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +let pr_atom = function +| AtmInt n -> int n +| AtmStr s -> qstring s + +let pr_name = function +| Name id -> Id.print id +| Anonymous -> str "_" + +let find_constructor n empty def = + let rec find n = function + | [] -> assert false + | (id, []) :: rem -> + if empty then + if Int.equal n 0 then id + else find (pred n) rem + else find n rem + | (id, _ :: _) :: rem -> + if not empty then + if Int.equal n 0 then id + else find (pred n) rem + else find n rem + in + find n def + +let order_branches cbr nbr def = + let rec order cidx nidx def = match def with + | [] -> [] + | (id, []) :: rem -> + let ans = order (succ cidx) nidx rem in + (id, [], cbr.(cidx)) :: ans + | (id, _ :: _) :: rem -> + let ans = order cidx (succ nidx) rem in + let (vars, e) = nbr.(nidx) in + (id, Array.to_list vars, e) :: ans + in + order 0 0 def + +let pr_glbexpr_gen lvl c = + let rec pr_glbexpr lvl = function + | GTacAtm atm -> pr_atom atm + | GTacVar id -> Id.print id + | GTacRef gr -> + let qid = shortest_qualid_of_ltac (TacConstant gr) in + Libnames.pr_qualid qid + | GTacFun (nas, c) -> + let nas = pr_sequence pr_name nas in + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + paren (str "fun" ++ spc () ++ nas ++ spc () ++ str "=>" ++ spc () ++ + hov 0 (pr_glbexpr E5 c)) + | GTacApp (c, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) + | GTacLet (mut, bnd, e) -> + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + let mut = if mut then str "rec" ++ spc () else mt () in + let pr_bnd (na, e) = + pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () + in + let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in + paren (str "let" ++ spc () ++ mut ++ bnd ++ str "in" ++ spc () ++ pr_glbexpr E5 e) + | GTacCst (GCaseTuple _, _, cl) -> + let paren = match lvl with + | E0 | E1 -> paren + | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) + | GTacArr cl -> + mt () (** FIXME when implemented *) + | GTacCst (GCaseAlg tpe, n, cl) -> + begin match Tac2env.interp_type tpe with + | _, GTydAlg def -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let id = find_constructor n (List.is_empty cl) def in + let kn = change_kn_label tpe id in + let cl = match cl with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl + in + paren (pr_constructor kn ++ cl) + | _, GTydRec def -> + let args = List.combine def cl in + let pr_arg ((id, _, _), arg) = + let kn = change_kn_label tpe id in + pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg + in + let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in + str "{" ++ spc () ++ args ++ spc () ++ str "}" + | _, (GTydDef _ | GTydOpn) -> assert false + end + | GTacCse (e, info, cst_br, ncst_br) -> + let e = pr_glbexpr E5 e in + let br = match info with + | GCaseAlg kn -> + let def = match Tac2env.interp_type kn with + | _, GTydAlg def -> def + | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false + in + let br = order_branches cst_br ncst_br def in + let pr_branch (cstr, vars, p) = + let cstr = change_kn_label kn cstr in + let cstr = pr_constructor cstr in + let vars = match vars with + | [] -> mt () + | _ -> spc () ++ pr_sequence pr_name vars + in + hov 0 (str "|" ++ spc () ++ cstr ++ vars ++ spc () ++ str "=>" ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + prlist pr_branch br + | GCaseTuple n -> + let (vars, p) = ncst_br.(0) in + let p = pr_glbexpr E5 p in + let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in + str "|" ++ spc () ++ paren vars ++ spc () ++ str "=>" ++ spc () ++ p + in + hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") + | GTacWth wth -> + let e = pr_glbexpr E5 wth.opn_match in + let pr_pattern c self vars p = + let self = match self with + | Anonymous -> mt () + | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id + in + hov 0 (str "|" ++ spc () ++ c ++ vars ++ self ++ spc () ++ str "=>" ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + let pr_branch (cstr, (self, vars, p)) = + let cstr = pr_constructor cstr in + let vars = match Array.to_list vars with + | [] -> mt () + | vars -> spc () ++ pr_sequence pr_name vars + in + pr_pattern cstr self vars p + in + let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in + let (def_as, def_p) = wth.opn_default in + let def = pr_pattern (str "_") def_as (mt ()) def_p in + let br = br ++ def in + hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") + | GTacPrj (kn, e, n) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + e ++ str "." ++ paren proj + | GTacSet (kn, e, n, r) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + let r = pr_glbexpr E1 r in + e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r + | GTacOpn (kn, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let c = pr_constructor kn in + paren (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) + | GTacExt arg -> + let GenArg (Glbwit tag, arg) = arg in + let name = match tag with + | ExtraArg tag -> ArgT.repr tag + | _ -> assert false + in + str name ++ str ":" ++ paren (Genprint.glb_print tag arg) + | GTacPrm (prm, args) -> + let args = match args with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args + in + str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ + qstring prm.mltac_tactic ++ args + in + hov 0 (pr_glbexpr lvl c) + +let pr_glbexpr c = + pr_glbexpr_gen E5 c diff --git a/src/tac2print.mli b/src/tac2print.mli new file mode 100644 index 0000000000..ddd599641d --- /dev/null +++ b/src/tac2print.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds +val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> std_ppcmds +val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> std_ppcmds + +(** {5 Printing expressions} *) + +val pr_constructor : ltac_constructor -> std_ppcmds +val pr_projection : ltac_projection -> std_ppcmds +val pr_glbexpr_gen : exp_level -> glb_tacexpr -> std_ppcmds +val pr_glbexpr : glb_tacexpr -> std_ppcmds + +(** {5 Utilities} *) + +val int_name : unit -> (int -> string) +(** Create a function that give names to integers. The names are generated on + the fly, in the order they are encountered. *) diff --git a/tac2core.ml b/tac2core.ml deleted file mode 100644 index c82893efc2..0000000000 --- a/tac2core.ml +++ /dev/null @@ -1,646 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -| _ -> assert false - -let val_constr = val_tag (topwit Stdarg.wit_constr) -let val_ident = val_tag (topwit Stdarg.wit_ident) -let val_pp = Val.create "ltac2:pp" - -let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = -match Val.eq tag tag' with -| None -> assert false -| Some Refl -> v - -module Core = -struct - -let t_int = coq_core "int" -let t_string = coq_core "string" -let t_array = coq_core "array" -let t_unit = coq_core "unit" -let t_list = coq_core "list" -let t_constr = coq_core "constr" -let t_ident = coq_core "ident" -let t_option = coq_core "option" - -let c_nil = coq_core "[]" -let c_cons = coq_core "::" - -let c_none = coq_core "None" -let c_some = coq_core "Some" - -end - -open Core - -let v_unit = ValInt 0 -let v_nil = ValInt 0 -let v_cons v vl = ValBlk (0, [|v; vl|]) - -module Value = -struct - -let of_unit () = v_unit - -let to_unit = function -| ValInt 0 -> () -| _ -> assert false - -let of_int n = ValInt n -let to_int = function -| ValInt n -> n -| _ -> assert false - -let of_bool b = if b then ValInt 0 else ValInt 1 - -let to_bool = function -| ValInt 0 -> true -| ValInt 1 -> false -| _ -> assert false - -let of_char n = ValInt (Char.code n) -let to_char = function -| ValInt n -> Char.chr n -| _ -> assert false - -let of_string s = ValStr s -let to_string = function -| ValStr s -> s -| _ -> assert false - -let rec of_list = function -| [] -> v_nil -| x :: l -> v_cons x (of_list l) - -let rec to_list = function -| ValInt 0 -> [] -| ValBlk (0, [|v; vl|]) -> v :: to_list vl -| _ -> assert false - -let of_ext tag c = - ValExt (Val.Dyn (tag, c)) - -let to_ext tag = function -| ValExt e -> extract_val tag e -| _ -> assert false - -let of_constr c = of_ext val_constr c -let to_constr c = to_ext val_constr c - -let of_ident c = of_ext val_ident c -let to_ident c = to_ext val_ident c - -(** FIXME: handle backtrace in Ltac2 exceptions *) -let of_exn c = match fst c with -| LtacError (kn, c) -> ValOpn (kn, c) -| _ -> of_ext val_exn c - -let to_exn c = match c with -| ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) -| _ -> to_ext val_exn c - -let of_pp c = of_ext val_pp c -let to_pp c = to_ext val_pp c - -end - -let val_valexpr = Val.create "ltac2:valexpr" - -(** Stdlib exceptions *) - -let err_notfocussed = - LtacError (coq_core "Not_focussed", [||]) - -let err_outofbounds = - LtacError (coq_core "Out_of_bounds", [||]) - -let err_notfound = - LtacError (coq_core "Not_found", [||]) - -(** Helper functions *) - -let thaw f = interp_app f [v_unit] -let throw e = Proofview.tclLIFT (Proofview.NonLogical.raise e) - -let return x = Proofview.tclUNIT x -let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } - -let wrap f = - return () >>= fun () -> return (f ()) - -let wrap_unit f = - return () >>= fun () -> f (); return v_unit - -let pf_apply f = - Proofview.Goal.goals >>= function - | [] -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - f env sigma - | [gl] -> - gl >>= fun gl -> - f (Proofview.Goal.env gl) (Tacmach.New.project gl) - | _ :: _ :: _ -> - throw err_notfocussed - -(** Primitives *) - -(** Printing *) - -let prm_print : ml_tactic = function -| [pp] -> wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) -| _ -> assert false - -let prm_message_of_int : ml_tactic = function -| [ValInt s] -> return (ValExt (Val.Dyn (val_pp, int s))) -| _ -> assert false - -let prm_message_of_string : ml_tactic = function -| [ValStr s] -> return (ValExt (Val.Dyn (val_pp, str (Bytes.to_string s)))) -| _ -> assert false - -let prm_message_of_constr : ml_tactic = function -| [c] -> - pf_apply begin fun env sigma -> - let c = Value.to_constr c in - let pp = Printer.pr_econstr_env env sigma c in - return (ValExt (Val.Dyn (val_pp, pp))) - end -| _ -> assert false - -let prm_message_concat : ml_tactic = function -| [m1; m2] -> - let m1 = Value.to_pp m1 in - let m2 = Value.to_pp m2 in - return (Value.of_pp (Pp.app m1 m2)) -| _ -> assert false - -(** Array *) - -let prm_array_make : ml_tactic = function -| [ValInt n; x] -> - if n < 0 || n > Sys.max_array_length then throw err_outofbounds - else wrap (fun () -> ValBlk (0, Array.make n x)) -| _ -> assert false - -let prm_array_length : ml_tactic = function -| [ValBlk (_, v)] -> return (ValInt (Array.length v)) -| _ -> assert false - -let prm_array_set : ml_tactic = function -| [ValBlk (_, v); ValInt n; x] -> - if n < 0 || n >= Array.length v then throw err_outofbounds - else wrap_unit (fun () -> v.(n) <- x) -| _ -> assert false - -let prm_array_get : ml_tactic = function -| [ValBlk (_, v); ValInt n] -> - if n < 0 || n >= Array.length v then throw err_outofbounds - else wrap (fun () -> v.(n)) -| _ -> assert false - -(** Int *) - -let prm_int_equal : ml_tactic = function -| [m; n] -> - return (Value.of_bool (Value.to_int m == Value.to_int n)) -| _ -> assert false - -let binop f : ml_tactic = function -| [m; n] -> return (Value.of_int (f (Value.to_int m) (Value.to_int n))) -| _ -> assert false - -let prm_int_compare args = binop Int.compare args -let prm_int_add args = binop (+) args -let prm_int_sub args = binop (-) args -let prm_int_mul args = binop ( * ) args - -let prm_int_neg : ml_tactic = function -| [m] -> return (Value.of_int (~- (Value.to_int m))) -| _ -> assert false - -(** String *) - -let prm_string_make : ml_tactic = function -| [n; c] -> - let n = Value.to_int n in - let c = Value.to_char c in - if n < 0 || n > Sys.max_string_length then throw err_outofbounds - else wrap (fun () -> Value.of_string (Bytes.make n c)) -| _ -> assert false - -let prm_string_length : ml_tactic = function -| [s] -> - return (Value.of_int (Bytes.length (Value.to_string s))) -| _ -> assert false - -let prm_string_set : ml_tactic = function -| [s; n; c] -> - let s = Value.to_string s in - let n = Value.to_int n in - let c = Value.to_char c in - if n < 0 || n >= Bytes.length s then throw err_outofbounds - else wrap_unit (fun () -> Bytes.set s n c) -| _ -> assert false - -let prm_string_get : ml_tactic = function -| [s; n] -> - let s = Value.to_string s in - let n = Value.to_int n in - if n < 0 || n >= Bytes.length s then throw err_outofbounds - else wrap (fun () -> Value.of_char (Bytes.get s n)) -| _ -> assert false - -(** Terms *) - -(** constr -> constr *) -let prm_constr_type : ml_tactic = function -| [c] -> - let c = Value.to_constr c in - let get_type env sigma = - Proofview.V82.wrap_exceptions begin fun () -> - let (sigma, t) = Typing.type_of env sigma c in - let t = Value.of_constr t in - Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t - end in - pf_apply get_type -| _ -> assert false - -(** constr -> constr *) -let prm_constr_equal : ml_tactic = function -| [c1; c2] -> - let c1 = Value.to_constr c1 in - let c2 = Value.to_constr c2 in - Proofview.tclEVARMAP >>= fun sigma -> - let b = EConstr.eq_constr sigma c1 c2 in - Proofview.tclUNIT (Value.of_bool b) -| _ -> assert false - -(** Error *) - -let prm_throw : ml_tactic = function -| [e] -> - let (e, info) = Value.to_exn e in - Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) -| _ -> assert false - -(** Control *) - -(** exn -> 'a *) -let prm_zero : ml_tactic = function -| [e] -> - let (e, info) = Value.to_exn e in - Proofview.tclZERO ~info e -| _ -> assert false - -(** exn -> 'a *) -let prm_plus : ml_tactic = function -| [x; k] -> - Proofview.tclOR (thaw x) (fun e -> interp_app k [Value.of_exn e]) -| _ -> assert false - -(** (unit -> 'a) -> 'a *) -let prm_once : ml_tactic = function -| [f] -> Proofview.tclONCE (thaw f) -| _ -> assert false - -(** (unit -> unit) list -> unit *) -let prm_dispatch : ml_tactic = function -| [l] -> - let l = Value.to_list l in - let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in - Proofview.tclDISPATCH l >>= fun () -> return v_unit -| _ -> assert false - -(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let prm_extend : ml_tactic = function -| [lft; tac; rgt] -> - let lft = Value.to_list lft in - let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in - let tac = Proofview.tclIGNORE (thaw tac) in - let rgt = Value.to_list rgt in - let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in - Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit -| _ -> assert false - -(** (unit -> unit) -> unit *) -let prm_enter : ml_tactic = function -| [f] -> - let f = Proofview.tclIGNORE (thaw f) in - Proofview.tclINDEPENDENT f >>= fun () -> return v_unit -| _ -> assert false - -(** int -> int -> (unit -> 'a) -> 'a *) -let prm_focus : ml_tactic = function -| [i; j; tac] -> - let i = Value.to_int i in - let j = Value.to_int j in - Proofview.tclFOCUS i j (thaw tac) -| _ -> assert false - -(** unit -> unit *) -let prm_shelve : ml_tactic = function -| [_] -> Proofview.shelve >>= fun () -> return v_unit -| _ -> assert false - -(** unit -> unit *) -let prm_shelve_unifiable : ml_tactic = function -| [_] -> Proofview.shelve_unifiable >>= fun () -> return v_unit -| _ -> assert false - -let prm_new_goal : ml_tactic = function -| [ev] -> - let ev = Evar.unsafe_of_int (Value.to_int ev) in - Proofview.tclEVARMAP >>= fun sigma -> - if Evd.mem sigma ev then - Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit - else throw err_notfound -| _ -> assert false - -(** unit -> constr *) -let prm_goal : ml_tactic = function -| [_] -> - Proofview.Goal.enter_one { enter = fun gl -> - let concl = Tacmach.New.pf_nf_concl gl in - return (Value.of_constr concl) - } -| _ -> assert false - -(** ident -> constr *) -let prm_hyp : ml_tactic = function -| [id] -> - let id = Value.to_ident id in - pf_apply begin fun env _ -> - let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in - if mem then return (Value.of_constr (EConstr.mkVar id)) - else Tacticals.New.tclZEROMSG - (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (** FIXME: Do something more sensible *) - end -| _ -> assert false - -(** (unit -> constr) -> unit *) -let prm_refine : ml_tactic = function -| [c] -> - let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in - Proofview.Goal.nf_enter { enter = fun gl -> - Refine.generic_refine ~unsafe:false c gl - } >>= fun () -> return v_unit -| _ -> assert false - - -(** Registering *) - -let () = Tac2env.define_primitive (pname "print") prm_print -let () = Tac2env.define_primitive (pname "message_of_string") prm_message_of_string -let () = Tac2env.define_primitive (pname "message_of_int") prm_message_of_int -let () = Tac2env.define_primitive (pname "message_of_constr") prm_message_of_constr -let () = Tac2env.define_primitive (pname "message_concat") prm_message_concat - -let () = Tac2env.define_primitive (pname "array_make") prm_array_make -let () = Tac2env.define_primitive (pname "array_length") prm_array_length -let () = Tac2env.define_primitive (pname "array_get") prm_array_get -let () = Tac2env.define_primitive (pname "array_set") prm_array_set - -let () = Tac2env.define_primitive (pname "string_make") prm_string_make -let () = Tac2env.define_primitive (pname "string_length") prm_string_length -let () = Tac2env.define_primitive (pname "string_get") prm_string_get -let () = Tac2env.define_primitive (pname "string_set") prm_string_set - -let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type -let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal - -let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal -let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare -let () = Tac2env.define_primitive (pname "int_neg") prm_int_neg -let () = Tac2env.define_primitive (pname "int_add") prm_int_add -let () = Tac2env.define_primitive (pname "int_sub") prm_int_sub -let () = Tac2env.define_primitive (pname "int_mul") prm_int_mul - -let () = Tac2env.define_primitive (pname "throw") prm_throw - -let () = Tac2env.define_primitive (pname "zero") prm_zero -let () = Tac2env.define_primitive (pname "plus") prm_plus -let () = Tac2env.define_primitive (pname "once") prm_once -let () = Tac2env.define_primitive (pname "dispatch") prm_dispatch -let () = Tac2env.define_primitive (pname "extend") prm_extend -let () = Tac2env.define_primitive (pname "enter") prm_enter - -let () = Tac2env.define_primitive (pname "focus") prm_focus -let () = Tac2env.define_primitive (pname "shelve") prm_shelve -let () = Tac2env.define_primitive (pname "shelve_unifiable") prm_shelve_unifiable -let () = Tac2env.define_primitive (pname "new_goal") prm_new_goal -let () = Tac2env.define_primitive (pname "goal") prm_goal -let () = Tac2env.define_primitive (pname "hyp") prm_hyp -let () = Tac2env.define_primitive (pname "refine") prm_refine - -(** ML types *) - -let constr_flags () = - let open Pretyping in - { - use_typeclasses = true; - solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); - fail_evar = true; - expand_evars = true - } - -let open_constr_no_classes_flags () = - let open Pretyping in - { - use_typeclasses = false; - solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); - fail_evar = false; - expand_evars = true - } - -(** Embed all Ltac2 data into Values *) -let to_lvar ist = - let open Pretyping in - let map e = Val.Dyn (val_valexpr, e) in - let lfun = Id.Map.map map ist in - { empty_lvar with ltac_genargs = lfun } - -let interp_constr flags ist (c, _) = - let open Pretyping in - pf_apply begin fun env sigma -> - Proofview.V82.wrap_exceptions begin fun () -> - let ist = to_lvar ist in - let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = Val.Dyn (val_constr, c) in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT c - end - end - -let () = - let interp ist c = interp_constr (constr_flags ()) ist c in - let obj = { - ml_type = t_constr; - ml_interp = interp; - } in - define_ml_object Stdarg.wit_constr obj - -let () = - let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in - let obj = { - ml_type = t_constr; - ml_interp = interp; - } in - define_ml_object Stdarg.wit_open_constr obj - -let () = - let interp _ id = return (Val.Dyn (val_ident, id)) in - let obj = { - ml_type = t_ident; - ml_interp = interp; - } in - define_ml_object Stdarg.wit_ident obj - -let () = - let interp ist env sigma concl tac = - let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = - match Val.eq tag val_valexpr with - | None -> accu - | Some Refl -> Id.Map.add id v accu - in - let ist = Id.Map.fold fold ist Id.Map.empty in - let tac = Proofview.tclIGNORE (interp ist tac) in - let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in - (EConstr.of_constr c, sigma) - in - Pretyping.register_constr_interp0 wit_ltac2 interp - -(** Built-in notation scopes *) - -let add_scope s f = - Tac2entries.register_scope (Id.of_string s) f - -let scope_fail () = CErrors.user_err (str "Invalid parsing token") - -let rthunk e = - let loc = Tac2intern.loc_of_tacexpr e in - let var = [(loc, Anonymous), Some (CTypRef (loc, AbsKn Core.t_unit, []))] in - CTacFun (loc, var, e) - -let add_generic_scope s entry arg = - let parse = function - | [] -> - let scope = Extend.Aentry entry in - let act x = rthunk (CTacExt (Loc.ghost, in_gen (rawwit arg) x)) in - Tac2entries.ScopeRule (scope, act) - | _ -> scope_fail () - in - add_scope s parse - -let () = add_scope "list0" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist0 scope in - let act l = - let l = List.map act l in - CTacLst (Loc.ghost, l) - in - Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr (_, str)] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist0sep (scope, sep) in - let act l = - let l = List.map act l in - CTacLst (Loc.ghost, l) - in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "list1" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist1 scope in - let act l = - let l = List.map act l in - CTacLst (Loc.ghost, l) - in - Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr (_, str)] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist1sep (scope, sep) in - let act l = - let l = List.map act l in - CTacLst (Loc.ghost, l) - in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "opt" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Aopt scope in - let act opt = match opt with - | None -> - CTacRef (AbsKn (TacConstructor Core.c_none)) - | Some x -> - CTacApp (Loc.ghost, CTacRef (AbsKn (TacConstructor Core.c_some)), [act x]) - in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "self" begin function -| [] -> - let scope = Extend.Aself in - let act tac = rthunk tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "next" begin function -| [] -> - let scope = Extend.Anext in - let act tac = rthunk tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "tactic" begin function -| [] -> - (** Default to level 5 parsing *) - let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, 5) in - let act tac = rthunk tac in - Tac2entries.ScopeRule (scope, act) -| [SexprInt (loc, n)] -> - let () = if n < 0 || n > 5 then scope_fail () in - let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, n) in - let act tac = rthunk tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_generic_scope "ident" Pcoq.Prim.ident Stdarg.wit_ident -let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr diff --git a/tac2core.mli b/tac2core.mli deleted file mode 100644 index fc90499ac6..0000000000 --- a/tac2core.mli +++ /dev/null @@ -1,62 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* valexpr -val to_unit : valexpr -> unit - -val of_int : int -> valexpr -val to_int : valexpr -> int - -val of_bool : bool -> valexpr -val to_bool : valexpr -> bool - -val of_char : char -> valexpr -val to_char : valexpr -> char - -val of_list : valexpr list -> valexpr -val to_list : valexpr -> valexpr list - -val of_constr : EConstr.t -> valexpr -val to_constr : valexpr -> EConstr.t - -val of_exn : Exninfo.iexn -> valexpr -val to_exn : valexpr -> Exninfo.iexn - -val of_ident : Id.t -> valexpr -val to_ident : valexpr -> Id.t - -end diff --git a/tac2entries.ml b/tac2entries.ml deleted file mode 100644 index 3959e705ed..0000000000 --- a/tac2entries.ml +++ /dev/null @@ -1,645 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = - declare_object {(default_object "TAC2-DEFINITION") with - cache_function = cache_tacdef; - load_function = load_tacdef; - open_function = open_tacdef; - subst_function = subst_tacdef; - classify_function = classify_tacdef} - -(** Type definition *) - -type typdef = { - typdef_local : bool; - typdef_expr : glb_quant_typedef; -} - -let change_kn_label kn id = - let (mp, dp, _) = KerName.repr kn in - KerName.make mp dp (Label.of_id id) - -let change_sp_label sp id = - let (dp, _) = Libnames.repr_path sp in - Libnames.make_path dp id - -let push_typedef visibility sp kn (_, def) = match def with -| GTydDef _ -> - Tac2env.push_type visibility sp kn -| GTydAlg cstrs -> - (** Register constructors *) - let iter (c, _) = - let spc = change_sp_label sp c in - let knc = change_kn_label kn c in - Tac2env.push_ltac visibility spc (TacConstructor knc) - in - Tac2env.push_type visibility sp kn; - List.iter iter cstrs -| GTydRec fields -> - (** Register fields *) - let iter (c, _, _) = - let spc = change_sp_label sp c in - let knc = change_kn_label kn c in - Tac2env.push_projection visibility spc knc - in - Tac2env.push_type visibility sp kn; - List.iter iter fields -| GTydOpn -> - Tac2env.push_type visibility sp kn - -let next i = - let ans = !i in - let () = incr i in - ans - -let define_typedef kn (params, def as qdef) = match def with -| GTydDef _ -> - Tac2env.define_type kn qdef -| GTydAlg cstrs -> - (** Define constructors *) - let constant = ref 0 in - let nonconstant = ref 0 in - let iter (c, args) = - let knc = change_kn_label kn c in - let tag = if List.is_empty args then next constant else next nonconstant in - let data = { - Tac2env.cdata_prms = params; - cdata_type = kn; - cdata_args = args; - cdata_indx = Some tag; - } in - Tac2env.define_constructor knc data - in - Tac2env.define_type kn qdef; - List.iter iter cstrs -| GTydRec fs -> - (** Define projections *) - let iter i (id, mut, t) = - let knp = change_kn_label kn id in - let proj = { - Tac2env.pdata_prms = params; - pdata_type = kn; - pdata_ptyp = t; - pdata_mutb = mut; - pdata_indx = i; - } in - Tac2env.define_projection knp proj - in - Tac2env.define_type kn qdef; - List.iteri iter fs -| GTydOpn -> - Tac2env.define_type kn qdef - -let perform_typdef vs ((sp, kn), def) = - let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in - define_typedef kn def.typdef_expr - -let load_typdef i obj = perform_typdef (Until i) obj -let open_typdef i obj = perform_typdef (Exactly i) obj - -let cache_typdef ((sp, kn), def) = - let () = push_typedef (Until 1) sp kn def.typdef_expr in - define_typedef kn def.typdef_expr - -let subst_typdef (subst, def) = - let expr' = subst_quant_typedef subst def.typdef_expr in - if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } - -let classify_typdef o = Substitute o - -let inTypDef : typdef -> obj = - declare_object {(default_object "TAC2-TYPE-DEFINITION") with - cache_function = cache_typdef; - load_function = load_typdef; - open_function = open_typdef; - subst_function = subst_typdef; - classify_function = classify_typdef} - -(** Type extension *) - -type extension_data = { - edata_name : Id.t; - edata_args : int glb_typexpr list; -} - -type typext = { - typext_local : bool; - typext_prms : int; - typext_type : type_constant; - typext_expr : extension_data list; -} - -let push_typext vis sp kn def = - let iter data = - let spc = change_sp_label sp data.edata_name in - let knc = change_kn_label kn data.edata_name in - Tac2env.push_ltac vis spc (TacConstructor knc) - in - List.iter iter def.typext_expr - -let define_typext kn def = - let iter data = - let knc = change_kn_label kn data.edata_name in - let cdata = { - Tac2env.cdata_prms = def.typext_prms; - cdata_type = def.typext_type; - cdata_args = data.edata_args; - cdata_indx = None; - } in - Tac2env.define_constructor knc cdata - in - List.iter iter def.typext_expr - -let cache_typext ((sp, kn), def) = - let () = define_typext kn def in - push_typext (Until 1) sp kn def - -let perform_typext vs ((sp, kn), def) = - let () = if not def.typext_local then push_typext vs sp kn def in - define_typext kn def - -let load_typext i obj = perform_typext (Until i) obj -let open_typext i obj = perform_typext (Exactly i) obj - -let subst_typext (subst, e) = - let open Mod_subst in - let subst_data data = - let edata_args = List.smartmap (fun e -> subst_type subst e) data.edata_args in - if edata_args == data.edata_args then data - else { data with edata_args } - in - let typext_type = subst_kn subst e.typext_type in - let typext_expr = List.smartmap subst_data e.typext_expr in - if typext_type == e.typext_type && typext_expr == e.typext_expr then - e - else - { e with typext_type; typext_expr } - -let classify_typext o = Substitute o - -let inTypExt : typext -> obj = - declare_object {(default_object "TAC2-TYPE-EXTENSION") with - cache_function = cache_typext; - load_function = load_typext; - open_function = open_typext; - subst_function = subst_typext; - classify_function = classify_typext} - -(** Toplevel entries *) - -let register_ltac ?(local = false) isrec tactics = - if isrec then - let map (na, e) = (na, None, e) in - let bindings = List.map map tactics in - let map ((loc, na), e) = match na with - | Anonymous -> None - | Name id -> - let qid = Libnames.qualid_of_ident id in - let e = CTacLet (Loc.ghost, true, bindings, CTacRef (RelId (loc, qid))) in - let (e, t) = intern e in - let e = match e with - | GTacLet (true, _, e) -> assert false - | _ -> assert false - in - Some (e, t) - in - let tactics = List.map map tactics in - assert false (** FIXME *) - else - let map ((loc, na), e) = - let (e, t) = intern e in - let () = - if not (is_value e) then - user_err ~loc (str "Tactic definition must be a syntactical value") - in - let id = match na with - | Anonymous -> - user_err ~loc (str "Tactic definition must have a name") - | Name id -> id - in - let kn = Lib.make_kn id in - let exists = - try let _ = Tac2env.interp_global kn in true with Not_found -> false - in - let () = - if exists then - user_err ~loc (str "Tactic " ++ Nameops.pr_id id ++ str " already exists") - in - (id, e, t) - in - let defs = List.map map tactics in - let iter (id, e, t) = - let def = { - tacdef_local = local; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) - in - List.iter iter defs - -let qualid_to_ident (loc, qid) = - let (dp, id) = Libnames.repr_qualid qid in - if DirPath.is_empty dp then (loc, id) - else user_err ~loc (str "Identifier expected") - -let register_typedef ?(local = false) isrec types = - let same_name ((_, id1), _) ((_, id2), _) = Id.equal id1 id2 in - let () = match List.duplicates same_name types with - | [] -> () - | ((loc, id), _) :: _ -> - user_err ~loc (str "Multiple definition of the type name " ++ Id.print id) - in - let check ((loc, id), (params, def)) = - let same_name (_, id1) (_, id2) = Id.equal id1 id2 in - let () = match List.duplicates same_name params with - | [] -> () - | (loc, id) :: _ -> - user_err ~loc (str "The type parameter " ++ Id.print id ++ - str " occurs several times") - in - match def with - | CTydDef _ -> - if isrec then - user_err ~loc (str "The type abbreviation " ++ Id.print id ++ - str " cannot be recursive") - | CTydAlg cs -> - let same_name (id1, _) (id2, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name cs with - | [] -> () - | (id, _) :: _ -> - user_err (str "Multiple definitions of the constructor " ++ Id.print id) - in - () - | CTydRec ps -> - let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name ps with - | [] -> () - | (id, _, _) :: _ -> - user_err (str "Multiple definitions of the projection " ++ Id.print id) - in - () - | CTydOpn -> - if isrec then - user_err ~loc (str "The open type declaration " ++ Id.print id ++ - str " cannot be recursive") - in - let () = List.iter check types in - let self = - if isrec then - let fold accu ((_, id), (params, _)) = - Id.Map.add id (Lib.make_kn id, List.length params) accu - in - List.fold_left fold Id.Map.empty types - else Id.Map.empty - in - let map ((_, id), def) = - let typdef = { - typdef_local = local; - typdef_expr = intern_typedef self def; - } in - (id, typdef) - in - let types = List.map map types in - let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in - List.iter iter types - -let register_primitive ?(local = false) (loc, id) t ml = - let t = intern_open_type t in - let rec count_arrow = function - | GTypArrow (_, t) -> 1 + count_arrow t - | _ -> 0 - in - let arrows = count_arrow (snd t) in - let () = if Int.equal arrows 0 then - user_err ~loc (str "External tactic must have at least one argument") in - let () = - try let _ = Tac2env.interp_primitive ml in () with Not_found -> - user_err ~loc (str "Unregistered primitive " ++ - quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) - in - let init i = Id.of_string (Printf.sprintf "x%i" i) in - let names = List.init arrows init in - let bnd = List.map (fun id -> Name id) names in - let arg = List.map (fun id -> GTacVar id) names in - let e = GTacFun (bnd, GTacPrm (ml, arg)) in - let def = { - tacdef_local = local; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) - -let register_open ?(local = false) (loc, qid) (params, def) = - let kn = - try Tac2env.locate_type qid - with Not_found -> - user_err ~loc (str "Unbound type " ++ pr_qualid qid) - in - let (tparams, t) = Tac2env.interp_type kn in - let () = match t with - | GTydOpn -> () - | GTydAlg _ | GTydRec _ | GTydDef _ -> - user_err ~loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") - in - let () = - if not (Int.equal (List.length params) tparams) then - Tac2intern.error_nparams_mismatch loc (List.length params) tparams - in - match def with - | CTydOpn -> () - | CTydAlg def -> - let intern_type t = - let tpe = CTydDef (Some t) in - let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in - match ans with - | GTydDef (Some t) -> t - | _ -> assert false - in - let map (id, tpe) = - let tpe = List.map intern_type tpe in - { edata_name = id; edata_args = tpe } - in - let def = List.map map def in - let def = { - typext_local = local; - typext_type = kn; - typext_prms = tparams; - typext_expr = def; - } in - Lib.add_anonymous_leaf (inTypExt def) - | CTydRec _ | CTydDef _ -> - user_err ~loc (str "Extensions only accept inductive constructors") - -let register_type ?local isrec types = match types with -| [qid, true, def] -> - let (loc, _) = qid in - let () = if isrec then user_err ~loc (str "Extensions cannot be recursive") in - register_open ?local qid def -| _ -> - let map (qid, redef, def) = - let (loc, _) = qid in - let () = if redef then - user_err ~loc (str "Types can only be extended one by one") - in - (qualid_to_ident qid, def) - in - let types = List.map map types in - register_typedef ?local isrec types - -(** Parsing *) - -type 'a token = -| TacTerm of string -| TacNonTerm of Name.t * 'a - -type scope_rule = -| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule - -type scope_interpretation = sexpr list -> scope_rule - -let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty - -let register_scope id s = - scope_table := Id.Map.add id s !scope_table - -module ParseToken = -struct - -let loc_of_token = function -| SexprStr (loc, _) -> loc -| SexprInt (loc, _) -> loc -| SexprRec (loc, _, _) -> loc - -let parse_scope = function -| SexprRec (_, (loc, Some id), toks) -> - if Id.Map.mem id !scope_table then - Id.Map.find id !scope_table toks - else - CErrors.user_err ~loc (str "Unknown scope" ++ spc () ++ Nameops.pr_id id) -| tok -> - let loc = loc_of_token tok in - CErrors.user_err ~loc (str "Invalid parsing token") - -let parse_token = function -| SexprStr (_, s) -> TacTerm s -| SexprRec (_, (_, na), [tok]) -> - let na = match na with None -> Anonymous | Some id -> Name id in - let scope = parse_scope tok in - TacNonTerm (na, scope) -| tok -> - let loc = loc_of_token tok in - CErrors.user_err ~loc (str "Invalid parsing token") - -end - -let parse_scope = ParseToken.parse_scope - -type synext = { - synext_tok : sexpr list; - synext_exp : raw_tacexpr; - synext_lev : int option; - synext_loc : bool; -} - -type krule = -| KRule : - (raw_tacexpr, 'act, Loc.t -> raw_tacexpr) Extend.rule * - ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule - -let rec get_rule (tok : scope_rule token list) : krule = match tok with -| [] -> KRule (Extend.Stop, fun k loc -> k loc []) -| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> - let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, scope) in - let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in - KRule (rule, act) -| TacTerm t :: tok -> - let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in - let act k _ = act k in - KRule (rule, act) - -let perform_notation syn st = - let tok = List.rev_map ParseToken.parse_token syn.synext_tok in - let KRule (rule, act) = get_rule tok in - let mk loc args = - let map (na, e) = - let loc = loc_of_tacexpr e in - ((loc, na), None, e) - in - let bnd = List.map map args in - CTacLet (loc, false, bnd, syn.synext_exp) - in - let rule = Extend.Rule (rule, act mk) in - let lev = match syn.synext_lev with - | None -> None - | Some lev -> Some (string_of_int lev) - in - let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) - -let ltac2_notation = - Pcoq.create_grammar_command "ltac2-notation" perform_notation - -let cache_synext (_, syn) = - Pcoq.extend_grammar_command ltac2_notation syn - -let open_synext i (_, syn) = - if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn - -let subst_synext (subst, syn) = - let e = Tac2intern.subst_rawexpr subst syn.synext_exp in - if e == syn.synext_exp then syn else { syn with synext_exp = e } - -let classify_synext o = - if o.synext_loc then Dispose else Substitute o - -let inTac2Notation : synext -> obj = - declare_object {(default_object "TAC2-NOTATION") with - cache_function = cache_synext; - open_function = open_synext; - subst_function = subst_synext; - classify_function = classify_synext} - -let register_notation ?(local = false) tkn lev body = - (** Check that the tokens make sense *) - let entries = List.map ParseToken.parse_token tkn in - let fold accu tok = match tok with - | TacTerm _ -> accu - | TacNonTerm (Name id, _) -> Id.Set.add id accu - | TacNonTerm (Anonymous, _) -> accu - in - let ids = List.fold_left fold Id.Set.empty entries in - (** Globalize so that names are absolute *) - let body = Tac2intern.globalize ids body in - let ext = { - synext_tok = tkn; - synext_exp = body; - synext_lev = lev; - synext_loc = local; - } in - Lib.add_anonymous_leaf (inTac2Notation ext) - -(** Toplevel entries *) - -let register_struct ?local str = match str with -| StrVal (isrec, e) -> register_ltac ?local isrec e -| StrTyp (isrec, t) -> register_type ?local isrec t -| StrPrm (id, t, ml) -> register_primitive ?local id t ml -| StrSyn (tok, lev, e) -> register_notation ?local tok lev e - -(** Printing *) - -let print_ltac ref = - let (loc, qid) = qualid_of_reference ref in - let kn = - try Tac2env.locate_ltac qid - with Not_found -> user_err ~loc (str "Unknown tactic " ++ pr_qualid qid) - in - match kn with - | TacConstant kn -> - let (e, _, (_, t)) = Tac2env.interp_global kn in - let name = int_name () in - Feedback.msg_notice ( - hov 0 ( - hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ - hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) - ) - ) - | TacConstructor kn -> - let _ = Tac2env.interp_constructor kn in - Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) - -(** Calling tactics *) - -let solve default tac = - let status = Proof_global.with_current_proof begin fun etac p -> - let with_end_tac = if default then Some etac else None in - let (p, status) = Pfedit.solve SelectAll None tac ?with_end_tac p in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p, status - end in - if not status then Feedback.feedback Feedback.AddedAxiom - -let call ~default e = - let loc = loc_of_tacexpr e in - let (e, (_, t)) = intern e in - let () = check_unit ~loc t in - let tac = Tac2interp.interp Id.Map.empty e in - solve default (Proofview.tclIGNORE tac) - -(** Primitive algebraic types than can't be defined Coq-side *) - -let register_prim_alg name params def = - let id = Id.of_string name in - let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in - let def = (params, GTydAlg def) in - let def = { typdef_local = false; typdef_expr = def } in - ignore (Lib.add_leaf id (inTypDef def)) - -let coq_def n = KerName.make2 Tac2env.coq_prefix (Label.make n) - -let t_list = coq_def "list" - -let _ = Mltop.declare_cache_obj begin fun () -> - register_prim_alg "unit" 0 ["()", []]; - register_prim_alg "list" 1 [ - ("[]", []); - ("::", [GTypVar 0; GTypRef (t_list, [GTypVar 0])]); - ]; -end "ltac2_plugin" diff --git a/tac2entries.mli b/tac2entries.mli deleted file mode 100644 index 71e8150057..0000000000 --- a/tac2entries.mli +++ /dev/null @@ -1,57 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* rec_flag -> - (Name.t located * raw_tacexpr) list -> unit - -val register_type : ?local:bool -> rec_flag -> - (qualid located * redef_flag * raw_quant_typedef) list -> unit - -val register_primitive : ?local:bool -> - Id.t located -> raw_typexpr -> ml_tactic_name -> unit - -val register_struct : ?local:bool -> strexpr -> unit - -val register_notation : ?local:bool -> sexpr list -> int option -> - raw_tacexpr -> unit - -(** {5 Notations} *) - -type scope_rule = -| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule - -type scope_interpretation = sexpr list -> scope_rule - -val register_scope : Id.t -> scope_interpretation -> unit -(** Create a new scope with the provided name *) - -val parse_scope : sexpr -> scope_rule -(** Use this to interpret the subscopes for interpretation functions *) - -(** {5 Inspecting} *) - -val print_ltac : Libnames.reference -> unit - -(** {5 Eval loop} *) - -(** Evaluate a tactic expression in the current environment *) -val call : default:bool -> raw_tacexpr -> unit - -(** {5 Parsing entries} *) - -module Pltac : -sig -val tac2expr : raw_tacexpr Pcoq.Gram.entry -end diff --git a/tac2env.ml b/tac2env.ml deleted file mode 100644 index 5ccdd018ee..0000000000 --- a/tac2env.ml +++ /dev/null @@ -1,242 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ValInt n -| GTacRef kn -> - let (e, _) = - try KNmap.find kn ltac_state.contents.ltac_tactics - with Not_found -> assert false - in - eval_pure e -| GTacFun (na, e) -> - ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e } -| GTacCst (_, n, []) -> ValInt n -| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) -| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_pure el) -| GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ | GTacSet _ -| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> - anomaly (Pp.str "Term is not a syntactical value") - -let define_global kn e = - let state = !ltac_state in - ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } - -let interp_global kn = - let (e, t) = KNmap.find kn ltac_state.contents.ltac_tactics in - (e, eval_pure e, t) - -let define_constructor kn t = - let state = !ltac_state in - ltac_state := { state with ltac_constructors = KNmap.add kn t state.ltac_constructors } - -let interp_constructor kn = KNmap.find kn ltac_state.contents.ltac_constructors - -let define_projection kn t = - let state = !ltac_state in - ltac_state := { state with ltac_projections = KNmap.add kn t state.ltac_projections } - -let interp_projection kn = KNmap.find kn ltac_state.contents.ltac_projections - -let define_type kn e = - let state = !ltac_state in - ltac_state := { state with ltac_types = KNmap.add kn e state.ltac_types } - -let interp_type kn = KNmap.find kn ltac_state.contents.ltac_types - -module ML = -struct - type t = ml_tactic_name - let compare n1 n2 = - let c = String.compare n1.mltac_plugin n2.mltac_plugin in - if Int.equal c 0 then String.compare n1.mltac_tactic n2.mltac_tactic - else c -end - -module MLMap = Map.Make(ML) - -let primitive_map = ref MLMap.empty - -let define_primitive name f = primitive_map := MLMap.add name f !primitive_map -let interp_primitive name = MLMap.find name !primitive_map - -(** Name management *) - -module FullPath = -struct - type t = full_path - let equal = eq_full_path - let to_string = string_of_path - let repr sp = - let dir,id = repr_path sp in - id, (DirPath.repr dir) -end - -type tacref = Tac2expr.tacref = -| TacConstant of ltac_constant -| TacConstructor of ltac_constructor - -module TacRef = -struct -type t = tacref -let equal r1 r2 = match r1, r2 with -| TacConstant c1, TacConstant c2 -> KerName.equal c1 c2 -| TacConstructor c1, TacConstructor c2 -> KerName.equal c1 c2 -| _ -> false -end - -module KnTab = Nametab.Make(FullPath)(KerName) -module RfTab = Nametab.Make(FullPath)(TacRef) - -type nametab = { - tab_ltac : RfTab.t; - tab_ltac_rev : full_path KNmap.t * full_path KNmap.t; - tab_type : KnTab.t; - tab_type_rev : full_path KNmap.t; - tab_proj : KnTab.t; - tab_proj_rev : full_path KNmap.t; -} - -let empty_nametab = { - tab_ltac = RfTab.empty; - tab_ltac_rev = (KNmap.empty, KNmap.empty); - tab_type = KnTab.empty; - tab_type_rev = KNmap.empty; - tab_proj = KnTab.empty; - tab_proj_rev = KNmap.empty; -} - -let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" - -let push_ltac vis sp kn = - let tab = !nametab in - let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in - let (constant_map, constructor_map) = tab.tab_ltac_rev in - let tab_ltac_rev = match kn with - | TacConstant c -> (KNmap.add c sp constant_map, constructor_map) - | TacConstructor c -> (constant_map, KNmap.add c sp constructor_map) - in - nametab := { tab with tab_ltac; tab_ltac_rev } - -let locate_ltac qid = - let tab = !nametab in - RfTab.locate qid tab.tab_ltac - -let locate_extended_all_ltac qid = - let tab = !nametab in - RfTab.find_prefixes qid tab.tab_ltac - -let shortest_qualid_of_ltac kn = - let tab = !nametab in - let sp = match kn with - | TacConstant c -> KNmap.find c (fst tab.tab_ltac_rev) - | TacConstructor c -> KNmap.find c (snd tab.tab_ltac_rev) - in - RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac - -let push_type vis sp kn = - let tab = !nametab in - let tab_type = KnTab.push vis sp kn tab.tab_type in - let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in - nametab := { tab with tab_type; tab_type_rev } - -let locate_type qid = - let tab = !nametab in - KnTab.locate qid tab.tab_type - -let locate_extended_all_type qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_type - -let shortest_qualid_of_type kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_type_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_type - -let push_projection vis sp kn = - let tab = !nametab in - let tab_proj = KnTab.push vis sp kn tab.tab_proj in - let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in - nametab := { tab with tab_proj; tab_proj_rev } - -let locate_projection qid = - let tab = !nametab in - KnTab.locate qid tab.tab_proj - -let locate_extended_all_projection qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_proj - -let shortest_qualid_of_projection kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_proj_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj - -type 'a ml_object = { - ml_type : type_constant; - ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; -} - -module MLTypeObj = -struct - type ('a, 'b, 'c) obj = 'b ml_object - let name = "ltac2_ml_type" - let default _ = None -end - -module MLType = Genarg.Register(MLTypeObj) - -let define_ml_object t tpe = MLType.register0 t tpe -let interp_ml_object t = MLType.obj t - -(** Absolute paths *) - -let coq_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Init"; "ltac2"; "Coq"])) - -(** Generic arguments *) - -let wit_ltac2 = Genarg.make0 "ltac2" diff --git a/tac2env.mli b/tac2env.mli deleted file mode 100644 index c4b8c1e0ca..0000000000 --- a/tac2env.mli +++ /dev/null @@ -1,106 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (glb_tacexpr * type_scheme) -> unit -val interp_global : ltac_constant -> (glb_tacexpr * valexpr * type_scheme) - -(** {5 Toplevel definition of types} *) - -val define_type : type_constant -> glb_quant_typedef -> unit -val interp_type : type_constant -> glb_quant_typedef - -(** {5 Toplevel definition of algebraic constructors} *) - -type constructor_data = { - cdata_prms : int; - (** Type parameters *) - cdata_type : type_constant; - (** Inductive definition to which the constructor pertains *) - cdata_args : int glb_typexpr list; - (** Types of the constructor arguments *) - cdata_indx : int option; - (** Index of the constructor in the ADT. Numbering is duplicated between - argumentless and argument-using constructors, e.g. in type ['a option] - [None] and [Some] have both index 0. This field is empty whenever the - constructor is a member of an open type. *) -} - -val define_constructor : ltac_constructor -> constructor_data -> unit -val interp_constructor : ltac_constructor -> constructor_data - -(** {5 Toplevel definition of projections} *) - -type projection_data = { - pdata_prms : int; - (** Type parameters *) - pdata_type : type_constant; - (** Record definition to which the projection pertains *) - pdata_ptyp : int glb_typexpr; - (** Type of the projection *) - pdata_mutb : bool; - (** Whether the field is mutable *) - pdata_indx : int; - (** Index of the projection *) -} - -val define_projection : ltac_projection -> projection_data -> unit -val interp_projection : ltac_projection -> projection_data - -(** {5 Name management} *) - -val push_ltac : visibility -> full_path -> tacref -> unit -val locate_ltac : qualid -> tacref -val locate_extended_all_ltac : qualid -> tacref list -val shortest_qualid_of_ltac : tacref -> qualid - -val push_type : visibility -> full_path -> type_constant -> unit -val locate_type : qualid -> type_constant -val locate_extended_all_type : qualid -> type_constant list -val shortest_qualid_of_type : type_constant -> qualid - -val push_projection : visibility -> full_path -> ltac_projection -> unit -val locate_projection : qualid -> ltac_projection -val locate_extended_all_projection : qualid -> ltac_projection list -val shortest_qualid_of_projection : ltac_projection -> qualid - -(** {5 Toplevel definitions of ML tactics} *) - -(** This state is not part of the summary, contrarily to the ones above. It is - intended to be used from ML plugins to register ML-side functions. *) - -val define_primitive : ml_tactic_name -> ml_tactic -> unit -val interp_primitive : ml_tactic_name -> ml_tactic - -(** {5 ML primitive types} *) - -type 'a ml_object = { - ml_type : type_constant; - ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; -} - -val define_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object -> unit -val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object - -(** {5 Absolute paths} *) - -val coq_prefix : ModPath.t -(** Path where primitive datatypes are defined in Ltac2 plugin. *) - -(** {5 Generic arguments} *) - -val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type diff --git a/tac2expr.mli b/tac2expr.mli deleted file mode 100644 index acdad9bab4..0000000000 --- a/tac2expr.mli +++ /dev/null @@ -1,195 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* valexpr Proofview.tactic - -type environment = valexpr Id.Map.t diff --git a/tac2intern.ml b/tac2intern.ml deleted file mode 100644 index 756bbe3076..0000000000 --- a/tac2intern.ml +++ /dev/null @@ -1,1452 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* elt -> bool -val create : unit -> 'a t -val fresh : 'a t -> elt -val find : elt -> 'a t -> (elt * 'a option) -val union : elt -> elt -> 'a t -> unit -val set : elt -> 'a -> 'a t -> unit -module Map : -sig - type key = elt - type +'a t - val empty : 'a t - val add : key -> 'a -> 'a t -> 'a t - val mem : key -> 'a t -> bool - val find : key -> 'a t -> 'a - val exists : (key -> 'a -> bool) -> 'a t -> bool -end -end -= -struct -type elt = int -let equal = Int.equal -module Map = Int.Map - -type 'a node = -| Canon of int * 'a option -| Equiv of elt - -type 'a t = { - mutable uf_data : 'a node array; - mutable uf_size : int; -} - -let resize p = - if Int.equal (Array.length p.uf_data) p.uf_size then begin - let nsize = 2 * p.uf_size + 1 in - let v = Array.make nsize (Equiv 0) in - Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); - p.uf_data <- v; - end - -let create () = { uf_data = [||]; uf_size = 0 } - -let fresh p = - resize p; - let n = p.uf_size in - p.uf_data.(n) <- (Canon (1, None)); - p.uf_size <- n + 1; - n - -let rec lookup n p = - let node = Array.get p.uf_data n in - match node with - | Canon (size, v) -> n, size, v - | Equiv y -> - let ((z, _, _) as res) = lookup y p in - if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); - res - -let find n p = - let (x, _, v) = lookup n p in (x, v) - -let union x y p = - let ((x, size1, _) as xcan) = lookup x p in - let ((y, size2, _) as ycan) = lookup y p in - let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in - let x, _, xnode = xcan in - let y, _, ynode = ycan in - assert (Option.is_empty xnode); - assert (Option.is_empty ynode); - p.uf_data.(x) <- Equiv y; - p.uf_data.(y) <- Canon (size1 + size2, None) - -let set x v p = - let (x, s, v') = lookup x p in - assert (Option.is_empty v'); - p.uf_data.(x) <- Canon (s, Some v) - -end - -type mix_var = -| GVar of UF.elt -| LVar of int - -type mix_type_scheme = int * mix_var glb_typexpr - -type environment = { - env_var : mix_type_scheme Id.Map.t; - (** Type schemes of bound variables *) - env_cst : UF.elt glb_typexpr UF.t; - (** Unification state *) - env_als : UF.elt Id.Map.t ref; - (** Map user-facing type variables to unification variables *) - env_opn : bool; - (** Accept unbound type variables *) - env_rec : (KerName.t * int) Id.Map.t; - (** Recursive type definitions *) -} - -let empty_env () = { - env_var = Id.Map.empty; - env_cst = UF.create (); - env_als = ref Id.Map.empty; - env_opn = true; - env_rec = Id.Map.empty; -} - -let env_name env = - (** Generate names according to a provided environment *) - let mk num = - let base = num mod 26 in - let rem = num / 26 in - let name = String.make 1 (Char.chr (97 + base)) in - let suff = if Int.equal rem 0 then "" else string_of_int rem in - let name = name ^ suff in - name - in - let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in - let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in - let vars = ref vars in - let rec fresh n = - let name = mk n in - if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) - else name - in - fun n -> - if UF.Map.mem n !vars then UF.Map.find n !vars - else - let ans = fresh 0 in - let () = vars := UF.Map.add n ans !vars in - ans - -let ltac2_env : environment Genintern.Store.field = - Genintern.Store.field () - -let fresh_id env = UF.fresh env.env_cst - -let get_alias (loc, id) env = - try Id.Map.find id env.env_als.contents - with Not_found -> - if env.env_opn then - let n = fresh_id env in - let () = env.env_als := Id.Map.add id n env.env_als.contents in - n - else user_err ~loc (str "Unbound type parameter " ++ Id.print id) - -let push_name id t env = match id with -| Anonymous -> env -| Name id -> { env with env_var = Id.Map.add id t env.env_var } - -let loc_of_tacexpr = function -| CTacAtm (loc, _) -> loc -| CTacRef (RelId (loc, _)) -> loc -| CTacRef (AbsKn _) -> Loc.ghost -| CTacFun (loc, _, _) -> loc -| CTacApp (loc, _, _) -> loc -| CTacLet (loc, _, _, _) -> loc -| CTacTup (loc, _) -> loc -| CTacArr (loc, _) -> loc -| CTacLst (loc, _) -> loc -| CTacCnv (loc, _, _) -> loc -| CTacSeq (loc, _, _) -> loc -| CTacCse (loc, _, _) -> loc -| CTacRec (loc, _) -> loc -| CTacPrj (loc, _, _) -> loc -| CTacSet (loc, _, _, _) -> loc -| CTacExt (loc, _) -> loc - -let loc_of_patexpr = function -| CPatAny loc -> loc -| CPatRef (loc, _, _) -> loc -| CPatTup (loc, _) -> loc - -let error_nargs_mismatch loc nargs nfound = - user_err ~loc (str "Constructor expects " ++ int nargs ++ - str " arguments, but is applied to " ++ int nfound ++ - str " arguments") - -let error_nparams_mismatch loc nargs nfound = - user_err ~loc (str "Type expects " ++ int nargs ++ - str " arguments, but is applied to " ++ int nfound ++ - str " arguments") - -let rec subst_type subst (t : 'a glb_typexpr) = match t with -| GTypVar id -> subst id -| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) -| GTypTuple tl -> GTypTuple (List.map (fun t -> subst_type subst t) tl) -| GTypRef (qid, args) -> - GTypRef (qid, List.map (fun t -> subst_type subst t) args) - -let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with -| CTypVar (loc, Name id) -> GTypVar (get_alias (loc, id) env) -| CTypVar (_, Anonymous) -> GTypVar (fresh_id env) -| CTypRef (loc, rel, args) -> - let (kn, nparams) = match rel with - | RelId (loc, qid) -> - let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp && Id.Map.mem id env.env_rec then - Id.Map.find id env.env_rec - else - let kn = - try Tac2env.locate_type qid - with Not_found -> - user_err ~loc (str "Unbound type constructor " ++ pr_qualid qid) - in - let (nparams, _) = Tac2env.interp_type kn in - (kn, nparams) - | AbsKn kn -> - let (nparams, _) = Tac2env.interp_type kn in - (kn, nparams) - in - let nargs = List.length args in - let () = - if not (Int.equal nparams nargs) then - let loc, qid = match rel with - | RelId lid -> lid - | AbsKn kn -> loc, shortest_qualid_of_type kn - in - user_err ~loc (strbrk "The type constructor " ++ pr_qualid qid ++ - strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ - applied to " ++ int nargs ++ strbrk "argument(s)") - in - GTypRef (kn, List.map (fun t -> intern_type env t) args) -| CTypArrow (loc, t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) -| CTypTuple (loc, tl) -> GTypTuple (List.map (fun t -> intern_type env t) tl) - -let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = - let (n, t) = t in - let subst = Array.init n (fun _ -> fresh_id env) in - let substf i = GTypVar subst.(i) in - subst_type substf t - -let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = - let (n, t) = t in - let subst = Array.init n (fun _ -> fresh_id env) in - let substf = function - | LVar i -> GTypVar subst.(i) - | GVar n -> GTypVar n - in - subst_type substf t - -let fresh_reftype env (kn : KerName.t) = - let (n, _) = Tac2env.interp_type kn in - let subst = Array.init n (fun _ -> fresh_id env) in - let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in - (subst, t) - -(** First-order unification algorithm *) - -let is_unfoldable kn = match snd (Tac2env.interp_type kn) with -| GTydDef (Some _) -> true -| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false - -let unfold env kn args = - let (nparams, def) = Tac2env.interp_type kn in - let def = match def with - | GTydDef (Some t) -> t - | _ -> assert false - in - let args = Array.of_list args in - let subst n = args.(n) in - subst_type subst def - -(** View function, allows to ensure head normal forms *) -let rec kind env t = match t with -| GTypVar id -> - let (id, v) = UF.find id env.env_cst in - begin match v with - | None -> GTypVar id - | Some t -> kind env t - end -| GTypRef (kn, tl) -> - if is_unfoldable kn then kind env (unfold env kn tl) else t -| GTypArrow _ | GTypTuple _ -> t - -exception Occur - -let rec occur_check env id t = match kind env t with -| GTypVar id' -> if UF.equal id id' then raise Occur -| GTypArrow (t1, t2) -> - let () = occur_check env id t1 in - occur_check env id t2 -| GTypTuple tl -> - List.iter (fun t -> occur_check env id t) tl -| GTypRef (kn, tl) -> - List.iter (fun t -> occur_check env id t) tl - -exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr - -let unify_var env id t = match kind env t with -| GTypVar id' -> - if not (UF.equal id id') then UF.union id id' env.env_cst -| GTypArrow _ | GTypRef _ | GTypTuple _ -> - try - let () = occur_check env id t in - UF.set id t env.env_cst - with Occur -> raise (CannotUnify (GTypVar id, t)) - -let rec unify env t1 t2 = match kind env t1, kind env t2 with -| GTypVar id, t | t, GTypVar id -> - unify_var env id t -| GTypArrow (t1, u1), GTypArrow (t2, u2) -> - let () = unify env t1 t2 in - unify env u1 u2 -| GTypTuple tl1, GTypTuple tl2 -> - if Int.equal (List.length tl1) (List.length tl2) then - List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 - else raise (CannotUnify (t1, t2)) -| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> - if KerName.equal kn1 kn2 then - List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 - else raise (CannotUnify (t1, t2)) -| _ -> raise (CannotUnify (t1, t2)) - -let unify loc env t1 t2 = - try unify env t1 t2 - with CannotUnify (u1, u2) -> - let name = env_name env in - user_err ~loc (str "This expression has type " ++ pr_glbtype name t1 ++ - str " but an expression what expected of type " ++ pr_glbtype name t2) - -(** Term typing *) - -let is_pure_constructor kn = - match snd (Tac2env.interp_type kn) with - | GTydAlg _ | GTydOpn -> true - | GTydRec fields -> - let is_pure (_, mut, _) = not mut in - List.for_all is_pure fields - | GTydDef _ -> assert false (** Type definitions have no constructors *) - -let rec is_value = function -| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true -| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false -| GTacCst (GCaseTuple _, _, el) -> List.for_all is_value el -| GTacCst (_, _, []) -> true -| GTacOpn (_, el) -> List.for_all is_value el -| GTacCst (GCaseAlg kn, _, el) -> is_pure_constructor kn && List.for_all is_value el -| GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ -| GTacWth _ -> false - -let is_rec_rhs = function -| GTacFun _ -> true -| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ -| GTacSet _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ -| GTacCse _ | GTacOpn _ | GTacWth _ -> false - -let rec fv_type f t accu = match t with -| GTypVar id -> f id accu -| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) -| GTypTuple tl -> List.fold_left (fun accu t -> fv_type f t accu) accu tl -| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl - -let fv_env env = - let rec f id accu = match UF.find id env.env_cst with - | id, None -> UF.Map.add id () accu - | _, Some t -> fv_type f t accu - in - let fold_var id (_, t) accu = - let fmix id accu = match id with - | LVar _ -> accu - | GVar id -> f id accu - in - fv_type fmix t accu - in - let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in - let fold_als _ id accu = f id accu in - Id.Map.fold fold_als !(env.env_als) fv_var - -let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = - let fv = fv_env env in - let count = ref 0 in - let vars = ref UF.Map.empty in - let rec subst id = - let (id, t) = UF.find id env.env_cst in - match t with - | None -> - if UF.Map.mem id fv then GTypVar (GVar id) - else - begin try UF.Map.find id !vars - with Not_found -> - let n = !count in - let var = GTypVar (LVar n) in - let () = incr count in - let () = vars := UF.Map.add id var !vars in - var - end - | Some t -> subst_type subst t - in - let t = subst_type subst t in - (!count, t) - -let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = - let subst id = GTypVar (GVar id) in - (0, subst_type subst t) - -let warn_not_unit = - CWarnings.create ~name:"not-unit" ~category:"ltac" - (fun () -> strbrk "The following expression should have type unit.") - -let warn_redundant_clause = - CWarnings.create ~name:"redundant-clause" ~category:"ltac" - (fun () -> strbrk "The following clause is redundant.") - -let check_elt_unit loc env t = - let maybe_unit = match kind env t with - | GTypVar _ -> true - | GTypArrow _ | GTypTuple _ -> false - | GTypRef (kn, _) -> KerName.equal kn t_unit - in - if not maybe_unit then warn_not_unit ~loc () - -let check_elt_empty loc env t = match kind env t with -| GTypVar _ -> - user_err ~loc (str "Cannot infer an empty type for this expression") -| GTypArrow _ | GTypTuple _ -> - let name = env_name env in - user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") -| GTypRef (kn, _) -> - let def = Tac2env.interp_type kn in - match def with - | _, GTydAlg [] -> kn - | _ -> - let name = env_name env in - user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") - -let check_unit ?loc t = - let maybe_unit = match t with - | GTypVar _ -> true - | GTypArrow _ | GTypTuple _ -> false - | GTypRef (kn, _) -> KerName.equal kn t_unit - in - if not maybe_unit then warn_not_unit ?loc () - -let check_redundant_clause = function -| [] -> () -| (p, _) :: _ -> warn_redundant_clause ~loc:(loc_of_patexpr p) () - -let get_variable0 mem var = match var with -| RelId (loc, qid) -> - let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp && mem id then ArgVar (loc, id) - else - let kn = - try Tac2env.locate_ltac qid - with Not_found -> - CErrors.user_err ~loc (str "Unbound value " ++ pr_qualid qid) - in - ArgArg kn -| AbsKn kn -> ArgArg kn - -let get_variable env var = - let mem id = Id.Map.mem id env.env_var in - get_variable0 mem var - -let get_constructor env var = match var with -| RelId (loc, qid) -> - let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in - begin match c with - | Some (TacConstructor knc) -> - let kn = Tac2env.interp_constructor knc in - ArgArg (kn, knc) - | Some (TacConstant _) -> - CErrors.user_err ~loc (str "The term " ++ pr_qualid qid ++ - str " is not the constructor of an inductive type.") - | None -> - let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp then ArgVar (loc, id) - else CErrors.user_err ~loc (str "Unbound constructor " ++ pr_qualid qid) - end -| AbsKn knc -> - let kn = Tac2env.interp_constructor knc in - ArgArg (kn, knc) - -let get_projection var = match var with -| RelId (loc, qid) -> - let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ~loc (pr_qualid qid ++ str " is not a projection") - in - Tac2env.interp_projection kn -| AbsKn kn -> - Tac2env.interp_projection kn - -let intern_atm env = function -| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (t_int, [])) -| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (t_string, [])) - -let invalid_pattern ~loc kn t = - let pt = match t with - | GCaseAlg kn' -> pr_typref kn - | GCaseTuple n -> str "tuple" - in - user_err ~loc (str "Invalid pattern, expected a pattern for type " ++ - pr_typref kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) - -(** Pattern view *) - -type glb_patexpr = -| GPatVar of Name.t -| GPatRef of ltac_constructor * glb_patexpr list -| GPatTup of glb_patexpr list - -let rec intern_patexpr env = function -| CPatAny _ -> GPatVar Anonymous -| CPatRef (_, qid, []) -> - begin match get_constructor env qid with - | ArgVar (_, id) -> GPatVar (Name id) - | ArgArg (_, kn) -> GPatRef (kn, []) - end -| CPatRef (_, qid, pl) -> - begin match get_constructor env qid with - | ArgVar (loc, id) -> - user_err ~loc (str "Unbound constructor " ++ Nameops.pr_id id) - | ArgArg (_, kn) -> GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) - end -| CPatTup (_, pl) -> - GPatTup (List.map (fun p -> intern_patexpr env p) pl) - -type pattern_kind = -| PKind_empty -| PKind_variant of type_constant -| PKind_open of type_constant -| PKind_tuple of int -| PKind_any - -let get_pattern_kind env pl = match pl with -| [] -> PKind_empty -| p :: pl -> - let rec get_kind (p, _) pl = match intern_patexpr env p with - | GPatVar _ -> - begin match pl with - | [] -> PKind_any - | p :: pl -> get_kind p pl - end - | GPatRef (kn, pl) -> - let data = Tac2env.interp_constructor kn in - if Option.is_empty data.cdata_indx then PKind_open data.cdata_type - else PKind_variant data.cdata_type - | GPatTup tp -> PKind_tuple (List.length tp) - in - get_kind p pl - -(** Internalization *) - -let is_constructor env qid = match get_variable env qid with -| ArgArg (TacConstructor _) -> true -| _ -> false - -let rec intern_rec env = function -| CTacAtm (_, atm) -> intern_atm env atm -| CTacRef qid as e -> - begin match get_variable env qid with - | ArgVar (_, id) -> - let sch = Id.Map.find id env.env_var in - (GTacVar id, fresh_mix_type_scheme env sch) - | ArgArg (TacConstant kn) -> - let (_, _, sch) = Tac2env.interp_global kn in - (GTacRef kn, fresh_type_scheme env sch) - | ArgArg (TacConstructor kn) -> - let loc = loc_of_tacexpr e in - intern_constructor env loc kn [] - end -| CTacFun (loc, bnd, e) -> - let fold (env, bnd, tl) ((_, na), t) = - let t = match t with - | None -> GTypVar (fresh_id env) - | Some t -> intern_type env t - in - let env = push_name na (monomorphic t) env in - (env, na :: bnd, t :: tl) - in - let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in - let bnd = List.rev bnd in - let (e, t) = intern_rec env e in - let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in - (GTacFun (bnd, e), t) -| CTacApp (loc, CTacRef qid, args) as e when is_constructor env qid -> - let kn = match get_variable env qid with - | ArgArg (TacConstructor kn) -> kn - | _ -> assert false - in - let loc = loc_of_tacexpr e in - intern_constructor env loc kn args -| CTacApp (loc, f, args) -> - let (f, ft) = intern_rec env f in - let fold arg (args, t) = - let (arg, argt) = intern_rec env arg in - (arg :: args, GTypArrow (argt, t)) - in - let ret = GTypVar (fresh_id env) in - let (args, t) = List.fold_right fold args ([], ret) in - let () = unify loc env ft t in - (GTacApp (f, args), ret) -| CTacLet (loc, false, el, e) -> - let fold accu ((loc, na), _, _) = match na with - | Anonymous -> accu - | Name id -> - if Id.Set.mem id accu then - user_err ~loc (str "Variable " ++ Id.print id ++ str " is bound several \ - times in this matching") - else Id.Set.add id accu - in - let _ = List.fold_left fold Id.Set.empty el in - let fold ((loc, na), tc, e) (el, p) = - let (e, t) = intern_rec env e in - let () = match tc with - | None -> () - | Some tc -> - let tc = intern_type env tc in - unify loc env t tc - in - let t = if is_value e then abstract_var env t else monomorphic t in - ((na, e) :: el), ((na, t) :: p) - in - let (el, p) = List.fold_right fold el ([], []) in - let nenv = List.fold_left (fun accu (na, t) -> push_name na t env) env p in - let (e, t) = intern_rec nenv e in - (GTacLet (false, el, e), t) -| CTacLet (loc, true, el, e) -> - intern_let_rec env loc el e -| CTacTup (loc, []) -> - (GTacCst (GCaseAlg t_unit, 0, []), GTypRef (t_unit, [])) -| CTacTup (loc, el) -> - let fold e (el, tl) = - let (e, t) = intern_rec env e in - (e :: el, t :: tl) - in - let (el, tl) = List.fold_right fold el ([], []) in - (GTacCst (GCaseTuple (List.length el), 0, el), GTypTuple tl) -| CTacArr (loc, []) -> - let id = fresh_id env in - (GTacArr [], GTypRef (t_int, [GTypVar id])) -| CTacArr (loc, e0 :: el) -> - let (e0, t0) = intern_rec env e0 in - let fold e el = intern_rec_with_constraint env e t0 :: el in - let el = e0 :: List.fold_right fold el [] in - (GTacArr el, GTypRef (t_array, [t0])) -| CTacLst (loc, []) -> - let id = fresh_id env in - (c_nil, GTypRef (t_list, [GTypVar id])) -| CTacLst (loc, e0 :: el) -> - let (e0, t0) = intern_rec env e0 in - let fold e el = c_cons (intern_rec_with_constraint env e t0) el in - let el = c_cons e0 (List.fold_right fold el c_nil) in - (el, GTypRef (t_list, [t0])) -| CTacCnv (loc, e, tc) -> - let (e, t) = intern_rec env e in - let tc = intern_type env tc in - let () = unify loc env t tc in - (e, tc) -| CTacSeq (loc, e1, e2) -> - let (e1, t1) = intern_rec env e1 in - let (e2, t2) = intern_rec env e2 in - let () = check_elt_unit loc env t1 in - (GTacLet (false, [Anonymous, e1], e2), t2) -| CTacCse (loc, e, pl) -> - intern_case env loc e pl -| CTacRec (loc, fs) -> - intern_record env loc fs -| CTacPrj (loc, e, proj) -> - let pinfo = get_projection proj in - let loc = loc_of_tacexpr e in - let (e, t) = intern_rec env e in - let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in - let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (pinfo.pdata_type, params) in - let () = unify loc env t exp in - let substf i = GTypVar subst.(i) in - let ret = subst_type substf pinfo.pdata_ptyp in - (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) -| CTacSet (loc, e, proj, r) -> - let pinfo = get_projection proj in - let () = - if not pinfo.pdata_mutb then - let loc = match proj with - | RelId (loc, _) -> loc - | AbsKn _ -> Loc.ghost - in - user_err ~loc (str "Field is not mutable") - in - let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in - let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (pinfo.pdata_type, params) in - let e = intern_rec_with_constraint env e exp in - let substf i = GTypVar subst.(i) in - let ret = subst_type substf pinfo.pdata_ptyp in - let r = intern_rec_with_constraint env r ret in - (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (t_unit, [])) -| CTacExt (loc, ext) -> - let open Genintern in - let GenArg (Rawwit tag, _) = ext in - let tpe = interp_ml_object tag in - (** External objects do not have access to the named context because this is - not stable by dynamic semantics. *) - let genv = Global.env_of_context Environ.empty_named_context_val in - let ist = empty_glob_sign genv in - let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let (_, ext) = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> generic_intern ist ext) () in - (GTacExt ext, GTypRef (tpe.ml_type, [])) - -and intern_rec_with_constraint env e exp = - let loc = loc_of_tacexpr e in - let (e, t) = intern_rec env e in - let () = unify loc env t exp in - e - -and intern_let_rec env loc el e = - let fold accu ((loc, na), _, _) = match na with - | Anonymous -> accu - | Name id -> - if Id.Set.mem id accu then - user_err ~loc (str "Variable " ++ Id.print id ++ str " is bound several \ - times in this matching") - else Id.Set.add id accu - in - let _ = List.fold_left fold Id.Set.empty el in - let map env ((loc, na), t, e) = - let id = fresh_id env in - let env = push_name na (monomorphic (GTypVar id)) env in - (env, (loc, na, t, e, id)) - in - let (env, el) = List.fold_map map env el in - let fold (loc, na, tc, e, id) (el, tl) = - let loc_e = loc_of_tacexpr e in - let (e, t) = intern_rec env e in - let () = - if not (is_rec_rhs e) then - user_err ~loc:loc_e (str "This kind of expression is not allowed as \ - right-hand side of a recursive binding") - in - let () = unify loc env t (GTypVar id) in - let () = match tc with - | None -> () - | Some tc -> - let tc = intern_type env tc in - unify loc env t tc - in - ((na, e) :: el, t :: tl) - in - let (el, tl) = List.fold_right fold el ([], []) in - let (e, t) = intern_rec env e in - (GTacLet (true, el, e), t) - -(** For now, patterns recognized by the pattern-matching compiling are limited - to depth-one where leaves are either variables or catch-all *) -and intern_case env loc e pl = - let (e', t) = intern_rec env e in - let todo ~loc () = user_err ~loc (str "Pattern not handled yet") in - match get_pattern_kind env pl with - | PKind_any -> - let (pat, b) = List.hd pl in - let na = match intern_patexpr env pat with - | GPatVar na -> na - | _ -> assert false - in - let () = check_redundant_clause (List.tl pl) in - let env = push_name na (monomorphic t) env in - let (b, tb) = intern_rec env b in - (GTacLet (false, [na, e'], b), tb) - | PKind_empty -> - let kn = check_elt_empty loc env t in - let r = fresh_id env in - (GTacCse (e', GCaseAlg kn, [||], [||]), GTypVar r) - | PKind_tuple len -> - begin match pl with - | [] -> assert false - | [CPatTup (_, []), b] -> - let () = unify (loc_of_tacexpr e) env t (GTypRef (t_unit, [])) in - let (b, tb) = intern_rec env b in - (GTacCse (e', GCaseAlg t_unit, [|b|], [||]), tb) - | [CPatTup (_, pl), b] -> - let map = function - | CPatAny _ -> Anonymous - | CPatRef (loc, qid, []) -> - begin match get_constructor env qid with - | ArgVar (_, id) -> Name id - | ArgArg _ -> todo ~loc () - end - | p -> todo ~loc:(loc_of_patexpr p) () - in - let ids = Array.map_of_list map pl in - let tc = GTypTuple (List.map (fun _ -> GTypVar (fresh_id env)) pl) in - let () = unify (loc_of_tacexpr e) env t tc in - let (b, tb) = intern_rec env b in - (GTacCse (e', GCaseTuple len, [||], [|ids, b|]), tb) - | (p, _) :: _ -> todo ~loc:(loc_of_patexpr p) () - end - | PKind_variant kn -> - let subst, tc = fresh_reftype env kn in - let () = unify (loc_of_tacexpr e) env t tc in - let (params, def) = Tac2env.interp_type kn in - let cstrs = match def with - | GTydAlg c -> c - | _ -> assert false - in - let count (const, nonconst) (c, args) = match args with - | [] -> (succ const, nonconst) - | _ :: _ -> (const, succ nonconst) - in - let nconst, nnonconst = List.fold_left count (0, 0) cstrs in - let const = Array.make nconst None in - let nonconst = Array.make nnonconst None in - let ret = GTypVar (fresh_id env) in - let rec intern_branch = function - | [] -> () - | (pat, br) :: rem -> - let tbr = match pat with - | CPatAny _ -> - let () = check_redundant_clause rem in - let (br', brT) = intern_rec env br in - (** Fill all remaining branches *) - let fill (ncst, narg) (_, args) = - if List.is_empty args then - let () = - if Option.is_empty const.(ncst) then const.(ncst) <- Some br' - in - (succ ncst, narg) - else - let () = - if Option.is_empty const.(narg) then - let ids = Array.map_of_list (fun _ -> Anonymous) args in - nonconst.(narg) <- Some (ids, br') - in - (ncst, succ narg) - in - let _ = List.fold_left fill (0, 0) cstrs in - brT - | CPatRef (loc, qid, args) -> - let data = match get_constructor env qid with - | ArgVar _ -> todo ~loc () - | ArgArg (data, _) -> - let () = - let kn' = data.cdata_type in - if not (KerName.equal kn kn') then - invalid_pattern ~loc kn (GCaseAlg kn') - in - data - in - let get_id = function - | CPatAny _ -> Anonymous - | CPatRef (loc, qid, []) -> - begin match get_constructor env qid with - | ArgVar (_, id) -> Name id - | ArgArg _ -> todo ~loc () - end - | p -> todo ~loc:(loc_of_patexpr p) () - in - let ids = List.map get_id args in - let nids = List.length ids in - let nargs = List.length data.cdata_args in - let () = - if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids - in - let fold env id tpe = - (** Instantiate all arguments *) - let subst n = GTypVar subst.(n) in - let tpe = subst_type subst tpe in - push_name id (monomorphic tpe) env - in - let nenv = List.fold_left2 fold env ids data.cdata_args in - let (br', brT) = intern_rec nenv br in - let () = - let index = match data.cdata_indx with - | Some i -> i - | None -> assert false - in - if List.is_empty args then - if Option.is_empty const.(index) then const.(index) <- Some br' - else warn_redundant_clause ~loc () - else - let ids = Array.of_list ids in - if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') - else warn_redundant_clause ~loc () - in - brT - | CPatTup (loc, tup) -> - invalid_pattern ~loc kn (GCaseTuple (List.length tup)) - in - let () = unify (loc_of_tacexpr br) env ret tbr in - intern_branch rem - in - let () = intern_branch pl in - let map = function - | None -> user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) - | Some x -> x - in - let const = Array.map map const in - let nonconst = Array.map map nonconst in - let ce = GTacCse (e', GCaseAlg kn, const, nonconst) in - (ce, ret) - | PKind_open kn -> - let subst, tc = fresh_reftype env kn in - let () = unify (loc_of_tacexpr e) env t tc in - let ret = GTypVar (fresh_id env) in - let rec intern_branch map = function - | [] -> - user_err ~loc (str "Missing default case") - | (pat, br) :: rem -> - match intern_patexpr env pat with - | GPatVar na -> - let () = check_redundant_clause rem in - let nenv = push_name na (monomorphic tc) env in - let br' = intern_rec_with_constraint nenv br ret in - let def = (na, br') in - (map, def) - | GPatRef (knc, args) -> - let get = function - | GPatVar na -> na - | GPatRef _ | GPatTup _ -> - user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) - in - let loc = loc_of_patexpr pat in - let ids = List.map get args in - let data = Tac2env.interp_constructor knc in - let () = - if not (KerName.equal kn data.cdata_type) then - invalid_pattern ~loc kn (GCaseAlg data.cdata_type) - in - let nids = List.length ids in - let nargs = List.length data.cdata_args in - let () = - if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids - in - let fold env id tpe = - (** Instantiate all arguments *) - let subst n = GTypVar subst.(n) in - let tpe = subst_type subst tpe in - push_name id (monomorphic tpe) env - in - let nenv = List.fold_left2 fold env ids data.cdata_args in - let br' = intern_rec_with_constraint nenv br ret in - let map = - if KNmap.mem knc map then - let () = warn_redundant_clause ~loc () in - map - else - KNmap.add knc (Anonymous, Array.of_list ids, br') map - in - intern_branch map rem - | GPatTup tup -> - invalid_pattern ~loc kn (GCaseTuple (List.length tup)) - in - let (map, def) = intern_branch KNmap.empty pl in - (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) - -and intern_constructor env loc kn args = - let cstr = interp_constructor kn in - let nargs = List.length cstr.cdata_args in - if Int.equal nargs (List.length args) then - let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in - let substf i = GTypVar subst.(i) in - let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in - let ans = GTypRef (cstr.cdata_type, List.init cstr.cdata_prms (fun i -> GTypVar subst.(i))) in - let map arg tpe = intern_rec_with_constraint env arg tpe in - let args = List.map2 map args types in - match cstr.cdata_indx with - | Some idx -> - (GTacCst (GCaseAlg cstr.cdata_type, idx, args), ans) - | None -> - (GTacOpn (kn, args), ans) - else - error_nargs_mismatch loc nargs (List.length args) - -and intern_record env loc fs = - let map (proj, e) = - let loc = match proj with - | RelId (loc, _) -> loc - | AbsKn _ -> Loc.ghost - in - let proj = get_projection proj in - (loc, proj, e) - in - let fs = List.map map fs in - let kn = match fs with - | [] -> user_err ~loc (str "Cannot infer the corresponding record type") - | (_, proj, _) :: _ -> proj.pdata_type - in - let params, typdef = match Tac2env.interp_type kn with - | n, GTydRec def -> n, def - | _ -> assert false - in - let subst = Array.init params (fun _ -> fresh_id env) in - (** Set the answer [args] imperatively *) - let args = Array.make (List.length typdef) None in - let iter (loc, pinfo, e) = - if KerName.equal kn pinfo.pdata_type then - let index = pinfo.pdata_indx in - match args.(index) with - | None -> - let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in - let e = intern_rec_with_constraint env e exp in - args.(index) <- Some e - | Some _ -> - let (name, _, _) = List.nth typdef pinfo.pdata_indx in - user_err ~loc (str "Field " ++ Id.print name ++ str " is defined \ - several times") - else - user_err ~loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ - pertain to record definition " ++ pr_typref pinfo.pdata_type) - in - let () = List.iter iter fs in - let () = match Array.findi (fun _ o -> Option.is_empty o) args with - | None -> () - | Some i -> - let (field, _, _) = List.nth typdef i in - user_err ~loc (str "Field " ++ Id.print field ++ str " is undefined") - in - let args = Array.map_to_list Option.get args in - let tparam = List.init params (fun i -> GTypVar subst.(i)) in - (GTacCst (GCaseAlg kn, 0, args), GTypRef (kn, tparam)) - -let normalize env (count, vars) (t : UF.elt glb_typexpr) = - let get_var id = - try UF.Map.find id !vars - with Not_found -> - let () = assert env.env_opn in - let n = GTypVar !count in - let () = incr count in - let () = vars := UF.Map.add id n !vars in - n - in - let rec subst id = match UF.find id env.env_cst with - | id, None -> get_var id - | _, Some t -> subst_type subst t - in - subst_type subst t - -let intern e = - let env = empty_env () in - let (e, t) = intern_rec env e in - let count = ref 0 in - let vars = ref UF.Map.empty in - let t = normalize env (count, vars) t in - (e, (!count, t)) - -let intern_typedef self (ids, t) : glb_quant_typedef = - let env = { (empty_env ()) with env_rec = self } in - (** Initialize type parameters *) - let map id = get_alias id env in - let ids = List.map map ids in - let count = ref (List.length ids) in - let vars = ref UF.Map.empty in - let iter n id = vars := UF.Map.add id (GTypVar n) !vars in - let () = List.iteri iter ids in - (** Do not accept unbound type variables *) - let env = { env with env_opn = false } in - let intern t = - let t = intern_type env t in - normalize env (count, vars) t - in - let count = !count in - match t with - | CTydDef None -> (count, GTydDef None) - | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) - | CTydAlg constrs -> - let map (c, t) = (c, List.map intern t) in - let constrs = List.map map constrs in - (count, GTydAlg constrs) - | CTydRec fields -> - let map (c, mut, t) = (c, mut, intern t) in - let fields = List.map map fields in - (count, GTydRec fields) - | CTydOpn -> (count, GTydOpn) - -let intern_open_type t = - let env = empty_env () in - let t = intern_type env t in - let count = ref 0 in - let vars = ref UF.Map.empty in - let t = normalize env (count, vars) t in - (!count, t) - -(** Globalization *) - -let add_name accu = function -| Name id -> Id.Set.add id accu -| Anonymous -> accu - -let get_projection0 var = match var with -| RelId (loc, qid) -> - let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ~loc (pr_qualid qid ++ str " is not a projection") - in - kn -| AbsKn kn -> kn - -let rec globalize ids e = match e with -| CTacAtm _ -> e -| CTacRef ref -> - let mem id = Id.Set.mem id ids in - begin match get_variable0 mem ref with - | ArgVar _ -> e - | ArgArg kn -> CTacRef (AbsKn kn) - end -| CTacFun (loc, bnd, e) -> - let fold accu ((_, na), _) = add_name accu na in - let ids = List.fold_left fold ids bnd in - let e = globalize ids e in - CTacFun (loc, bnd, e) -| CTacApp (loc, e, el) -> - let e = globalize ids e in - let el = List.map (fun e -> globalize ids e) el in - CTacApp (loc, e, el) -| CTacLet (loc, isrec, bnd, e) -> - let fold accu ((_, na), _, _) = add_name accu na in - let ext = List.fold_left fold Id.Set.empty bnd in - let eids = Id.Set.union ext ids in - let e = globalize eids e in - let map (qid, t, e) = - let ids = if isrec then eids else ids in - (qid, t, globalize ids e) - in - let bnd = List.map map bnd in - CTacLet (loc, isrec, bnd, e) -| CTacTup (loc, el) -> - let el = List.map (fun e -> globalize ids e) el in - CTacTup (loc, el) -| CTacArr (loc, el) -> - let el = List.map (fun e -> globalize ids e) el in - CTacArr (loc, el) -| CTacLst (loc, el) -> - let el = List.map (fun e -> globalize ids e) el in - CTacLst (loc, el) -| CTacCnv (loc, e, t) -> - let e = globalize ids e in - CTacCnv (loc, e, t) -| CTacSeq (loc, e1, e2) -> - let e1 = globalize ids e1 in - let e2 = globalize ids e2 in - CTacSeq (loc, e1, e2) -| CTacCse (loc, e, bl) -> - let e = globalize ids e in - let bl = List.map (fun b -> globalize_case ids b) bl in - CTacCse (loc, e, bl) -| CTacRec (loc, r) -> - let map (p, e) = - let p = get_projection0 p in - let e = globalize ids e in - (AbsKn p, e) - in - CTacRec (loc, List.map map r) -| CTacPrj (loc, e, p) -> - let e = globalize ids e in - let p = get_projection0 p in - CTacPrj (loc, e, AbsKn p) -| CTacSet (loc, e, p, e') -> - let e = globalize ids e in - let p = get_projection0 p in - let e' = globalize ids e' in - CTacSet (loc, e, AbsKn p, e') -| CTacExt (loc, arg) -> - let arg = pr_argument_type (genarg_tag arg) in - CErrors.user_err ~loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) - -and globalize_case ids (p, e) = - (globalize_pattern ids p, globalize ids e) - -and globalize_pattern ids p = match p with -| CPatAny _ -> p -| CPatRef (loc, cst, pl) -> - let cst = match get_constructor () cst with - | ArgVar _ -> cst - | ArgArg (_, knc) -> AbsKn knc - in - let pl = List.map (fun p -> globalize_pattern ids p) pl in - CPatRef (loc, cst, pl) -| CPatTup (loc, pl) -> - let pl = List.map (fun p -> globalize_pattern ids p) pl in - CPatTup (loc, pl) - -(** Kernel substitution *) - -open Mod_subst - -let rec subst_type subst t = match t with -| GTypVar _ -> t -| GTypArrow (t1, t2) -> - let t1' = subst_type subst t1 in - let t2' = subst_type subst t2 in - if t1' == t1 && t2' == t2 then t - else GTypArrow (t1', t2') -| GTypTuple tl -> - let tl'= List.smartmap (fun t -> subst_type subst t) tl in - if tl' == tl then t else GTypTuple tl' -| GTypRef (kn, tl) -> - let kn' = subst_kn subst kn in - let tl' = List.smartmap (fun t -> subst_type subst t) tl in - if kn' == kn && tl' == tl then t else GTypRef (kn', tl') - -let subst_case_info subst ci = match ci with -| GCaseAlg kn -> - let kn' = subst_kn subst kn in - if kn' == kn then ci else GCaseAlg kn' -| GCaseTuple _ -> ci - -let rec subst_expr subst e = match e with -| GTacAtm _ | GTacVar _ | GTacPrm _ -> e -| GTacRef kn -> GTacRef (subst_kn subst kn) -| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) -| GTacApp (f, args) -> - GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) -| GTacLet (r, bs, e) -> - let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in - GTacLet (r, bs, subst_expr subst e) -| GTacArr el -> - GTacArr (List.map (fun e -> subst_expr subst e) el) -| GTacCst (t, n, el) as e0 -> - let t' = match t with - | GCaseAlg kn -> - let kn' = subst_kn subst kn in - if kn' == kn then t else GCaseAlg kn' - | GCaseTuple _ -> t - in - let el' = List.smartmap (fun e -> subst_expr subst e) el in - if t' == t && el' == el then e0 else GTacCst (t', n, el') -| GTacCse (e, ci, cse0, cse1) -> - let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in - let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in - let ci' = subst_case_info subst ci in - GTacCse (subst_expr subst e, ci', cse0', cse1') -| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> - let e' = subst_expr subst e in - let def' = subst_expr subst def in - let fold kn (self, vars, p) accu = - let kn' = subst_kn subst kn in - let p' = subst_expr subst p in - if kn' == kn && p' == p then accu - else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) - in - let br' = KNmap.fold fold br br in - if e' == e && br' == br && def' == def then e0 - else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } -| GTacPrj (kn, e, p) as e0 -> - let kn' = subst_kn subst kn in - let e' = subst_expr subst e in - if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) -| GTacSet (kn, e, p, r) as e0 -> - let kn' = subst_kn subst kn in - let e' = subst_expr subst e in - let r' = subst_expr subst r in - if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') -| GTacExt ext -> - let ext' = Genintern.generic_substitute subst ext in - if ext' == ext then e else GTacExt ext' -| GTacOpn (kn, el) as e0 -> - let kn' = subst_kn subst kn in - let el' = List.smartmap (fun e -> subst_expr subst e) el in - if kn' == kn && el' == el then e0 else GTacOpn (kn', el') - -let subst_typedef subst e = match e with -| GTydDef t -> - let t' = Option.smartmap (fun t -> subst_type subst t) t in - if t' == t then e else GTydDef t' -| GTydAlg constrs -> - let map (c, tl as p) = - let tl' = List.smartmap (fun t -> subst_type subst t) tl in - if tl' == tl then p else (c, tl') - in - let constrs' = List.smartmap map constrs in - if constrs' == constrs then e else GTydAlg constrs' -| GTydRec fields -> - let map (c, mut, t as p) = - let t' = subst_type subst t in - if t' == t then p else (c, mut, t') - in - let fields' = List.smartmap map fields in - if fields' == fields then e else GTydRec fields' -| GTydOpn -> GTydOpn - -let subst_quant_typedef subst (prm, def as qdef) = - let def' = subst_typedef subst def in - if def' == def then qdef else (prm, def') - -let subst_type_scheme subst (prm, t as sch) = - let t' = subst_type subst t in - if t' == t then sch else (prm, t') - -let subst_or_relid subst ref = match ref with -| RelId _ -> ref -| AbsKn kn -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn kn' - -let rec subst_rawtype subst t = match t with -| CTypVar _ -> t -| CTypArrow (loc, t1, t2) -> - let t1' = subst_rawtype subst t1 in - let t2' = subst_rawtype subst t2 in - if t1' == t1 && t2' == t2 then t else CTypArrow (loc, t1', t2') -| CTypTuple (loc, tl) -> - let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in - if tl' == tl then t else CTypTuple (loc, tl') -| CTypRef (loc, ref, tl) -> - let ref' = subst_or_relid subst ref in - let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in - if ref' == ref && tl' == tl then t else CTypRef (loc, ref', tl') - -let subst_tacref subst ref = match ref with -| RelId _ -> ref -| AbsKn (TacConstant kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacConstant kn') -| AbsKn (TacConstructor kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacConstructor kn') - -let subst_projection subst prj = match prj with -| RelId _ -> prj -| AbsKn kn -> - let kn' = subst_kn subst kn in - if kn' == kn then prj else AbsKn kn' - -let rec subst_rawpattern subst p = match p with -| CPatAny _ -> p -| CPatRef (loc, c, pl) -> - let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in - let c' = match c with - | RelId _ -> c - | AbsKn kn -> - let kn' = subst_kn subst kn in - if kn' == kn then c else AbsKn kn' - in - if pl' == pl && c' == c then p else CPatRef (loc, c', pl') -| CPatTup (loc, pl) -> - let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in - if pl' == pl then p else CPatTup (loc, pl') - -(** Used for notations *) -let rec subst_rawexpr subst t = match t with -| CTacAtm _ -> t -| CTacRef ref -> - let ref' = subst_tacref subst ref in - if ref' == ref then t else CTacRef ref' -| CTacFun (loc, bnd, e) -> - let map (na, t as p) = - let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in - if t' == t then p else (na, t') - in - let bnd' = List.smartmap map bnd in - let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CTacFun (loc, bnd', e') -| CTacApp (loc, e, el) -> - let e' = subst_rawexpr subst e in - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if e' == e && el' == el then t else CTacApp (loc, e', el') -| CTacLet (loc, isrec, bnd, e) -> - let map (na, t, e as p) = - let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in - let e' = subst_rawexpr subst e in - if t' == t && e' == e then p else (na, t', e') - in - let bnd' = List.smartmap map bnd in - let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CTacLet (loc, isrec, bnd', e') -| CTacTup (loc, el) -> - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if el' == el then t else CTacTup (loc, el') -| CTacArr (loc, el) -> - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if el' == el then t else CTacArr (loc, el') -| CTacLst (loc, el) -> - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if el' == el then t else CTacLst (loc, el') -| CTacCnv (loc, e, c) -> - let e' = subst_rawexpr subst e in - let c' = subst_rawtype subst c in - if c' == c && e' == e then t else CTacCnv (loc, e', c') -| CTacSeq (loc, e1, e2) -> - let e1' = subst_rawexpr subst e1 in - let e2' = subst_rawexpr subst e2 in - if e1' == e1 && e2' == e2 then t else CTacSeq (loc, e1', e2') -| CTacCse (loc, e, bl) -> - let map (p, e as x) = - let p' = subst_rawpattern subst p in - let e' = subst_rawexpr subst e in - if p' == p && e' == e then x else (p', e') - in - let e' = subst_rawexpr subst e in - let bl' = List.smartmap map bl in - if e' == e && bl' == bl then t else CTacCse (loc, e', bl') -| CTacRec (loc, el) -> - let map (prj, e as p) = - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then p else (prj', e') - in - let el' = List.smartmap map el in - if el' == el then t else CTacRec (loc, el') -| CTacPrj (loc, e, prj) -> - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then t else CTacPrj (loc, e', prj') -| CTacSet (loc, e, prj, r) -> - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - let r' = subst_rawexpr subst r in - if prj' == prj && e' == e && r' == r then t else CTacSet (loc, e', prj', r') -| CTacExt _ -> assert false (** Should not be generated by gloabalization *) - -(** Registering *) - -let () = - let open Genintern in - let intern ist tac = - let env = match Genintern.Store.get ist.extra ltac2_env with - | None -> empty_env () - | Some env -> env - in - let loc = loc_of_tacexpr tac in - let (tac, t) = intern_rec env tac in - let () = check_elt_unit loc env t in - (ist, tac) - in - Genintern.register_intern0 wit_ltac2 intern -let () = Genintern.register_subst0 wit_ltac2 subst_expr diff --git a/tac2intern.mli b/tac2intern.mli deleted file mode 100644 index 3d400a5cdd..0000000000 --- a/tac2intern.mli +++ /dev/null @@ -1,41 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Loc.t - -val intern : raw_tacexpr -> glb_tacexpr * type_scheme -val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef -val intern_open_type : raw_typexpr -> type_scheme - -(** Check that a term is a value. Only values are safe to marshall between - processes. *) -val is_value : glb_tacexpr -> bool -val check_unit : ?loc:Loc.t -> int glb_typexpr -> unit - -val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr -val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr -val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef -val subst_type_scheme : substitution -> type_scheme -> type_scheme - -val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr - -(** {5 Notations} *) - -val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr -(** Replaces all qualified identifiers by their corresponding kernel name. The - set represents bound variables in the context. *) - -(** Errors *) - -val error_nargs_mismatch : Loc.t -> int -> int -> 'a -val error_nparams_mismatch : Loc.t -> int -> int -> 'a diff --git a/tac2interp.ml b/tac2interp.ml deleted file mode 100644 index 664b7de3d6..0000000000 --- a/tac2interp.ml +++ /dev/null @@ -1,160 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let c = Tac2print.pr_constructor kn in - hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) -| _ -> raise Unhandled -end - -let val_exn = Geninterp.Val.create "ltac2:exn" - -type environment = valexpr Id.Map.t - -let empty_environment = Id.Map.empty - -let push_name ist id v = match id with -| Anonymous -> ist -| Name id -> Id.Map.add id v ist - -let get_var ist id = - try Id.Map.find id ist with Not_found -> - anomaly (str "Unbound variable " ++ Id.print id) - -let get_ref ist kn = - try pi2 (Tac2env.interp_global kn) with Not_found -> - anomaly (str "Unbound reference" ++ KerName.print kn) - -let return = Proofview.tclUNIT - -let rec interp ist = function -| GTacAtm (AtmInt n) -> return (ValInt n) -| GTacAtm (AtmStr s) -> return (ValStr (Bytes.of_string s)) -| GTacVar id -> return (get_var ist id) -| GTacRef qid -> return (get_ref ist qid) -| GTacFun (ids, e) -> - let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in - return (ValCls cls) -| GTacApp (f, args) -> - interp ist f >>= fun f -> - Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - interp_app f args -| GTacLet (false, el, e) -> - let fold accu (na, e) = - interp ist e >>= fun e -> - return (push_name accu na e) - in - Proofview.Monad.List.fold_left fold ist el >>= fun ist -> - interp ist e -| GTacLet (true, el, e) -> - let map (na, e) = match e with - | GTacFun (ids, e) -> - let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in - na, cls - | _ -> anomaly (str "Ill-formed recursive function") - in - let fixs = List.map map el in - let fold accu (na, cls) = match na with - | Anonymous -> accu - | Name id -> Id.Map.add id (ValCls cls) accu - in - let ist = List.fold_left fold ist fixs in - (** Hack to make a cycle imperatively in the environment *) - let iter (_, e) = e.clos_env <- ist in - let () = List.iter iter fixs in - interp ist e -| GTacArr el -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (ValBlk (0, Array.of_list el)) -| GTacCst (_, n, []) -> return (ValInt n) -| GTacCst (_, n, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (ValBlk (n, Array.of_list el)) -| GTacCse (e, _, cse0, cse1) -> - interp ist e >>= fun e -> interp_case ist e cse0 cse1 -| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> - interp ist e >>= fun e -> interp_with ist e cse def -| GTacPrj (_, e, p) -> - interp ist e >>= fun e -> interp_proj ist e p -| GTacSet (_, e, p, r) -> - interp ist e >>= fun e -> - interp ist r >>= fun r -> - interp_set ist e p r -| GTacOpn (kn, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (ValOpn (kn, Array.of_list el)) -| GTacPrm (ml, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - Tac2env.interp_primitive ml el -| GTacExt e -> - let GenArg (Glbwit tag, e) = e in - let tpe = Tac2env.interp_ml_object tag in - tpe.Tac2env.ml_interp ist e >>= fun e -> return (ValExt e) - -and interp_app f args = match f with -| ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> - let rec push ist ids args = match ids, args with - | [], [] -> interp ist e - | [], _ :: _ -> interp ist e >>= fun f -> interp_app f args - | _ :: _, [] -> - let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in - return (ValCls cls) - | id :: ids, arg :: args -> push (push_name ist id arg) ids args - in - push ist ids args -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> - anomaly (str "Unexpected value shape") - -and interp_case ist e cse0 cse1 = match e with -| ValInt n -> interp ist cse0.(n) -| ValBlk (n, args) -> - let (ids, e) = cse1.(n) in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist e -| ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> - anomaly (str "Unexpected value shape") - -and interp_with ist e cse def = match e with -| ValOpn (kn, args) -> - let br = try Some (KNmap.find kn cse) with Not_found -> None in - begin match br with - | None -> - let (self, def) = def in - let ist = push_name ist self e in - interp ist def - | Some (self, ids, p) -> - let ist = push_name ist self e in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist p - end -| ValInt _ | ValBlk _ | ValExt _ | ValStr _ | ValCls _ -> - anomaly (str "Unexpected value shape") - -and interp_proj ist e p = match e with -| ValBlk (_, args) -> - return args.(p) -| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> - anomaly (str "Unexpected value shape") - -and interp_set ist e p r = match e with -| ValBlk (_, args) -> - let () = args.(p) <- r in - return (ValInt 0) -| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> - anomaly (str "Unexpected value shape") diff --git a/tac2interp.mli b/tac2interp.mli deleted file mode 100644 index bf6b2d4dde..0000000000 --- a/tac2interp.mli +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glb_tacexpr -> valexpr Proofview.tactic - -val interp_app : valexpr -> valexpr list -> valexpr Proofview.tactic - -(** {5 Exceptions} *) - -exception LtacError of KerName.t * valexpr array -(** Ltac2-defined exceptions seen from OCaml side *) - -val val_exn : Exninfo.iexn Geninterp.Val.typ -(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] - should be put into a value with tag [val_exn]. *) diff --git a/tac2print.ml b/tac2print.ml deleted file mode 100644 index e6f0582e3d..0000000000 --- a/tac2print.ml +++ /dev/null @@ -1,296 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* str "'" ++ str (pr n) - | GTypRef (kn, []) -> pr_typref kn - | GTypRef (kn, [t]) -> - let paren = match lvl with - | T5_r | T5_l | T2 | T1 -> fun x -> x - | T0 -> paren - in - paren (pr_glbtype lvl t ++ spc () ++ pr_typref kn) - | GTypRef (kn, tl) -> - let paren = match lvl with - | T5_r | T5_l | T2 | T1 -> fun x -> x - | T0 -> paren - in - paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) - | GTypArrow (t1, t2) -> - let paren = match lvl with - | T5_r -> fun x -> x - | T5_l | T2 | T1 | T0 -> paren - in - paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) - | GTypTuple tl -> - let paren = match lvl with - | T5_r | T5_l -> fun x -> x - | T2 | T1 | T0 -> paren - in - paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) - in - hov 0 (pr_glbtype lvl c) - -let pr_glbtype pr c = pr_glbtype_gen pr T5_r c - -let int_name () = - let vars = ref Int.Map.empty in - fun n -> - if Int.Map.mem n !vars then Int.Map.find n !vars - else - let num = Int.Map.cardinal !vars in - let base = num mod 26 in - let rem = num / 26 in - let name = String.make 1 (Char.chr (97 + base)) in - let suff = if Int.equal rem 0 then "" else string_of_int rem in - let name = name ^ suff in - let () = vars := Int.Map.add n name !vars in - name - -(** Term printing *) - -let pr_constructor kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstructor kn)) - -let pr_projection kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) - -type exp_level = Tac2expr.exp_level = -| E5 -| E4 -| E3 -| E2 -| E1 -| E0 - -let pr_atom = function -| AtmInt n -> int n -| AtmStr s -> qstring s - -let pr_name = function -| Name id -> Id.print id -| Anonymous -> str "_" - -let find_constructor n empty def = - let rec find n = function - | [] -> assert false - | (id, []) :: rem -> - if empty then - if Int.equal n 0 then id - else find (pred n) rem - else find n rem - | (id, _ :: _) :: rem -> - if not empty then - if Int.equal n 0 then id - else find (pred n) rem - else find n rem - in - find n def - -let order_branches cbr nbr def = - let rec order cidx nidx def = match def with - | [] -> [] - | (id, []) :: rem -> - let ans = order (succ cidx) nidx rem in - (id, [], cbr.(cidx)) :: ans - | (id, _ :: _) :: rem -> - let ans = order cidx (succ nidx) rem in - let (vars, e) = nbr.(nidx) in - (id, Array.to_list vars, e) :: ans - in - order 0 0 def - -let pr_glbexpr_gen lvl c = - let rec pr_glbexpr lvl = function - | GTacAtm atm -> pr_atom atm - | GTacVar id -> Id.print id - | GTacRef gr -> - let qid = shortest_qualid_of_ltac (TacConstant gr) in - Libnames.pr_qualid qid - | GTacFun (nas, c) -> - let nas = pr_sequence pr_name nas in - let paren = match lvl with - | E0 | E1 | E2 | E3 | E4 -> paren - | E5 -> fun x -> x - in - paren (str "fun" ++ spc () ++ nas ++ spc () ++ str "=>" ++ spc () ++ - hov 0 (pr_glbexpr E5 c)) - | GTacApp (c, cl) -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - paren (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) - | GTacLet (mut, bnd, e) -> - let paren = match lvl with - | E0 | E1 | E2 | E3 | E4 -> paren - | E5 -> fun x -> x - in - let mut = if mut then str "rec" ++ spc () else mt () in - let pr_bnd (na, e) = - pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () - in - let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in - paren (str "let" ++ spc () ++ mut ++ bnd ++ str "in" ++ spc () ++ pr_glbexpr E5 e) - | GTacCst (GCaseTuple _, _, cl) -> - let paren = match lvl with - | E0 | E1 -> paren - | E2 | E3 | E4 | E5 -> fun x -> x - in - paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) - | GTacArr cl -> - mt () (** FIXME when implemented *) - | GTacCst (GCaseAlg tpe, n, cl) -> - begin match Tac2env.interp_type tpe with - | _, GTydAlg def -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let id = find_constructor n (List.is_empty cl) def in - let kn = change_kn_label tpe id in - let cl = match cl with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl - in - paren (pr_constructor kn ++ cl) - | _, GTydRec def -> - let args = List.combine def cl in - let pr_arg ((id, _, _), arg) = - let kn = change_kn_label tpe id in - pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg - in - let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in - str "{" ++ spc () ++ args ++ spc () ++ str "}" - | _, (GTydDef _ | GTydOpn) -> assert false - end - | GTacCse (e, info, cst_br, ncst_br) -> - let e = pr_glbexpr E5 e in - let br = match info with - | GCaseAlg kn -> - let def = match Tac2env.interp_type kn with - | _, GTydAlg def -> def - | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false - in - let br = order_branches cst_br ncst_br def in - let pr_branch (cstr, vars, p) = - let cstr = change_kn_label kn cstr in - let cstr = pr_constructor cstr in - let vars = match vars with - | [] -> mt () - | _ -> spc () ++ pr_sequence pr_name vars - in - hov 0 (str "|" ++ spc () ++ cstr ++ vars ++ spc () ++ str "=>" ++ spc () ++ - hov 2 (pr_glbexpr E5 p)) ++ spc () - in - prlist pr_branch br - | GCaseTuple n -> - let (vars, p) = ncst_br.(0) in - let p = pr_glbexpr E5 p in - let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in - str "|" ++ spc () ++ paren vars ++ spc () ++ str "=>" ++ spc () ++ p - in - hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") - | GTacWth wth -> - let e = pr_glbexpr E5 wth.opn_match in - let pr_pattern c self vars p = - let self = match self with - | Anonymous -> mt () - | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id - in - hov 0 (str "|" ++ spc () ++ c ++ vars ++ self ++ spc () ++ str "=>" ++ spc () ++ - hov 2 (pr_glbexpr E5 p)) ++ spc () - in - let pr_branch (cstr, (self, vars, p)) = - let cstr = pr_constructor cstr in - let vars = match Array.to_list vars with - | [] -> mt () - | vars -> spc () ++ pr_sequence pr_name vars - in - pr_pattern cstr self vars p - in - let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in - let (def_as, def_p) = wth.opn_default in - let def = pr_pattern (str "_") def_as (mt ()) def_p in - let br = br ++ def in - hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") - | GTacPrj (kn, e, n) -> - let def = match Tac2env.interp_type kn with - | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false - in - let (proj, _, _) = List.nth def n in - let proj = change_kn_label kn proj in - let proj = pr_projection proj in - let e = pr_glbexpr E0 e in - e ++ str "." ++ paren proj - | GTacSet (kn, e, n, r) -> - let def = match Tac2env.interp_type kn with - | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false - in - let (proj, _, _) = List.nth def n in - let proj = change_kn_label kn proj in - let proj = pr_projection proj in - let e = pr_glbexpr E0 e in - let r = pr_glbexpr E1 r in - e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r - | GTacOpn (kn, cl) -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let c = pr_constructor kn in - paren (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) - | GTacExt arg -> - let GenArg (Glbwit tag, arg) = arg in - let name = match tag with - | ExtraArg tag -> ArgT.repr tag - | _ -> assert false - in - str name ++ str ":" ++ paren (Genprint.glb_print tag arg) - | GTacPrm (prm, args) -> - let args = match args with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args - in - str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ - qstring prm.mltac_tactic ++ args - in - hov 0 (pr_glbexpr lvl c) - -let pr_glbexpr c = - pr_glbexpr_gen E5 c diff --git a/tac2print.mli b/tac2print.mli deleted file mode 100644 index ddd599641d..0000000000 --- a/tac2print.mli +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds -val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> std_ppcmds -val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> std_ppcmds - -(** {5 Printing expressions} *) - -val pr_constructor : ltac_constructor -> std_ppcmds -val pr_projection : ltac_projection -> std_ppcmds -val pr_glbexpr_gen : exp_level -> glb_tacexpr -> std_ppcmds -val pr_glbexpr : glb_tacexpr -> std_ppcmds - -(** {5 Utilities} *) - -val int_name : unit -> (int -> string) -(** Create a function that give names to integers. The names are generated on - the fly, in the order they are encountered. *) diff --git a/theories/Array.v b/theories/Array.v new file mode 100644 index 0000000000..11b64e3515 --- /dev/null +++ b/theories/Array.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'a array := "ltac2" "array_make". +Ltac2 @external length : 'a array -> int := "ltac2" "array_length". +Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". +Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/theories/Constr.v b/theories/Constr.v new file mode 100644 index 0000000000..c340e3aa87 --- /dev/null +++ b/theories/Constr.v @@ -0,0 +1,43 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr := "ltac2" "constr_type". +(** Return the type of a term *) + +Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". +(** Strict syntactic equality: only up to α-conversion and evar expansion *) + +Module Unsafe. + +(** Low-level access to kernel term. Use with care! *) + +Ltac2 Type kind := [ +| Rel (int) +| Var (ident) +| Meta (meta) +| Evar (evar, constr list) +| Sort (sort) +| Cast (constr, cast, constr) +| Prod (ident option, constr, constr) +| Lambda (ident option, constr, constr) +| LetIn (ident option, constr, constr, constr) +| App (constr, constr list) +| Constant (constant, instance) +| Ind (inductive, instance) +| Constructor (inductive, instance) +(* + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint +*) +| Proj (projection, constr) +]. + +End Unsafe. diff --git a/theories/Control.v b/theories/Control.v new file mode 100644 index 0000000000..3bc572547c --- /dev/null +++ b/theories/Control.v @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a := "ltac2" "throw". +(** Fatal exception throwing. This does not induce backtracking. *) + +(** Generic backtracking control *) + +Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". +Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". +Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". +Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". +Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". +Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". + +(** Proof state manipulation *) + +Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". +Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". +Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". + +Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". +(** Adds the given evar to the list of goals as the last one. If it is + already defined in the current state, don't do anything. Panics if the + evar is not in the current state. *) + +(** Goal inspection *) + +Ltac2 @ external goal : unit -> constr := "ltac2" "goal". +(** Panics if there is not exactly one goal under focus. Otherwise returns + the conclusion of this goal. *) + +Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, looks for the section variable with the given name. + If there is one, looks for the hypothesis with the given name. *) + +(** Refinement *) + +Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". diff --git a/theories/Init.v b/theories/Init.v new file mode 100644 index 0000000000..1d2d40f5c0 --- /dev/null +++ b/theories/Init.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> bool := "ltac2" "int_equal". +Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". +Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". +Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". +Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". +Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/theories/Ltac2.v b/theories/Ltac2.v new file mode 100644 index 0000000000..221f7be424 --- /dev/null +++ b/theories/Ltac2.v @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit := "ltac2" "print". + +Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". + +Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". + +Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/theories/String.v b/theories/String.v new file mode 100644 index 0000000000..99e1dab76b --- /dev/null +++ b/theories/String.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char -> string := "ltac2" "string_make". +Ltac2 @external length : string -> int := "ltac2" "string_length". +Ltac2 @external get : string -> int -> char := "ltac2" "string_get". +Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". -- cgit v1.2.3 From fed8f69b682c03ff901966890efd2d9d3ea91004 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 18:40:27 +0200 Subject: Fix library hardwired prefix. --- src/tac2env.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2env.ml b/src/tac2env.ml index 5ccdd018ee..08c7b321be 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -235,7 +235,7 @@ let interp_ml_object t = MLType.obj t (** Absolute paths *) let coq_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Init"; "ltac2"; "Coq"])) + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) (** Generic arguments *) -- cgit v1.2.3 From 484cf6add4aeb5faaa90f716d5acd2cc2bdf13b3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 18:38:32 +0200 Subject: Adding quick-n-dirty tests. --- tests/ltac2.v | 119 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 tests/ltac2.v diff --git a/tests/ltac2.v b/tests/ltac2.v new file mode 100644 index 0000000000..3d3d0032c5 --- /dev/null +++ b/tests/ltac2.v @@ -0,0 +1,119 @@ +Require Import Ltac2.Ltac2. + +Ltac2 foo (_ : int) := + let f (x : int) := x in + let _ := f 0 in + f 1. + +Print Ltac2 foo. + +Import Control. + +Ltac2 exact x := refine (fun _ => x). + +Print Ltac2 refine. +Print Ltac2 exact. + +Ltac2 foo' _ := ident:(bla). + +Print Ltac2 foo'. + +Ltac2 bar x H := match x with +| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) +| Some x => x +end. + +Print Ltac2 bar. + +Ltac2 qux := Some 0. + +Print Ltac2 qux. + +Ltac2 Type foo := [ Foo (int) ]. + +Fail Ltac2 qux0 := Foo None. + +Ltac2 Type 'a ref := { mutable contents : 'a }. + +Fail Ltac2 qux0 := { contents := None }. +Ltac2 foo0 _ := { contents := None }. + +Print Ltac2 foo0. + +Ltac2 qux0 x := x.(contents). +Ltac2 qux1 x := x.(contents) := x.(contents). + +Ltac2 qux2 := ([1;2], true). + +Print Ltac2 qux0. +Print Ltac2 qux1. +Print Ltac2 qux2. + +Import Control. + +Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun _ => hyp x))). + +Print Ltac2 qux3. + +Ltac2 qux4 f x := x, (f x, x). + +Print Ltac2 qux4. + +Ltac2 Type rec nat := [ O | S (nat) ]. + +Ltac2 message_of_nat n := +let rec aux n := +match n with +| O => Message.of_string "O" +| S n => Message.concat (Message.of_string "S") (aux n) +end in aux n. + +Print Ltac2 message_of_nat. + +Ltac2 numgoals (_ : unit) := + let r := { contents := O } in + enter (fun _ => r.(contents) := S (r.(contents))); + r.(contents). + +Print Ltac2 numgoals. + +Goal True /\ False. +Proof. +let n := numgoals () in Message.print (message_of_nat n). +refine (fun _ => open_constr:((fun x => conj _ _) 0)); (). +let n := numgoals () in Message.print (message_of_nat n). + +Fail (hyp ident:(x)). +Fail (enter (fun _ => hyp ident:(There_is_no_spoon); ())). + +enter (fun _ => Message.print (Message.of_string "foo")). + +enter (fun _ => Message.print (Message.of_constr (goal ()))). +Fail enter (fun _ => Message.print (Message.of_constr (qux3 ident:(x)))). +enter (fun _ => plus (fun _ => constr:(_); ()) (fun _ => ())). +plus + (fun _ => enter (fun _ => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). +let x := { contents := 0 } in +let x := x.(contents) := x.(contents) in x. +Abort. + +Ltac2 Type exn ::= [ Foo ]. + +Goal True. +Proof. +plus (fun _ => zero Foo) (fun _ => ()). +Abort. + +Ltac2 Type exn ::= [ Bar (string) ]. + +Goal True. +Proof. +Fail zero (Bar "lol"). +Abort. + +Ltac2 Notation "refine!" c(constr) := refine c. + +Goal True. +Proof. +refine! I. +Abort. -- cgit v1.2.3 From 2c9233d40d75492fa7f06c09c2bf4f7b16fd1280 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 18:49:10 +0200 Subject: Filling the README. --- README.md | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/README.md b/README.md index e69de29bb2..a5aa40eeb6 100644 --- a/README.md +++ b/README.md @@ -0,0 +1,23 @@ +Overview +======== + +This is a standalone version of the Ltac2 plugin. Ltac2 is an attempt at +providing the Coq users with a tactic language that is more robust and more +expressive than the venerable Ltac langue. + +Status +======== + +It is mostly a toy to experiment for now, and the implementation is quite +bug-ridden. Don't mistake this for a final product! + +Installation +============ + +This should compile with Coq 8.7, assuming the `COQLIB` variable is set +correctly. Standard procedures for `coq_makefile`-generated plugins apply. + +Demo +==== + +Horrible test-files are provided in the `tests` folder. Not for kids. -- cgit v1.2.3 From 5db849e1aa0d543d31389f5b10b6d863fcabce09 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 18:49:19 +0200 Subject: Removing a spurious file. --- vo.itarget | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 vo.itarget diff --git a/vo.itarget b/vo.itarget deleted file mode 100644 index 5777585681..0000000000 --- a/vo.itarget +++ /dev/null @@ -1,8 +0,0 @@ -Init.vo -Int.vo -String.vo -Array.vo -Control.vo -Message.vo -Constr.vo -Ltac2.vo -- cgit v1.2.3 From 1fe83d5d791f0ff91ffa032b556f02c6cc4cbfed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 18:54:02 +0200 Subject: Fix typo. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index a5aa40eeb6..4d6879d8af 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ Overview This is a standalone version of the Ltac2 plugin. Ltac2 is an attempt at providing the Coq users with a tactic language that is more robust and more -expressive than the venerable Ltac langue. +expressive than the venerable Ltac language. Status ======== -- cgit v1.2.3 From a647c38d3024f34711fbaa66975b5812097c33cc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 19:29:09 +0200 Subject: Properly handle parsing of list patterns. --- src/g_ltac2.ml4 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 36057b3a67..6cdbccb11d 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -33,7 +33,11 @@ GEXTEND Gram tac2pat: [ "1" LEFTA [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> CPatRef (!@loc, RelId id, pl) - | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) ] + | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) + | "["; "]" -> CPatRef (!@loc, AbsKn Tac2core.Core.c_nil, []) + | p1 = tac2pat; "::"; p2 = tac2pat -> + CPatRef (!@loc, AbsKn Tac2core.Core.c_cons, [p1; p2]) + ] | "0" [ "_" -> CPatAny (!@loc) | "()" -> CPatTup (Loc.tag ~loc:!@loc []) -- cgit v1.2.3 From fbfe239730bd5069026ae4e5356e93d3f3bfcb53 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 19:37:03 +0200 Subject: Correctly pushing variables for tuple patterns. --- src/tac2intern.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index b63e6a0cd8..ffbdaf4b9b 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -817,11 +817,13 @@ and intern_case env loc e pl = end | p -> todo ~loc:(loc_of_patexpr p) () in - let ids = Array.map_of_list map pl in - let tc = GTypTuple (List.map (fun _ -> GTypVar (fresh_id env)) pl) in + let ids = List.map map pl in + let targs = List.map (fun _ -> GTypVar (fresh_id env)) pl in + let tc = GTypTuple targs in let () = unify ~loc:(loc_of_tacexpr e) env t tc in + let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env ids targs in let (b, tb) = intern_rec env b in - (GTacCse (e', GCaseTuple len, [||], [|ids, b|]), tb) + (GTacCse (e', GCaseTuple len, [||], [|Array.of_list ids, b|]), tb) | (p, _) :: _ -> todo ~loc:(loc_of_patexpr p) () end | PKind_variant kn -> -- cgit v1.2.3 From 41cea8603b35a1af405650d8a2b9aaa89a445367 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 24 Jul 2017 19:00:29 +0200 Subject: Adding a few primitive functions. --- src/tac2core.ml | 197 +++++++++++++++++++++++++++++++++++++++++++++++++++-- src/tac2core.mli | 9 +++ tests/ltac2.v | 12 ++++ theories/Constr.v | 16 ++--- theories/Control.v | 7 ++ theories/Init.v | 2 + theories/Message.v | 2 + 7 files changed, 233 insertions(+), 12 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 91a3bfa168..13aa44c815 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -27,6 +27,15 @@ let val_tag t = match val_tag t with let val_constr = val_tag (topwit Stdarg.wit_constr) let val_ident = val_tag (topwit Stdarg.wit_ident) let val_pp = Val.create "ltac2:pp" +let val_sort = Val.create "ltac2:sort" +let val_cast = Val.create "ltac2:cast" +let val_inductive = Val.create "ltac2:inductive" +let val_constant = Val.create "ltac2:constant" +let val_constructor = Val.create "ltac2:constructor" +let val_projection = Val.create "ltac2:projection" +let val_univ = Val.create "ltac2:universe" +let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ = + Val.create "ltac2:kont" let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = match Val.eq tag tag' with @@ -121,9 +130,39 @@ let to_exn c = match c with | ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) | _ -> to_ext val_exn c +let of_option = function +| None -> ValInt 0 +| Some c -> ValBlk (0, [|c|]) + +let to_option = function +| ValInt 0 -> None +| ValBlk (0, [|c|]) -> Some c +| _ -> assert false + let of_pp c = of_ext val_pp c let to_pp c = to_ext val_pp c +let of_tuple cl = ValBlk (0, cl) +let to_tuple = function +| ValBlk (0, cl) -> cl +| _ -> assert false + +let of_array = of_tuple +let to_array = to_tuple + +let of_name c = match c with +| Anonymous -> of_option None +| Name id -> of_option (Some (of_ident id)) + +let of_instance sigma u = + let u = Univ.Instance.to_array (EConstr.EInstance.kind sigma u) in + of_array (Array.map (fun v -> of_ext val_univ v) u) + +let of_rec_declaration (nas, ts, cs) = + (of_array (Array.map of_name nas), + of_array (Array.map of_constr ts), + of_array (Array.map of_constr cs)) + end let val_valexpr = Val.create "ltac2:valexpr" @@ -174,11 +213,11 @@ let prm_print : ml_tactic = function | _ -> assert false let prm_message_of_int : ml_tactic = function -| [ValInt s] -> return (ValExt (Val.Dyn (val_pp, int s))) +| [ValInt s] -> return (Value.of_pp (int s)) | _ -> assert false let prm_message_of_string : ml_tactic = function -| [ValStr s] -> return (ValExt (Val.Dyn (val_pp, str (Bytes.to_string s)))) +| [ValStr s] -> return (Value.of_pp (str (Bytes.to_string s))) | _ -> assert false let prm_message_of_constr : ml_tactic = function @@ -186,10 +225,17 @@ let prm_message_of_constr : ml_tactic = function pf_apply begin fun env sigma -> let c = Value.to_constr c in let pp = Printer.pr_econstr_env env sigma c in - return (ValExt (Val.Dyn (val_pp, pp))) + return (Value.of_pp pp) end | _ -> assert false +let prm_message_of_ident : ml_tactic = function +| [c] -> + let c = Value.to_ident c in + let pp = Id.print c in + return (Value.of_pp pp) +| _ -> assert false + let prm_message_concat : ml_tactic = function | [m1; m2] -> let m1 = Value.to_pp m1 in @@ -298,6 +344,101 @@ let prm_constr_equal : ml_tactic = function Proofview.tclUNIT (Value.of_bool b) | _ -> assert false +let prm_constr_kind : ml_tactic = function +| [c] -> + let open Constr in + Proofview.tclEVARMAP >>= fun sigma -> + let c = Value.to_constr c in + return begin match EConstr.kind sigma c with + | Rel n -> + ValBlk (0, [|Value.of_int n|]) + | Var id -> + ValBlk (1, [|Value.of_ident id|]) + | Meta n -> + ValBlk (2, [|Value.of_int n|]) + | Evar (evk, args) -> + ValBlk (3, [| + Value.of_int (Evar.repr evk); + Value.of_array (Array.map Value.of_constr args) + |]) + | Sort s -> + ValBlk (4, [|Value.of_ext val_sort s|]) + | Cast (c, k, t) -> + ValBlk (5, [| + Value.of_constr c; + Value.of_ext val_cast k; + Value.of_constr t; + |]) + | Prod (na, t, u) -> + ValBlk (6, [| + Value.of_name na; + Value.of_constr t; + Value.of_constr u; + |]) + | Lambda (na, t, c) -> + ValBlk (7, [| + Value.of_name na; + Value.of_constr t; + Value.of_constr c; + |]) + | LetIn (na, b, t, c) -> + ValBlk (8, [| + Value.of_name na; + Value.of_constr b; + Value.of_constr t; + Value.of_constr c; + |]) + | App (c, cl) -> + ValBlk (9, [| + Value.of_constr c; + Value.of_array (Array.map Value.of_constr cl) + |]) + | Const (cst, u) -> + ValBlk (10, [| + Value.of_ext val_constant cst; + Value.of_instance sigma u; + |]) + | Ind (ind, u) -> + ValBlk (11, [| + Value.of_ext val_inductive ind; + Value.of_instance sigma u; + |]) + | Construct (cstr, u) -> + ValBlk (12, [| + Value.of_ext val_constructor cstr; + Value.of_instance sigma u; + |]) + | Case (_, c, t, bl) -> + ValBlk (13, [| + Value.of_constr c; + Value.of_constr t; + Value.of_array (Array.map (fun c -> Value.of_constr c) bl); + |]) + | Fix ((recs, i), def) -> + let (nas, ts, cs) = Value.of_rec_declaration def in + ValBlk (14, [| + Value.of_array (Array.map Value.of_int recs); + Value.of_int i; + nas; + ts; + cs; + |]) + | CoFix (i, def) -> + let (nas, ts, cs) = Value.of_rec_declaration def in + ValBlk (15, [| + Value.of_int i; + nas; + ts; + cs; + |]) + | Proj (p, c) -> + ValBlk (16, [| + Value.of_ext val_projection p; + Value.of_constr c; + |]) + end +| _ -> assert false + (** Error *) let prm_throw : ml_tactic = function @@ -315,7 +456,7 @@ let prm_zero : ml_tactic = function Proofview.tclZERO ~info e | _ -> assert false -(** exn -> 'a *) +(** (unit -> 'a) -> (exn -> 'a) -> 'a *) let prm_plus : ml_tactic = function | [x; k] -> Proofview.tclOR (thaw x) (fun e -> interp_app k [Value.of_exn e]) @@ -352,6 +493,30 @@ let prm_enter : ml_tactic = function Proofview.tclINDEPENDENT f >>= fun () -> return v_unit | _ -> assert false +let k_var = Id.of_string "k" +let e_var = Id.of_string "e" +let prm_apply_kont_h = pname "apply_kont" + +(** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) +let prm_case : ml_tactic = function +| [f] -> + Proofview.tclCASE (thaw f) >>= begin function + | Proofview.Next (x, k) -> + let k = { + clos_env = Id.Map.singleton k_var (Value.of_ext val_kont k); + clos_var = [Name e_var]; + clos_exp = GTacPrm (prm_apply_kont_h, [GTacVar k_var; GTacVar e_var]); + } in + return (ValBlk (0, [| Value.of_tuple [| x; ValCls k |] |])) + | Proofview.Fail e -> return (ValBlk (1, [| Value.of_exn e |])) + end +| _ -> assert false + +(** 'a kont -> exn -> 'a *) +let prm_apply_kont : ml_tactic = function +| [k; e] -> (Value.to_ext val_kont k) (Value.to_exn e) +| _ -> assert false + (** int -> int -> (unit -> 'a) -> 'a *) let prm_focus : ml_tactic = function | [i; j; tac] -> @@ -400,6 +565,25 @@ let prm_hyp : ml_tactic = function end | _ -> assert false +let prm_hyps : ml_tactic = function +| [_] -> + pf_apply begin fun env _ -> + let open Context.Named.Declaration in + let hyps = Environ.named_context env in + let map = function + | LocalAssum (id, t) -> + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id; Value.of_option None; Value.of_constr t|] + | LocalDef (id, c, t) -> + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id; Value.of_option (Some (Value.of_constr c)); Value.of_constr t|] + in + let hyps = List.rev_map map hyps in + return (Value.of_list hyps) + end +| _ -> assert false + (** (unit -> constr) -> unit *) let prm_refine : ml_tactic = function | [c] -> @@ -416,6 +600,7 @@ let () = Tac2env.define_primitive (pname "print") prm_print let () = Tac2env.define_primitive (pname "message_of_string") prm_message_of_string let () = Tac2env.define_primitive (pname "message_of_int") prm_message_of_int let () = Tac2env.define_primitive (pname "message_of_constr") prm_message_of_constr +let () = Tac2env.define_primitive (pname "message_of_ident") prm_message_of_ident let () = Tac2env.define_primitive (pname "message_concat") prm_message_concat let () = Tac2env.define_primitive (pname "array_make") prm_array_make @@ -430,6 +615,7 @@ let () = Tac2env.define_primitive (pname "string_set") prm_string_set let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal +let () = Tac2env.define_primitive (pname "constr_kind") prm_constr_kind let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare @@ -446,6 +632,8 @@ let () = Tac2env.define_primitive (pname "once") prm_once let () = Tac2env.define_primitive (pname "dispatch") prm_dispatch let () = Tac2env.define_primitive (pname "extend") prm_extend let () = Tac2env.define_primitive (pname "enter") prm_enter +let () = Tac2env.define_primitive (pname "case") prm_case +let () = Tac2env.define_primitive (pname "apply_kont") prm_apply_kont let () = Tac2env.define_primitive (pname "focus") prm_focus let () = Tac2env.define_primitive (pname "shelve") prm_shelve @@ -453,6 +641,7 @@ let () = Tac2env.define_primitive (pname "shelve_unifiable") prm_shelve_unifiabl let () = Tac2env.define_primitive (pname "new_goal") prm_new_goal let () = Tac2env.define_primitive (pname "goal") prm_goal let () = Tac2env.define_primitive (pname "hyp") prm_hyp +let () = Tac2env.define_primitive (pname "hyps") prm_hyps let () = Tac2env.define_primitive (pname "refine") prm_refine (** ML types *) diff --git a/src/tac2core.mli b/src/tac2core.mli index fc90499ac6..41c79b2c65 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -59,4 +59,13 @@ val to_exn : valexpr -> Exninfo.iexn val of_ident : Id.t -> valexpr val to_ident : valexpr -> Id.t +val of_array : valexpr array -> valexpr +val to_array : valexpr -> valexpr array + +val of_tuple : valexpr array -> valexpr +val to_tuple : valexpr -> valexpr array + +val of_option : valexpr option -> valexpr +val to_option : valexpr -> valexpr option + end diff --git a/tests/ltac2.v b/tests/ltac2.v index 3d3d0032c5..770d385406 100644 --- a/tests/ltac2.v +++ b/tests/ltac2.v @@ -117,3 +117,15 @@ Goal True. Proof. refine! I. Abort. + +Goal True. +Proof. +let x _ := plus (fun _ => 0) (fun _ => 1) in +match case x with +| Val x => + match x with + | (x, k) => Message.print (Message.of_int (k Not_found)) + end +| Err x => Message.print (Message.of_string "Err") +end. +Abort. diff --git a/theories/Constr.v b/theories/Constr.v index c340e3aa87..d7cd3b58a3 100644 --- a/theories/Constr.v +++ b/theories/Constr.v @@ -16,28 +16,28 @@ Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". Module Unsafe. -(** Low-level access to kernel term. Use with care! *) +(** Low-level access to kernel terms. Use with care! *) Ltac2 Type kind := [ | Rel (int) | Var (ident) | Meta (meta) -| Evar (evar, constr list) +| Evar (evar, constr array) | Sort (sort) | Cast (constr, cast, constr) | Prod (ident option, constr, constr) | Lambda (ident option, constr, constr) | LetIn (ident option, constr, constr, constr) -| App (constr, constr list) +| App (constr, constr array) | Constant (constant, instance) | Ind (inductive, instance) | Constructor (inductive, instance) -(* - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint -*) +| Case (constr, constr, constr array) +| Fix (int array, int, ident option array, constr array, constr array) +| CoFix (int, ident option array, constr array, constr array) | Proj (projection, constr) ]. +Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". + End Unsafe. diff --git a/theories/Control.v b/theories/Control.v index 3bc572547c..a6d46a89a8 100644 --- a/theories/Control.v +++ b/theories/Control.v @@ -21,6 +21,7 @@ Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". +Ltac2 @ external case : (unit -> 'a) -> ('a * (exn -> 'a)) result := "ltac2" "case". (** Proof state manipulation *) @@ -44,6 +45,12 @@ Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". goal under focus, looks for the section variable with the given name. If there is one, looks for the hypothesis with the given name. *) +Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" "hyps". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, returns the list of section variables. + If there is one, returns the list of hypotheses. In both cases, the + list is ordered with rightmost values being last introduced. *) + (** Refinement *) Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". diff --git a/theories/Init.v b/theories/Init.v index 1d2d40f5c0..c0a73576d3 100644 --- a/theories/Init.v +++ b/theories/Init.v @@ -41,6 +41,8 @@ Ltac2 Type 'a ref := { mutable contents : 'a }. Ltac2 Type bool := [ true | false ]. +Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. + (** Pervasive exceptions *) Ltac2 Type exn ::= [ Out_of_bounds ]. diff --git a/theories/Message.v b/theories/Message.v index b2159612cb..45f4b221db 100644 --- a/theories/Message.v +++ b/theories/Message.v @@ -14,6 +14,8 @@ Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". +Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". + Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". (** Panics if there is more than one goal under focus. *) -- cgit v1.2.3 From 5748cd3a913eec7a24600715fc9b71044a7c38b1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 25 Jul 2017 12:27:31 +0200 Subject: Generalizing patterns in fun bindings. --- src/g_ltac2.ml4 | 4 ++-- src/tac2core.ml | 2 +- src/tac2expr.mli | 2 +- src/tac2intern.ml | 44 ++++++++++++++++++++++++++++++++++++++------ 4 files changed, 42 insertions(+), 10 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 6cdbccb11d..47def14125 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -125,8 +125,8 @@ GEXTEND Gram | l = Prim.ident -> Loc.tag ~loc:!@loc (Name l) ] ] ; input_fun: - [ [ b = binder -> (b, None) - | "("; b = binder; ":"; t = tac2type; ")" -> (b, Some t) ] ] + [ [ b = tac2pat LEVEL "0" -> (b, None) + | "("; b = tac2pat; t = OPT [ ":"; t = tac2type -> t ]; ")" -> (b, t) ] ] ; tac2def_body: [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> diff --git a/src/tac2core.ml b/src/tac2core.ml index 13aa44c815..b665f761ce 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -734,7 +734,7 @@ let dummy_loc = Loc.make_loc (-1, -1) let rthunk e = let loc = Tac2intern.loc_of_tacexpr e in - let var = [Loc.tag ~loc Anonymous, Some (CTypRef (loc, AbsKn Core.t_unit, []))] in + let var = [CPatAny loc, Some (CTypRef (loc, AbsKn Core.t_unit, []))] in CTacFun (loc, var, e) let add_generic_scope s entry arg = diff --git a/src/tac2expr.mli b/src/tac2expr.mli index acdad9bab4..a9f2109cb2 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -83,7 +83,7 @@ type raw_patexpr = type raw_tacexpr = | CTacAtm of atom located | CTacRef of tacref or_relid -| CTacFun of Loc.t * (Name.t located * raw_typexpr option) list * raw_tacexpr +| CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list | CTacLet of Loc.t * rec_flag * (Name.t located * raw_typexpr option * raw_tacexpr) list * raw_tacexpr | CTacTup of raw_tacexpr list located diff --git a/src/tac2intern.ml b/src/tac2intern.ml index ffbdaf4b9b..b0ba9adf5e 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -585,6 +585,14 @@ let is_constructor env qid = match get_variable env qid with | ArgArg (TacConstructor _) -> true | _ -> false +(** Used to generate a fresh tactic variable for pattern-expansion *) +let fresh_var env = + let bad id = + Id.Map.mem id env.env_var || + (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string "p") bad + let rec intern_rec env = function | CTacAtm (_, atm) -> intern_atm env atm | CTacRef qid as e -> @@ -600,16 +608,24 @@ let rec intern_rec env = function intern_constructor env loc kn [] end | CTacFun (loc, bnd, e) -> - let fold (env, bnd, tl) ((_, na), t) = + let fold (env, bnd, tl) (pat, t) = let t = match t with | None -> GTypVar (fresh_id env) | Some t -> intern_type env t in - let env = push_name na (monomorphic t) env in - (env, na :: bnd, t :: tl) + let id = fresh_var env in + let env = push_name (Name id) (monomorphic t) env in + (env, (id, pat) :: bnd, t :: tl) in let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in - let bnd = List.rev bnd in + (** Expand pattern: [fun p => t] becomes [fun x => match x with p => t end] *) + let fold e (id, pat) = + let loc = loc_of_patexpr pat in + let qid = RelId (Loc.tag ~loc (qualid_of_ident id)) in + CTacCse (loc, CTacRef qid, [pat, e]) + in + let e = List.fold_left fold e bnd in + let bnd = List.rev_map (fun (id, _) -> Name id) bnd in let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in (GTacFun (bnd, e), t) @@ -1125,6 +1141,17 @@ let get_projection0 var = match var with kn | AbsKn kn -> kn +let rec ids_of_pattern accu = function +| CPatAny _ -> accu +| CPatRef (_, RelId (_, qid), pl) -> + let (dp, id) = repr_qualid qid in + let accu = if DirPath.is_empty dp then Id.Set.add id accu else accu in + List.fold_left ids_of_pattern accu pl +| CPatRef (_, AbsKn _, pl) -> + List.fold_left ids_of_pattern accu pl +| CPatTup (_, pl) -> + List.fold_left ids_of_pattern accu pl + let rec globalize ids e = match e with | CTacAtm _ -> e | CTacRef ref -> @@ -1134,8 +1161,13 @@ let rec globalize ids e = match e with | ArgArg kn -> CTacRef (AbsKn kn) end | CTacFun (loc, bnd, e) -> - let fold accu ((_, na), _) = add_name accu na in - let ids = List.fold_left fold ids bnd in + let fold (pats, accu) (pat, t) = + let accu = ids_of_pattern accu pat in + let pat = globalize_pattern ids pat in + ((pat, t) :: pats, accu) + in + let bnd, ids = List.fold_left fold ([], ids) bnd in + let bnd = List.rev bnd in let e = globalize ids e in CTacFun (loc, bnd, e) | CTacApp (loc, e, el) -> -- cgit v1.2.3 From a3da80680400610ffe8d7de33d9ca1ee1106ae28 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 00:32:50 +0200 Subject: Bugfix: wrong access to non-constant constructor compilation. --- src/tac2intern.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index b0ba9adf5e..06f04c4c3d 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -874,7 +874,7 @@ and intern_case env loc e pl = (succ ncst, narg) else let () = - if Option.is_empty const.(narg) then + if Option.is_empty nonconst.(narg) then let ids = Array.map_of_list (fun _ -> Anonymous) args in nonconst.(narg) <- Some (ids, br') in -- cgit v1.2.3 From bbf4ee2fe5072fa0bb639dce649c16fdd76f44b0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 25 Jul 2017 23:43:26 +0200 Subject: Exporting some basic tactics from Ltac1. --- _CoqProject | 3 + src/ltac2_plugin.mlpack | 1 + src/tac2stdlib.ml | 166 ++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2stdlib.mli | 9 +++ theories/Ltac2.v | 1 + theories/Std.v | 59 +++++++++++++++++ 6 files changed, 239 insertions(+) create mode 100644 src/tac2stdlib.ml create mode 100644 src/tac2stdlib.mli create mode 100644 theories/Std.v diff --git a/_CoqProject b/_CoqProject index 90338abbfb..6d3470cfa7 100644 --- a/_CoqProject +++ b/_CoqProject @@ -15,6 +15,8 @@ src/tac2entries.ml src/tac2entries.mli src/tac2core.ml src/tac2core.mli +src/tac2stdlib.ml +src/tac2stdlib.mli src/g_ltac2.ml4 src/ltac2_plugin.mlpack @@ -25,4 +27,5 @@ theories/Array.v theories/Control.v theories/Message.v theories/Constr.v +theories/Std.v theories/Ltac2.v diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 3d87a8cddb..dc78207291 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -4,4 +4,5 @@ Tac2intern Tac2interp Tac2entries Tac2core +Tac2stdlib G_ltac2 diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml new file mode 100644 index 0000000000..89a8d98693 --- /dev/null +++ b/src/tac2stdlib.ml @@ -0,0 +1,166 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* return v_unit + +let wrap f = + return () >>= fun () -> return (f ()) + +let wrap_unit f = + return () >>= fun () -> f (); return v_unit + +let define_prim0 name tac = + let tac = function + | [_] -> lift tac + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + +let define_prim1 name tac = + let tac = function + | [x] -> lift (tac x) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + +let define_prim2 name tac = + let tac = function + | [x; y] -> lift (tac x y) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + +(** Tactics from coretactics *) + +let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity + +(* + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + +*) + +let () = define_prim0 "tac_assumption" Tactics.assumption + +let () = define_prim1 "tac_transitivity" begin fun c -> + let c = Value.to_constr c in + Tactics.intros_transitivity (Some c) +end + +let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) + +let () = define_prim1 "tac_cut" begin fun c -> + let c = Value.to_constr c in + Tactics.cut c +end + +let () = define_prim0 "tac_left" (Tactics.left_with_bindings false NoBindings) +let () = define_prim0 "tac_eleft" (Tactics.left_with_bindings true NoBindings) +let () = define_prim0 "tac_right" (Tactics.right_with_bindings false NoBindings) +let () = define_prim0 "tac_eright" (Tactics.right_with_bindings true NoBindings) + +let () = define_prim1 "tac_exactnocheck" begin fun c -> + Tactics.exact_no_check (Value.to_constr c) +end + +let () = define_prim1 "tac_vmcastnocheck" begin fun c -> + Tactics.vm_cast_no_check (Value.to_constr c) +end + +let () = define_prim1 "tac_nativecastnocheck" begin fun c -> + Tactics.native_cast_no_check (Value.to_constr c) +end + +let () = define_prim0 "tac_constructor" (Tactics.any_constructor false None) +let () = define_prim0 "tac_econstructor" (Tactics.any_constructor true None) + +let () = define_prim1 "tac_constructorn" begin fun n -> + let n = Value.to_int n in + Tactics.constructor_tac false None n NoBindings +end + +let () = define_prim1 "tac_econstructorn" begin fun n -> + let n = Value.to_int n in + Tactics.constructor_tac true None n NoBindings +end + +let () = define_prim0 "tac_symmetry" (Tactics.intros_symmetry Locusops.onConcl) + +let () = define_prim0 "tac_split" (Tactics.split_with_bindings false [NoBindings]) +let () = define_prim0 "tac_esplit" (Tactics.split_with_bindings true [NoBindings]) + +let () = define_prim1 "tac_rename" begin fun ids -> + let ids = Value.to_list ids in + let map c = match Value.to_tuple c with + | [|x; y|] -> (Value.to_ident x, Value.to_ident y) + | _ -> assert false + in + let ids = List.map map ids in + Tactics.rename_hyp ids +end + +let () = define_prim1 "tac_revert" begin fun ids -> + let ids = List.map Value.to_ident (Value.to_list ids) in + Tactics.revert ids +end + +let () = define_prim0 "tac_admit" Proofview.give_up + +let () = define_prim2 "tac_fix" begin fun idopt n -> + let idopt = Option.map Value.to_ident (Value.to_option idopt) in + let n = Value.to_int n in + Tactics.fix idopt n +end + +let () = define_prim1 "tac_cofix" begin fun idopt -> + let idopt = Option.map Value.to_ident (Value.to_option idopt) in + Tactics.cofix idopt +end + +let () = define_prim1 "tac_clear" begin fun ids -> + let ids = List.map Value.to_ident (Value.to_list ids) in + Tactics.clear ids +end + +let () = define_prim1 "tac_keep" begin fun ids -> + let ids = List.map Value.to_ident (Value.to_list ids) in + Tactics.keep ids +end + +let () = define_prim1 "tac_clearbody" begin fun ids -> + let ids = List.map Value.to_ident (Value.to_list ids) in + Tactics.clear_body ids +end + +(** Tactics from extratactics *) + +let () = define_prim1 "tac_absurd" begin fun c -> + Contradiction.absurd (Value.to_constr c) +end + +let () = define_prim1 "tac_subst" begin fun ids -> + let ids = List.map Value.to_ident (Value.to_list ids) in + Equality.subst ids +end + +let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) diff --git a/src/tac2stdlib.mli b/src/tac2stdlib.mli new file mode 100644 index 0000000000..927b57074d --- /dev/null +++ b/src/tac2stdlib.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit := "ltac2" "tac_reflexivity". + +Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". + +Ltac2 @ external transitivity : constr -> unit := "ltac2" "tac_transitivity". + +Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". + +Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". + +Ltac2 @ external left : unit -> unit := "ltac2" "tac_left". +Ltac2 @ external eleft : unit -> unit := "ltac2" "tac_eleft". +Ltac2 @ external right : unit -> unit := "ltac2" "tac_right". +Ltac2 @ external eright : unit -> unit := "ltac2" "tac_eright". + +Ltac2 @ external constructor : unit -> unit := "ltac2" "tac_constructor". +Ltac2 @ external econstructor : unit -> unit := "ltac2" "tac_econstructor". +Ltac2 @ external split : unit -> unit := "ltac2" "tac_split". +Ltac2 @ external esplit : unit -> unit := "ltac2" "tac_esplit". + +Ltac2 @ external constructor_n : int -> unit := "ltac2" "tac_constructorn". +Ltac2 @ external econstructor_n : int -> unit := "ltac2" "tac_econstructorn". + +Ltac2 @ external symmetry : unit -> unit := "ltac2" "tac_symmetry". + +Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". + +Ltac2 @ external revert : ident list -> unit := "ltac2" "tac_revert". + +Ltac2 @ external admit : unit -> unit := "ltac2" "tac_admit". + +Ltac2 @ external fix_ : ident option -> int -> unit := "ltac2" "tac_fix". +Ltac2 @ external cofix_ : ident option -> unit := "ltac2" "tac_cofix". + +Ltac2 @ external clear : ident list -> unit := "ltac2" "tac_clear". +Ltac2 @ external keep : ident list -> unit := "ltac2" "tac_keep". + +Ltac2 @ external clearbody : ident list -> unit := "ltac2" "tac_clearbody". + +Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". +Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". +Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". + +Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". + +Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". +Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". -- cgit v1.2.3 From 93b5d42467dae8513ad7da4990f909bcc9f5b7fa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 13:30:58 +0200 Subject: Properly handling toplevel recursive definitions. --- src/tac2entries.ml | 124 +++++++++++++++++++++++++++++++++-------------------- src/tac2intern.mli | 1 + 2 files changed, 79 insertions(+), 46 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 46f390a6d4..100041f15e 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -241,56 +241,88 @@ let inTypExt : typext -> obj = let dummy_loc = Loc.make_loc (-1, -1) +let fresh_var avoid x = + let bad id = + Id.Set.mem id avoid || + (try ignore (Tac2env.locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string x) bad + +(** Mangle recursive tactics *) +let inline_rec_tactic tactics = + let avoid = List.fold_left (fun accu ((_, id), _) -> Id.Set.add id accu) Id.Set.empty tactics in + let map (id, e) = match e with + | CTacFun (loc, pat, _) -> (id, pat, e) + | _ -> + let loc, _ = id in + user_err ?loc (str "Recursive tactic definitions must be functions") + in + let tactics = List.map map tactics in + let map (id, pat, e) = + let fold_var (avoid, ans) (pat, _) = + let id = fresh_var avoid "x" in + let loc = loc_of_patexpr pat in + (Id.Set.add id avoid, Loc.tag ~loc id :: ans) + in + (** Fresh variables to abstract over the function patterns *) + let _, vars = List.fold_left fold_var (avoid, []) pat in + let map_body ((loc, id), _, e) = (loc, Name id), None, e in + let bnd = List.map map_body tactics in + let pat_of_id (loc, id) = + let qid = (loc, qualid_of_ident id) in + (CPatRef (Option.default dummy_loc loc, RelId qid, []), None) + in + let var_of_id (loc, id) = + let qid = (loc, qualid_of_ident id) in + CTacRef (RelId qid) + in + let loc0 = loc_of_tacexpr e in + let vpat = List.map pat_of_id vars in + let varg = List.map var_of_id vars in + let e = CTacLet (loc0, true, bnd, CTacApp (loc0, var_of_id id, varg)) in + (id, CTacFun (loc0, vpat, e)) + in + List.map map tactics + let register_ltac ?(local = false) isrec tactics = - if isrec then - let map (na, e) = (na, None, e) in - let bindings = List.map map tactics in - let map ((loc, na), e) = match na with - | Anonymous -> None - | Name id -> - let qid = Libnames.qualid_of_ident id in - let e = CTacLet (dummy_loc, true, bindings, CTacRef (RelId (loc, qid))) in - let (e, t) = intern e in - let e = match e with - | GTacLet (true, _, e) -> assert false - | _ -> assert false - in - Some (e, t) + let map ((loc, na), e) = + let id = match na with + | Anonymous -> + user_err ?loc (str "Tactic definition must have a name") + | Name id -> id in - let tactics = List.map map tactics in - assert false (** FIXME *) - else - let map ((loc, na), e) = - let (e, t) = intern e in - let () = - if not (is_value e) then - user_err ?loc (str "Tactic definition must be a syntactical value") - in - let id = match na with - | Anonymous -> - user_err ?loc (str "Tactic definition must have a name") - | Name id -> id - in - let kn = Lib.make_kn id in - let exists = - try let _ = Tac2env.interp_global kn in true with Not_found -> false - in - let () = - if exists then - user_err ?loc (str "Tactic " ++ Nameops.pr_id id ++ str " already exists") - in - (id, e, t) + ((loc, id), e) + in + let tactics = List.map map tactics in + let tactics = + if isrec then inline_rec_tactic tactics else tactics + in + let map ((loc, id), e) = + let (e, t) = intern e in + let () = + if not (is_value e) then + user_err ?loc (str "Tactic definition must be a syntactical value") in - let defs = List.map map tactics in - let iter (id, e, t) = - let def = { - tacdef_local = local; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) + let kn = Lib.make_kn id in + let exists = + try let _ = Tac2env.interp_global kn in true with Not_found -> false in - List.iter iter defs + let () = + if exists then + user_err ?loc (str "Tactic " ++ Nameops.pr_id id ++ str " already exists") + in + (id, e, t) + in + let defs = List.map map tactics in + let iter (id, e, t) = + let def = { + tacdef_local = local; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + in + List.iter iter defs let qualid_to_ident (loc, qid) = let (dp, id) = Libnames.repr_qualid qid in diff --git a/src/tac2intern.mli b/src/tac2intern.mli index 3d400a5cdd..b2604c4ea7 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -12,6 +12,7 @@ open Mod_subst open Tac2expr val loc_of_tacexpr : raw_tacexpr -> Loc.t +val loc_of_patexpr : raw_patexpr -> Loc.t val intern : raw_tacexpr -> glb_tacexpr * type_scheme val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef -- cgit v1.2.3 From edb9a5dd11520804d65e9b1e95ca38bb4acbb0e6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 16:01:52 +0200 Subject: Lightweight quotation syntax for terms and idents. --- src/g_ltac2.ml4 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 47def14125..605cb75d66 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -91,6 +91,8 @@ GEXTEND Gram [ [ n = Prim.integer -> CTacAtm (Loc.tag ~loc:!@loc (AtmInt n)) | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) | id = Prim.qualid -> CTacRef (RelId id) + | "@"; id = Prim.ident -> inj_ident !@loc id + | "'"; c = Constr.constr -> inj_open_constr !@loc c | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c -- cgit v1.2.3 From b13693a39014d727787c003c6d445c3bb6f2aef6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 16:11:32 +0200 Subject: Better typing errors for function types. --- src/tac2intern.ml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 06f04c4c3d..5d443dbfcb 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -358,6 +358,28 @@ let unify ?loc env t1 t2 = user_err ?loc (str "This expression has type " ++ pr_glbtype name t1 ++ str " but an expression what expected of type " ++ pr_glbtype name t2) +let unify_arrow ?loc env ft args = + let ft0 = ft in + let rec iter ft args is_fun = match kind env ft, args with + | t, [] -> t + | GTypArrow (t1, ft), (loc, t2) :: args -> + let () = unify ~loc env t1 t2 in + iter ft args true + | GTypVar id, (_, t) :: args -> + let ft = GTypVar (fresh_id env) in + let () = unify_var env id (GTypArrow (t, ft)) in + iter ft args true + | (GTypRef _ | GTypTuple _), _ :: _ -> + let name = env_name env in + if is_fun then + user_err ?loc (str "This function has type " ++ pr_glbtype name ft0 ++ + str " and is applied to too many arguments") + else + user_err ?loc (str "This expression has type " ++ pr_glbtype name ft0 ++ + str " and is not a function") + in + iter ft args false + (** Term typing *) let is_pure_constructor kn = @@ -637,14 +659,15 @@ let rec intern_rec env = function let loc = loc_of_tacexpr e in intern_constructor env loc kn args | CTacApp (loc, f, args) -> + let loc = loc_of_tacexpr f in let (f, ft) = intern_rec env f in let fold arg (args, t) = + let loc = loc_of_tacexpr arg in let (arg, argt) = intern_rec env arg in - (arg :: args, GTypArrow (argt, t)) + (arg :: args, (loc, argt) :: t) in - let ret = GTypVar (fresh_id env) in - let (args, t) = List.fold_right fold args ([], ret) in - let () = unify ~loc env ft t in + let (args, t) = List.fold_right fold args ([], []) in + let ret = unify_arrow ~loc env ft t in (GTacApp (f, args), ret) | CTacLet (loc, false, el, e) -> let fold accu ((loc, na), _, _) = match na with -- cgit v1.2.3 From cfb181899cdd076fb7f2e061089ba76067e47ccc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 16:34:09 +0200 Subject: Fix typo in error message --- src/tac2intern.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 5d443dbfcb..79e33f3a94 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -356,14 +356,14 @@ let unify ?loc env t1 t2 = with CannotUnify (u1, u2) -> let name = env_name env in user_err ?loc (str "This expression has type " ++ pr_glbtype name t1 ++ - str " but an expression what expected of type " ++ pr_glbtype name t2) + str " but an expression was expected of type " ++ pr_glbtype name t2) let unify_arrow ?loc env ft args = let ft0 = ft in let rec iter ft args is_fun = match kind env ft, args with | t, [] -> t | GTypArrow (t1, ft), (loc, t2) :: args -> - let () = unify ~loc env t1 t2 in + let () = unify ~loc env t2 t1 in iter ft args true | GTypVar id, (_, t) :: args -> let ft = GTypVar (fresh_id env) in -- cgit v1.2.3 From 2a74da7b6f275634fd8ed9c209edc73f2ae15427 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 16:38:52 +0200 Subject: Adding a file for testing typing. --- Makefile | 4 ++ tests/Makefile | 7 +++ tests/ltac2.v | 131 ---------------------------------------------------- tests/stuff/ltac2.v | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/typing.v | 25 ++++++++++ 5 files changed, 167 insertions(+), 131 deletions(-) create mode 100644 tests/Makefile delete mode 100644 tests/ltac2.v create mode 100644 tests/stuff/ltac2.v create mode 100644 tests/typing.v diff --git a/Makefile b/Makefile index cfdeeba747..d555fea236 100644 --- a/Makefile +++ b/Makefile @@ -10,3 +10,7 @@ clean: Makefile.coq Makefile.coq: _CoqProject $(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 index 0000000000..a48ab0860f --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,7 @@ +all: $(patsubst %.v,%.v.log,$(wildcard *.v)) + +%.v.log: %.v + $(COQBIN)/coqtop -I ../src -Q ../theories Ltac2 < $< 2> $@ + +clean: + rm -f *.log diff --git a/tests/ltac2.v b/tests/ltac2.v deleted file mode 100644 index 770d385406..0000000000 --- a/tests/ltac2.v +++ /dev/null @@ -1,131 +0,0 @@ -Require Import Ltac2.Ltac2. - -Ltac2 foo (_ : int) := - let f (x : int) := x in - let _ := f 0 in - f 1. - -Print Ltac2 foo. - -Import Control. - -Ltac2 exact x := refine (fun _ => x). - -Print Ltac2 refine. -Print Ltac2 exact. - -Ltac2 foo' _ := ident:(bla). - -Print Ltac2 foo'. - -Ltac2 bar x H := match x with -| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) -| Some x => x -end. - -Print Ltac2 bar. - -Ltac2 qux := Some 0. - -Print Ltac2 qux. - -Ltac2 Type foo := [ Foo (int) ]. - -Fail Ltac2 qux0 := Foo None. - -Ltac2 Type 'a ref := { mutable contents : 'a }. - -Fail Ltac2 qux0 := { contents := None }. -Ltac2 foo0 _ := { contents := None }. - -Print Ltac2 foo0. - -Ltac2 qux0 x := x.(contents). -Ltac2 qux1 x := x.(contents) := x.(contents). - -Ltac2 qux2 := ([1;2], true). - -Print Ltac2 qux0. -Print Ltac2 qux1. -Print Ltac2 qux2. - -Import Control. - -Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun _ => hyp x))). - -Print Ltac2 qux3. - -Ltac2 qux4 f x := x, (f x, x). - -Print Ltac2 qux4. - -Ltac2 Type rec nat := [ O | S (nat) ]. - -Ltac2 message_of_nat n := -let rec aux n := -match n with -| O => Message.of_string "O" -| S n => Message.concat (Message.of_string "S") (aux n) -end in aux n. - -Print Ltac2 message_of_nat. - -Ltac2 numgoals (_ : unit) := - let r := { contents := O } in - enter (fun _ => r.(contents) := S (r.(contents))); - r.(contents). - -Print Ltac2 numgoals. - -Goal True /\ False. -Proof. -let n := numgoals () in Message.print (message_of_nat n). -refine (fun _ => open_constr:((fun x => conj _ _) 0)); (). -let n := numgoals () in Message.print (message_of_nat n). - -Fail (hyp ident:(x)). -Fail (enter (fun _ => hyp ident:(There_is_no_spoon); ())). - -enter (fun _ => Message.print (Message.of_string "foo")). - -enter (fun _ => Message.print (Message.of_constr (goal ()))). -Fail enter (fun _ => Message.print (Message.of_constr (qux3 ident:(x)))). -enter (fun _ => plus (fun _ => constr:(_); ()) (fun _ => ())). -plus - (fun _ => enter (fun _ => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). -let x := { contents := 0 } in -let x := x.(contents) := x.(contents) in x. -Abort. - -Ltac2 Type exn ::= [ Foo ]. - -Goal True. -Proof. -plus (fun _ => zero Foo) (fun _ => ()). -Abort. - -Ltac2 Type exn ::= [ Bar (string) ]. - -Goal True. -Proof. -Fail zero (Bar "lol"). -Abort. - -Ltac2 Notation "refine!" c(constr) := refine c. - -Goal True. -Proof. -refine! I. -Abort. - -Goal True. -Proof. -let x _ := plus (fun _ => 0) (fun _ => 1) in -match case x with -| Val x => - match x with - | (x, k) => Message.print (Message.of_int (k Not_found)) - end -| Err x => Message.print (Message.of_string "Err") -end. -Abort. diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v new file mode 100644 index 0000000000..770d385406 --- /dev/null +++ b/tests/stuff/ltac2.v @@ -0,0 +1,131 @@ +Require Import Ltac2.Ltac2. + +Ltac2 foo (_ : int) := + let f (x : int) := x in + let _ := f 0 in + f 1. + +Print Ltac2 foo. + +Import Control. + +Ltac2 exact x := refine (fun _ => x). + +Print Ltac2 refine. +Print Ltac2 exact. + +Ltac2 foo' _ := ident:(bla). + +Print Ltac2 foo'. + +Ltac2 bar x H := match x with +| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) +| Some x => x +end. + +Print Ltac2 bar. + +Ltac2 qux := Some 0. + +Print Ltac2 qux. + +Ltac2 Type foo := [ Foo (int) ]. + +Fail Ltac2 qux0 := Foo None. + +Ltac2 Type 'a ref := { mutable contents : 'a }. + +Fail Ltac2 qux0 := { contents := None }. +Ltac2 foo0 _ := { contents := None }. + +Print Ltac2 foo0. + +Ltac2 qux0 x := x.(contents). +Ltac2 qux1 x := x.(contents) := x.(contents). + +Ltac2 qux2 := ([1;2], true). + +Print Ltac2 qux0. +Print Ltac2 qux1. +Print Ltac2 qux2. + +Import Control. + +Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun _ => hyp x))). + +Print Ltac2 qux3. + +Ltac2 qux4 f x := x, (f x, x). + +Print Ltac2 qux4. + +Ltac2 Type rec nat := [ O | S (nat) ]. + +Ltac2 message_of_nat n := +let rec aux n := +match n with +| O => Message.of_string "O" +| S n => Message.concat (Message.of_string "S") (aux n) +end in aux n. + +Print Ltac2 message_of_nat. + +Ltac2 numgoals (_ : unit) := + let r := { contents := O } in + enter (fun _ => r.(contents) := S (r.(contents))); + r.(contents). + +Print Ltac2 numgoals. + +Goal True /\ False. +Proof. +let n := numgoals () in Message.print (message_of_nat n). +refine (fun _ => open_constr:((fun x => conj _ _) 0)); (). +let n := numgoals () in Message.print (message_of_nat n). + +Fail (hyp ident:(x)). +Fail (enter (fun _ => hyp ident:(There_is_no_spoon); ())). + +enter (fun _ => Message.print (Message.of_string "foo")). + +enter (fun _ => Message.print (Message.of_constr (goal ()))). +Fail enter (fun _ => Message.print (Message.of_constr (qux3 ident:(x)))). +enter (fun _ => plus (fun _ => constr:(_); ()) (fun _ => ())). +plus + (fun _ => enter (fun _ => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). +let x := { contents := 0 } in +let x := x.(contents) := x.(contents) in x. +Abort. + +Ltac2 Type exn ::= [ Foo ]. + +Goal True. +Proof. +plus (fun _ => zero Foo) (fun _ => ()). +Abort. + +Ltac2 Type exn ::= [ Bar (string) ]. + +Goal True. +Proof. +Fail zero (Bar "lol"). +Abort. + +Ltac2 Notation "refine!" c(constr) := refine c. + +Goal True. +Proof. +refine! I. +Abort. + +Goal True. +Proof. +let x _ := plus (fun _ => 0) (fun _ => 1) in +match case x with +| Val x => + match x with + | (x, k) => Message.print (Message.of_int (k Not_found)) + end +| Err x => Message.print (Message.of_string "Err") +end. +Abort. diff --git a/tests/typing.v b/tests/typing.v new file mode 100644 index 0000000000..8460ab42b7 --- /dev/null +++ b/tests/typing.v @@ -0,0 +1,25 @@ +Require Import Ltac2.Ltac2. + +(** Ltac2 is typed à la ML. *) + +Ltac2 test0 n := Int.add n 1. + +Print Ltac2 test0. + +Ltac2 test1 () := test0 0. + +Print Ltac2 test1. + +Fail Ltac2 test2 () := test0 true. + +Fail Ltac2 test2 () := test0 0 0. + +(** Polymorphism *) + +Ltac2 rec list_length l := +match l with +| [] => 0 +| x :: l => Int.add 1 (list_length l) +end. + +Print Ltac2 list_length. -- cgit v1.2.3 From 4395637a6471fc95934fe93da671bda68d415a77 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 17:53:04 +0200 Subject: Ensuring that inductive constructors are always capitalized. --- src/g_ltac2.ml4 | 23 +++++++--- src/tac2core.ml | 6 +-- src/tac2entries.ml | 29 +++++++------ src/tac2env.ml | 75 ++++++++++++++++++-------------- src/tac2env.mli | 17 ++++++-- src/tac2expr.mli | 9 ++-- src/tac2intern.ml | 120 +++++++++++++++++++--------------------------------- src/tac2print.ml | 4 +- tests/stuff/ltac2.v | 2 +- 9 files changed, 144 insertions(+), 141 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 605cb75d66..88a64dacd9 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -28,20 +28,32 @@ let inj_constr loc c = inj_wit Stdarg.wit_constr loc c let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c let inj_ident loc c = inj_wit Stdarg.wit_ident loc c +let pattern_of_qualid loc id = + if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) + else + let (dp, id) = Libnames.repr_qualid (snd id) in + if DirPath.is_empty dp then CPatVar (Some loc, Name id) + else + CErrors.user_err ~loc (Pp.str "Syntax error") + GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn; tac2pat: [ "1" LEFTA - [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> CPatRef (!@loc, RelId id, pl) - | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) + [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> + if Tac2env.is_constructor (snd id) then + CPatRef (!@loc, RelId id, pl) + else + CErrors.user_err ~loc:!@loc (Pp.str "Syntax error") + | id = Prim.qualid -> pattern_of_qualid !@loc id | "["; "]" -> CPatRef (!@loc, AbsKn Tac2core.Core.c_nil, []) | p1 = tac2pat; "::"; p2 = tac2pat -> CPatRef (!@loc, AbsKn Tac2core.Core.c_cons, [p1; p2]) ] | "0" - [ "_" -> CPatAny (!@loc) + [ "_" -> CPatVar (Some !@loc, Anonymous) | "()" -> CPatTup (Loc.tag ~loc:!@loc []) - | id = Prim.qualid -> CPatRef (!@loc, RelId id, []) + | id = Prim.qualid -> pattern_of_qualid !@loc id | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> CPatTup (Loc.tag ~loc:!@loc pl) ] ] ; @@ -90,7 +102,8 @@ GEXTEND Gram tactic_atom: [ [ n = Prim.integer -> CTacAtm (Loc.tag ~loc:!@loc (AtmInt n)) | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) - | id = Prim.qualid -> CTacRef (RelId id) + | id = Prim.qualid -> + if Tac2env.is_constructor (snd id) then CTacCst (RelId id) else CTacRef (RelId id) | "@"; id = Prim.ident -> inj_ident !@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c diff --git a/src/tac2core.ml b/src/tac2core.ml index b665f761ce..2ccc49b043 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -734,7 +734,7 @@ let dummy_loc = Loc.make_loc (-1, -1) let rthunk e = let loc = Tac2intern.loc_of_tacexpr e in - let var = [CPatAny loc, Some (CTypRef (loc, AbsKn Core.t_unit, []))] in + let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn Core.t_unit, []))] in CTacFun (loc, var, e) let add_generic_scope s entry arg = @@ -795,9 +795,9 @@ let () = add_scope "opt" begin function let scope = Extend.Aopt scope in let act opt = match opt with | None -> - CTacRef (AbsKn (TacConstructor Core.c_none)) + CTacCst (AbsKn Core.c_none) | Some x -> - CTacApp (dummy_loc, CTacRef (AbsKn (TacConstructor Core.c_some)), [act x]) + CTacApp (dummy_loc, CTacCst (AbsKn Core.c_some), [act x]) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 100041f15e..da0e213340 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -34,14 +34,14 @@ type tacdef = { } let perform_tacdef visibility ((sp, kn), def) = - let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp (TacConstant kn) in + let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp kn in Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) let load_tacdef i obj = perform_tacdef (Until i) obj let open_tacdef i obj = perform_tacdef (Exactly i) obj let cache_tacdef ((sp, kn), def) = - let () = Tac2env.push_ltac (Until 1) sp (TacConstant kn) in + let () = Tac2env.push_ltac (Until 1) sp kn in Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) let subst_tacdef (subst, def) = @@ -83,7 +83,7 @@ let push_typedef visibility sp kn (_, def) = match def with let iter (c, _) = let spc = change_sp_label sp c in let knc = change_kn_label kn c in - Tac2env.push_ltac visibility spc (TacConstructor knc) + Tac2env.push_constructor visibility spc knc in Tac2env.push_type visibility sp kn; List.iter iter cstrs @@ -185,7 +185,7 @@ let push_typext vis sp kn def = let iter data = let spc = change_sp_label sp data.edata_name in let knc = change_kn_label kn data.edata_name in - Tac2env.push_ltac vis spc (TacConstructor knc) + Tac2env.push_constructor vis spc knc in List.iter iter def.typext_expr @@ -620,12 +620,18 @@ let register_struct ?local str = match str with let print_ltac ref = let (loc, qid) = qualid_of_reference ref in - let kn = - try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) - in - match kn with - | TacConstant kn -> + if Tac2env.is_constructor qid then + let kn = + try Tac2env.locate_constructor qid + with Not_found -> user_err ?loc (str "Unknown constructor " ++ pr_qualid qid) + in + let _ = Tac2env.interp_constructor kn in + Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) + in let (e, _, (_, t)) = Tac2env.interp_global kn in let name = int_name () in Feedback.msg_notice ( @@ -634,9 +640,6 @@ let print_ltac ref = hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) ) ) - | TacConstructor kn -> - let _ = Tac2env.interp_constructor kn in - Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) (** Calling tactics *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 08c7b321be..6e47e78a9d 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -115,25 +115,13 @@ struct id, (DirPath.repr dir) end -type tacref = Tac2expr.tacref = -| TacConstant of ltac_constant -| TacConstructor of ltac_constructor - -module TacRef = -struct -type t = tacref -let equal r1 r2 = match r1, r2 with -| TacConstant c1, TacConstant c2 -> KerName.equal c1 c2 -| TacConstructor c1, TacConstructor c2 -> KerName.equal c1 c2 -| _ -> false -end - module KnTab = Nametab.Make(FullPath)(KerName) -module RfTab = Nametab.Make(FullPath)(TacRef) type nametab = { - tab_ltac : RfTab.t; - tab_ltac_rev : full_path KNmap.t * full_path KNmap.t; + tab_ltac : KnTab.t; + tab_ltac_rev : full_path KNmap.t; + tab_cstr : KnTab.t; + tab_cstr_rev : full_path KNmap.t; tab_type : KnTab.t; tab_type_rev : full_path KNmap.t; tab_proj : KnTab.t; @@ -141,8 +129,10 @@ type nametab = { } let empty_nametab = { - tab_ltac = RfTab.empty; - tab_ltac_rev = (KNmap.empty, KNmap.empty); + tab_ltac = KnTab.empty; + tab_ltac_rev = KNmap.empty; + tab_cstr = KnTab.empty; + tab_cstr_rev = KNmap.empty; tab_type = KnTab.empty; tab_type_rev = KNmap.empty; tab_proj = KnTab.empty; @@ -153,29 +143,41 @@ let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" let push_ltac vis sp kn = let tab = !nametab in - let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in - let (constant_map, constructor_map) = tab.tab_ltac_rev in - let tab_ltac_rev = match kn with - | TacConstant c -> (KNmap.add c sp constant_map, constructor_map) - | TacConstructor c -> (constant_map, KNmap.add c sp constructor_map) - in + let tab_ltac = KnTab.push vis sp kn tab.tab_ltac in + let tab_ltac_rev = KNmap.add kn sp tab.tab_ltac_rev in nametab := { tab with tab_ltac; tab_ltac_rev } let locate_ltac qid = let tab = !nametab in - RfTab.locate qid tab.tab_ltac + KnTab.locate qid tab.tab_ltac let locate_extended_all_ltac qid = let tab = !nametab in - RfTab.find_prefixes qid tab.tab_ltac + KnTab.find_prefixes qid tab.tab_ltac let shortest_qualid_of_ltac kn = let tab = !nametab in - let sp = match kn with - | TacConstant c -> KNmap.find c (fst tab.tab_ltac_rev) - | TacConstructor c -> KNmap.find c (snd tab.tab_ltac_rev) - in - RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + let sp = KNmap.find kn tab.tab_ltac_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + +let push_constructor vis sp kn = + let tab = !nametab in + let tab_cstr = KnTab.push vis sp kn tab.tab_cstr in + let tab_cstr_rev = KNmap.add kn sp tab.tab_cstr_rev in + nametab := { tab with tab_cstr; tab_cstr_rev } + +let locate_constructor qid = + let tab = !nametab in + KnTab.locate qid tab.tab_cstr + +let locate_extended_all_constructor qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_cstr + +let shortest_qualid_of_constructor kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_cstr_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr let push_type vis sp kn = let tab = !nametab in @@ -240,3 +242,14 @@ let coq_prefix = (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2" + +let is_constructor qid = + let (_, id) = repr_qualid qid in + let id = Id.to_string id in + assert (String.length id > 0); + match id with + | "true" | "false" -> true (** built-in constructors *) + | _ -> + match id.[0] with + | 'A'..'Z' -> true + | _ -> false diff --git a/src/tac2env.mli b/src/tac2env.mli index c4b8c1e0ca..8ab9656cb9 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -63,10 +63,15 @@ val interp_projection : ltac_projection -> projection_data (** {5 Name management} *) -val push_ltac : visibility -> full_path -> tacref -> unit -val locate_ltac : qualid -> tacref -val locate_extended_all_ltac : qualid -> tacref list -val shortest_qualid_of_ltac : tacref -> qualid +val push_ltac : visibility -> full_path -> ltac_constant -> unit +val locate_ltac : qualid -> ltac_constant +val locate_extended_all_ltac : qualid -> ltac_constant list +val shortest_qualid_of_ltac : ltac_constant -> qualid + +val push_constructor : visibility -> full_path -> ltac_constructor -> unit +val locate_constructor : qualid -> ltac_constructor +val locate_extended_all_constructor : qualid -> ltac_constructor list +val shortest_qualid_of_constructor : ltac_constructor -> qualid val push_type : visibility -> full_path -> type_constant -> unit val locate_type : qualid -> type_constant @@ -104,3 +109,7 @@ val coq_prefix : ModPath.t (** {5 Generic arguments} *) val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type + +(** {5 Helper functions} *) + +val is_constructor : qualid -> bool diff --git a/src/tac2expr.mli b/src/tac2expr.mli index a9f2109cb2..b268e70cb3 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -70,19 +70,16 @@ type atom = | AtmInt of int | AtmStr of string -type tacref = -| TacConstant of ltac_constant -| TacConstructor of ltac_constructor - (** Tactic expressions *) type raw_patexpr = -| CPatAny of Loc.t +| CPatVar of Name.t located | CPatRef of Loc.t * ltac_constructor or_relid * raw_patexpr list | CPatTup of raw_patexpr list located type raw_tacexpr = | CTacAtm of atom located -| CTacRef of tacref or_relid +| CTacRef of ltac_constant or_relid +| CTacCst of ltac_constructor or_relid | CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list | CTacLet of Loc.t * rec_flag * (Name.t located * raw_typexpr option * raw_tacexpr) list * raw_tacexpr diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 79e33f3a94..3ea35171bb 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -191,6 +191,8 @@ let loc_of_tacexpr = function | CTacAtm (loc, _) -> Option.default dummy_loc loc | CTacRef (RelId (loc, _)) -> Option.default dummy_loc loc | CTacRef (AbsKn _) -> dummy_loc +| CTacCst (RelId (loc, _)) -> Option.default dummy_loc loc +| CTacCst (AbsKn _) -> dummy_loc | CTacFun (loc, _, _) -> loc | CTacApp (loc, _, _) -> loc | CTacLet (loc, _, _, _) -> loc @@ -206,7 +208,7 @@ let loc_of_tacexpr = function | CTacExt (loc, _) -> loc let loc_of_patexpr = function -| CPatAny loc -> loc +| CPatVar (loc, _) -> Option.default dummy_loc loc | CPatRef (loc, _, _) -> loc | CPatTup (loc, _) -> Option.default dummy_loc loc @@ -516,22 +518,17 @@ let get_variable env var = let get_constructor env var = match var with | RelId (loc, qid) -> - let c = try Some (Tac2env.locate_ltac qid) with Not_found -> None in + let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in begin match c with - | Some (TacConstructor knc) -> + | Some knc -> let kn = Tac2env.interp_constructor knc in - ArgArg (kn, knc) - | Some (TacConstant _) -> - CErrors.user_err ?loc (str "The term " ++ pr_qualid qid ++ - str " is not the constructor of an inductive type.") + (kn, knc) | None -> - let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp then ArgVar (loc, id) - else CErrors.user_err ?loc (str "Unbound constructor " ++ pr_qualid qid) + CErrors.user_err ?loc (str "Unbound constructor " ++ pr_qualid qid) end | AbsKn knc -> let kn = Tac2env.interp_constructor knc in - ArgArg (kn, knc) + (kn, knc) let get_projection var = match var with | RelId (loc, qid) -> @@ -562,18 +559,10 @@ type glb_patexpr = | GPatTup of glb_patexpr list let rec intern_patexpr env = function -| CPatAny _ -> GPatVar Anonymous -| CPatRef (_, qid, []) -> - begin match get_constructor env qid with - | ArgVar (_, id) -> GPatVar (Name id) - | ArgArg (_, kn) -> GPatRef (kn, []) - end +| CPatVar (_, na) -> GPatVar na | CPatRef (_, qid, pl) -> - begin match get_constructor env qid with - | ArgVar (loc, id) -> - user_err ?loc (str "Unbound constructor " ++ Nameops.pr_id id) - | ArgArg (_, kn) -> GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) - end + let (_, kn) = get_constructor env qid in + GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) | CPatTup (_, pl) -> GPatTup (List.map (fun p -> intern_patexpr env p) pl) @@ -603,10 +592,6 @@ let get_pattern_kind env pl = match pl with (** Internalization *) -let is_constructor env qid = match get_variable env qid with -| ArgArg (TacConstructor _) -> true -| _ -> false - (** Used to generate a fresh tactic variable for pattern-expansion *) let fresh_var env = let bad id = @@ -617,18 +602,19 @@ let fresh_var env = let rec intern_rec env = function | CTacAtm (_, atm) -> intern_atm env atm -| CTacRef qid as e -> +| CTacRef qid -> begin match get_variable env qid with | ArgVar (_, id) -> let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) - | ArgArg (TacConstant kn) -> + | ArgArg kn -> let (_, _, sch) = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) - | ArgArg (TacConstructor kn) -> - let loc = loc_of_tacexpr e in - intern_constructor env loc kn [] end +| CTacCst qid as e -> + let loc = loc_of_tacexpr e in + let (_, kn) = get_constructor env qid in + intern_constructor env loc kn [] | CTacFun (loc, bnd, e) -> let fold (env, bnd, tl) (pat, t) = let t = match t with @@ -651,11 +637,8 @@ let rec intern_rec env = function let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in (GTacFun (bnd, e), t) -| CTacApp (loc, CTacRef qid, args) as e when is_constructor env qid -> - let kn = match get_variable env qid with - | ArgArg (TacConstructor kn) -> kn - | _ -> assert false - in +| CTacApp (loc, CTacCst qid, args) as e -> + let (_, kn) = get_constructor env qid in let loc = loc_of_tacexpr e in intern_constructor env loc kn args | CTacApp (loc, f, args) -> @@ -823,7 +806,7 @@ and intern_let_rec env loc el e = to depth-one where leaves are either variables or catch-all *) and intern_case env loc e pl = let (e', t) = intern_rec env e in - let todo ~loc () = user_err ~loc (str "Pattern not handled yet") in + let todo ?loc () = user_err ?loc (str "Pattern not handled yet") in match get_pattern_kind env pl with | PKind_any -> let (pat, b) = List.hd pl in @@ -848,12 +831,7 @@ and intern_case env loc e pl = (GTacCse (e', GCaseAlg t_unit, [|b|], [||]), tb) | [CPatTup (_, pl), b] -> let map = function - | CPatAny _ -> Anonymous - | CPatRef (loc, qid, []) -> - begin match get_constructor env qid with - | ArgVar (_, id) -> Name id - | ArgArg _ -> todo ~loc () - end + | CPatVar (_, na) -> na | p -> todo ~loc:(loc_of_patexpr p) () in let ids = List.map map pl in @@ -885,7 +863,8 @@ and intern_case env loc e pl = | [] -> () | (pat, br) :: rem -> let tbr = match pat with - | CPatAny _ -> + | CPatVar (loc, Name _) -> todo ?loc () + | CPatVar (_, Anonymous) -> let () = check_redundant_clause rem in let (br', brT) = intern_rec env br in (** Fill all remaining branches *) @@ -906,23 +885,14 @@ and intern_case env loc e pl = let _ = List.fold_left fill (0, 0) cstrs in brT | CPatRef (loc, qid, args) -> - let data = match get_constructor env qid with - | ArgVar _ -> todo ~loc () - | ArgArg (data, _) -> - let () = - let kn' = data.cdata_type in - if not (KerName.equal kn kn') then - invalid_pattern ~loc kn (GCaseAlg kn') - in - data + let (data, _) = get_constructor env qid in + let () = + let kn' = data.cdata_type in + if not (KerName.equal kn kn') then + invalid_pattern ~loc kn (GCaseAlg kn') in let get_id = function - | CPatAny _ -> Anonymous - | CPatRef (loc, qid, []) -> - begin match get_constructor env qid with - | ArgVar (_, id) -> Name id - | ArgArg _ -> todo ~loc () - end + | CPatVar (_, na) -> na | p -> todo ~loc:(loc_of_patexpr p) () in let ids = List.map get_id args in @@ -1165,12 +1135,9 @@ let get_projection0 var = match var with | AbsKn kn -> kn let rec ids_of_pattern accu = function -| CPatAny _ -> accu -| CPatRef (_, RelId (_, qid), pl) -> - let (dp, id) = repr_qualid qid in - let accu = if DirPath.is_empty dp then Id.Set.add id accu else accu in - List.fold_left ids_of_pattern accu pl -| CPatRef (_, AbsKn _, pl) -> +| CPatVar (_, Anonymous) -> accu +| CPatVar (_, Name id) -> Id.Set.add id accu +| CPatRef (_, _, pl) -> List.fold_left ids_of_pattern accu pl | CPatTup (_, pl) -> List.fold_left ids_of_pattern accu pl @@ -1183,6 +1150,9 @@ let rec globalize ids e = match e with | ArgVar _ -> e | ArgArg kn -> CTacRef (AbsKn kn) end +| CTacCst qid -> + let (_, knc) = get_constructor () qid in + CTacCst (AbsKn knc) | CTacFun (loc, bnd, e) -> let fold (pats, accu) (pat, t) = let accu = ids_of_pattern accu pat in @@ -1252,12 +1222,10 @@ and globalize_case ids (p, e) = (globalize_pattern ids p, globalize ids e) and globalize_pattern ids p = match p with -| CPatAny _ -> p +| CPatVar _ -> p | CPatRef (loc, cst, pl) -> - let cst = match get_constructor () cst with - | ArgVar _ -> cst - | ArgArg (_, knc) -> AbsKn knc - in + let (_, knc) = get_constructor () cst in + let cst = AbsKn knc in let pl = List.map (fun p -> globalize_pattern ids p) pl in CPatRef (loc, cst, pl) | CPatTup (loc, pl) -> @@ -1393,12 +1361,9 @@ let rec subst_rawtype subst t = match t with let subst_tacref subst ref = match ref with | RelId _ -> ref -| AbsKn (TacConstant kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacConstant kn') -| AbsKn (TacConstructor kn) -> +| AbsKn kn -> let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacConstructor kn') + if kn' == kn then ref else AbsKn kn' let subst_projection subst prj = match prj with | RelId _ -> prj @@ -1407,7 +1372,7 @@ let subst_projection subst prj = match prj with if kn' == kn then prj else AbsKn kn' let rec subst_rawpattern subst p = match p with -| CPatAny _ -> p +| CPatVar _ -> p | CPatRef (loc, c, pl) -> let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in let c' = match c with @@ -1427,6 +1392,9 @@ let rec subst_rawexpr subst t = match t with | CTacRef ref -> let ref' = subst_tacref subst ref in if ref' == ref then t else CTacRef ref' +| CTacCst ref -> + let ref' = subst_tacref subst ref in + if ref' == ref then t else CTacCst ref' | CTacFun (loc, bnd, e) -> let map (na, t as p) = let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in diff --git a/src/tac2print.ml b/src/tac2print.ml index e6f0582e3d..2afcfb4a6e 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -83,7 +83,7 @@ let int_name () = (** Term printing *) let pr_constructor kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstructor kn)) + Libnames.pr_qualid (Tac2env.shortest_qualid_of_constructor kn) let pr_projection kn = Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) @@ -138,7 +138,7 @@ let pr_glbexpr_gen lvl c = | GTacAtm atm -> pr_atom atm | GTacVar id -> Id.print id | GTacRef gr -> - let qid = shortest_qualid_of_ltac (TacConstant gr) in + let qid = shortest_qualid_of_ltac gr in Libnames.pr_qualid qid | GTacFun (nas, c) -> let nas = pr_sequence pr_name nas in diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 770d385406..36ea1ef4c1 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -18,7 +18,7 @@ Ltac2 foo' _ := ident:(bla). Print Ltac2 foo'. -Ltac2 bar x H := match x with +Ltac2 bar x h := match x with | None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) | Some x => x end. -- cgit v1.2.3 From e917841e46264ad7b80241b25dcd7731eca468a8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 19:05:22 +0200 Subject: Do not expand trivial patterns in functions. --- src/tac2intern.ml | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 3ea35171bb..431b551191 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -616,27 +616,36 @@ let rec intern_rec env = function let (_, kn) = get_constructor env qid in intern_constructor env loc kn [] | CTacFun (loc, bnd, e) -> + (** Expand pattern: [fun p => t] becomes [fun x => match x with p => t end] *) let fold (env, bnd, tl) (pat, t) = let t = match t with | None -> GTypVar (fresh_id env) | Some t -> intern_type env t in - let id = fresh_var env in - let env = push_name (Name id) (monomorphic t) env in - (env, (id, pat) :: bnd, t :: tl) + let na, expand = match pat with + | CPatVar (_, na) -> + (** Don't expand variable patterns *) + na, None + | _ -> + let loc = loc_of_patexpr pat in + let id = fresh_var env in + let qid = RelId (Loc.tag ~loc (qualid_of_ident id)) in + Name id, Some qid + in + let env = push_name na (monomorphic t) env in + (env, (na, pat, expand) :: bnd, t :: tl) in let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in - (** Expand pattern: [fun p => t] becomes [fun x => match x with p => t end] *) - let fold e (id, pat) = - let loc = loc_of_patexpr pat in - let qid = RelId (Loc.tag ~loc (qualid_of_ident id)) in + let fold e (na, pat, expand) = match expand with + | None -> e + | Some qid -> CTacCse (loc, CTacRef qid, [pat, e]) in let e = List.fold_left fold e bnd in - let bnd = List.rev_map (fun (id, _) -> Name id) bnd in + let nas = List.rev_map (fun (na, _, _) -> na) bnd in let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in - (GTacFun (bnd, e), t) + (GTacFun (nas, e), t) | CTacApp (loc, CTacCst qid, args) as e -> let (_, kn) = get_constructor env qid in let loc = loc_of_tacexpr e in -- cgit v1.2.3 From 57b9df4e07351a753f897dc24eb8238f6465b26d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 20:50:58 +0200 Subject: Dedicated module for ident type. --- _CoqProject | 1 + src/tac2core.ml | 29 +++++++++++++++++++++++++++++ theories/Ident.v | 17 +++++++++++++++++ theories/Ltac2.v | 1 + 4 files changed, 48 insertions(+) create mode 100644 theories/Ident.v diff --git a/_CoqProject b/_CoqProject index 6d3470cfa7..2561b7b6ec 100644 --- a/_CoqProject +++ b/_CoqProject @@ -23,6 +23,7 @@ src/ltac2_plugin.mlpack theories/Init.v theories/Int.v theories/String.v +theories/Ident.v theories/Array.v theories/Control.v theories/Message.v diff --git a/src/tac2core.ml b/src/tac2core.ml index 2ccc49b043..f29cc8c89e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -267,6 +267,31 @@ let prm_array_get : ml_tactic = function else wrap (fun () -> v.(n)) | _ -> assert false +(** Ident *) + +let prm_ident_equal : ml_tactic = function +| [id1; id2] -> + let id1 = Value.to_ident id1 in + let id2 = Value.to_ident id2 in + return (Value.of_bool (Id.equal id1 id2)) +| _ -> assert false + +let prm_ident_to_string : ml_tactic = function +| [id] -> + let id = Value.to_ident id in + return (Value.of_string (Id.to_string id)) +| _ -> assert false + +let prm_ident_of_string : ml_tactic = function +| [s] -> + let s = Value.to_string s in + let id = + try Value.of_option (Some (Value.of_ident (Id.of_string s))) + with _ -> Value.of_option None + in + return id +| _ -> assert false + (** Int *) let prm_int_equal : ml_tactic = function @@ -624,6 +649,10 @@ let () = Tac2env.define_primitive (pname "int_add") prm_int_add let () = Tac2env.define_primitive (pname "int_sub") prm_int_sub let () = Tac2env.define_primitive (pname "int_mul") prm_int_mul +let () = Tac2env.define_primitive (pname "ident_equal") prm_ident_equal +let () = Tac2env.define_primitive (pname "ident_to_string") prm_ident_to_string +let () = Tac2env.define_primitive (pname "ident_of_string") prm_ident_of_string + let () = Tac2env.define_primitive (pname "throw") prm_throw let () = Tac2env.define_primitive (pname "zero") prm_zero diff --git a/theories/Ident.v b/theories/Ident.v new file mode 100644 index 0000000000..55456afbe2 --- /dev/null +++ b/theories/Ident.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> bool := "ltac2" "ident_equal". + +Ltac2 @ external of_string : string -> t option := "ltac2" "ident_of_string". + +Ltac2 @ external to_string : t -> string := "ltac2" "ident_to_string". diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 4cd3fafcb2..0d6c8f232a 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -10,6 +10,7 @@ Require Export Ltac2.Init. Require Ltac2.Int. Require Ltac2.String. +Require Ltac2.Ident. Require Ltac2.Array. Require Ltac2.Message. Require Ltac2.Constr. -- cgit v1.2.3 From 2d6461140fadf1af8b92567b77e869eb2bd9dd7e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 22:41:55 +0200 Subject: Tentative fix of parsing of product types. --- src/g_ltac2.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 88a64dacd9..cd227a78f1 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -121,7 +121,7 @@ GEXTEND Gram [ "5" RIGHTA [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type SEP "*" -> CTypTuple (!@loc, t :: tl) ] + [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> CTypTuple (!@loc, t :: tl) ] | "1" LEFTA [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, RelId qid, [t]) ] | "0" -- cgit v1.2.3 From c9e7d7f1ceb22667e77a4ee49a4afc2cce6f9a2c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 22:47:18 +0200 Subject: Adding an example file --- tests/example1.v | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 tests/example1.v diff --git a/tests/example1.v b/tests/example1.v new file mode 100644 index 0000000000..1b26aad824 --- /dev/null +++ b/tests/example1.v @@ -0,0 +1,26 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Control. + +(** Alternative implementation of the hyp primitive *) +Ltac2 get_hyp_by_name x := + let h := hyps () in + let rec find x l := match l with + | [] => zero Not_found + | p :: l => + match p with + | (id, _, t) => + match Ident.equal x id with + | true => t + | false => find x l + end + end + end in + find x h. + +Print Ltac2 get_hyp_by_name. + +Goal forall n m, n + m = 0 -> n = 0. +Proof. +refine (fun () => '(fun n m H => _)). +let t := get_hyp_by_name @H in Message.print (Message.of_constr t). -- cgit v1.2.3 From f204058d329fa78b506f4c3b3c4f97ecce504d4b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 26 Jul 2017 21:27:36 +0200 Subject: Adding necessary primitives to do pattern-matching over constr. --- _CoqProject | 1 + src/g_ltac2.ml4 | 2 ++ src/tac2core.ml | 81 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2env.ml | 1 + src/tac2env.mli | 2 ++ theories/Init.v | 4 +++ theories/Ltac2.v | 1 + theories/Pattern.v | 30 ++++++++++++++++++++ 8 files changed, 122 insertions(+) create mode 100644 theories/Pattern.v diff --git a/_CoqProject b/_CoqProject index 2561b7b6ec..e3ad3987bd 100644 --- a/_CoqProject +++ b/_CoqProject @@ -28,5 +28,6 @@ theories/Array.v theories/Control.v theories/Message.v theories/Constr.v +theories/Pattern.v theories/Std.v theories/Ltac2.v diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index cd227a78f1..d7d376f88a 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -27,6 +27,7 @@ let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) let inj_constr loc c = inj_wit Stdarg.wit_constr loc c let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c let inj_ident loc c = inj_wit Stdarg.wit_ident loc c +let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c let pattern_of_qualid loc id = if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) @@ -109,6 +110,7 @@ GEXTEND Gram | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c + | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> inj_pattern !@loc c ] ] ; let_clause: diff --git a/src/tac2core.ml b/src/tac2core.ml index f29cc8c89e..ab1eaec9d9 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -26,6 +26,7 @@ let val_tag t = match val_tag t with let val_constr = val_tag (topwit Stdarg.wit_constr) let val_ident = val_tag (topwit Stdarg.wit_ident) +let val_pattern = Val.create "ltac2:pattern" let val_pp = Val.create "ltac2:pp" let val_sort = Val.create "ltac2:sort" let val_cast = Val.create "ltac2:cast" @@ -51,6 +52,7 @@ let t_array = coq_core "array" let t_unit = coq_core "unit" let t_list = coq_core "list" let t_constr = coq_core "constr" +let t_pattern = coq_core "pattern" let t_ident = coq_core "ident" let t_option = coq_core "option" @@ -121,6 +123,9 @@ let to_constr c = to_ext val_constr c let of_ident c = of_ext val_ident c let to_ident c = to_ext val_ident c +let of_pattern c = of_ext val_pattern c +let to_pattern c = to_ext val_pattern c + (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with | LtacError (kn, c) -> ValOpn (kn, c) @@ -178,6 +183,9 @@ let err_outofbounds = let err_notfound = LtacError (coq_core "Not_found", [||]) +let err_matchfailure = + LtacError (coq_core "Match_failure", [||]) + (** Helper functions *) let thaw f = interp_app f [v_unit] @@ -464,6 +472,54 @@ let prm_constr_kind : ml_tactic = function end | _ -> assert false +(** Patterns *) + +let prm_pattern_matches : ml_tactic = function +| [pat; c] -> + let pat = Value.to_pattern pat in + let c = Value.to_constr c in + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> Proofview.tclZERO err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + return (Value.of_list (List.map of_pair ans)) + end + end +| _ -> assert false + +let prm_pattern_matches_subterm : ml_tactic = function +| [pat; c] -> + let pat = Value.to_pattern pat in + let c = Value.to_constr c in + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_list (List.map of_pair ans) |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_appsubterm env sigma pat c in + of_ans ans + end +| _ -> assert false + +let prm_pattern_instantiate : ml_tactic = function +| [ctx; c] -> + let ctx = EConstr.Unsafe.to_constr (Value.to_constr ctx) in + let c = EConstr.Unsafe.to_constr (Value.to_constr c) in + let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in + return (Value.of_constr (EConstr.of_constr ans)) +| _ -> assert false + (** Error *) let prm_throw : ml_tactic = function @@ -642,6 +698,10 @@ let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal let () = Tac2env.define_primitive (pname "constr_kind") prm_constr_kind +let () = Tac2env.define_primitive (pname "pattern_matches") prm_pattern_matches +let () = Tac2env.define_primitive (pname "pattern_matches_subterm") prm_pattern_matches_subterm +let () = Tac2env.define_primitive (pname "pattern_instantiate") prm_pattern_instantiate + let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare let () = Tac2env.define_primitive (pname "int_neg") prm_int_neg @@ -738,6 +798,14 @@ let () = } in define_ml_object Stdarg.wit_ident obj +let () = + let interp _ c = return (Val.Dyn (val_pattern, c)) in + let obj = { + ml_type = t_pattern; + ml_interp = interp; + } in + define_ml_object Tac2env.wit_pattern obj + let () = let interp ist env sigma concl tac = let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = @@ -752,6 +820,19 @@ let () = in Pretyping.register_constr_interp0 wit_ltac2 interp +(** Patterns *) + +let () = + let intern ist c = + let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in + ist, pat + in + Genintern.register_intern0 wit_pattern intern + +let () = + let subst s c = Patternops.subst_pattern s c in + Genintern.register_subst0 wit_pattern subst + (** Built-in notation scopes *) let add_scope s f = diff --git a/src/tac2env.ml b/src/tac2env.ml index 6e47e78a9d..2094898ced 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -242,6 +242,7 @@ let coq_prefix = (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2" +let wit_pattern = Genarg.make0 "ltac2:pattern" let is_constructor qid = let (_, id) = repr_qualid qid in diff --git a/src/tac2env.mli b/src/tac2env.mli index 8ab9656cb9..e26109b691 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -110,6 +110,8 @@ val coq_prefix : ModPath.t val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern, Pattern.constr_pattern) genarg_type + (** {5 Helper functions} *) val is_constructor : qualid -> bool diff --git a/theories/Init.v b/theories/Init.v index c0a73576d3..803e48e352 100644 --- a/theories/Init.v +++ b/theories/Init.v @@ -27,6 +27,7 @@ Ltac2 Type constant. Ltac2 Type inductive. Ltac2 Type constructor. Ltac2 Type projection. +Ltac2 Type pattern. Ltac2 Type constr. Ltac2 Type message. @@ -56,3 +57,6 @@ Ltac2 Type exn ::= [ Not_focussed ]. Ltac2 Type exn ::= [ Not_found ]. (** Used when something is missing. *) + +Ltac2 Type exn ::= [ Match_failure ]. +(** Used to signal a pattern didn't match a term. *) diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 0d6c8f232a..9aaee850cd 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -15,4 +15,5 @@ Require Ltac2.Array. Require Ltac2.Message. Require Ltac2.Constr. Require Ltac2.Control. +Require Ltac2.Pattern. Require Ltac2.Std. diff --git a/theories/Pattern.v b/theories/Pattern.v new file mode 100644 index 0000000000..c2ba4162e8 --- /dev/null +++ b/theories/Pattern.v @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> (ident * constr) list := + "ltac2" "pattern_matches". +(** If the term matches the pattern, returns the bound variables. If it doesn't, + fail with [Match_failure]. Panics if not focussed. *) + +Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := + "ltac2" "pattern_matches_subterm". +(** Returns a stream of results corresponding to all of the subterms of the term + that matches the pattern as in [matches]. The stream is encoded as a + backtracking value whose last exception is [Match_failure]. The additional + value compared to [matches] is the context of the match, to be filled with + the instantiate function. *) + +Ltac2 @ external instantiate : context -> constr -> constr := + "ltac2" "pattern_instantiate". +(** Fill the hole of a context with the given term. *) -- cgit v1.2.3 From 6b3fd33d7e3b775ce6afe38f7b16d4b11bdccdb3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 27 Jul 2017 16:05:34 +0200 Subject: Fix expansion of toplevel let-rec after the constructor / constant split. --- src/tac2entries.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index da0e213340..6fce739d30 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -269,8 +269,7 @@ let inline_rec_tactic tactics = let map_body ((loc, id), _, e) = (loc, Name id), None, e in let bnd = List.map map_body tactics in let pat_of_id (loc, id) = - let qid = (loc, qualid_of_ident id) in - (CPatRef (Option.default dummy_loc loc, RelId qid, []), None) + (CPatVar (loc, Name id), None) in let var_of_id (loc, id) = let qid = (loc, qualid_of_ident id) in -- cgit v1.2.3 From bc9a18bd48fb43a2aedd9c11df7a3e4244074120 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 27 Jul 2017 16:20:16 +0200 Subject: Using thunks in the horrible Ltac2 example. --- tests/stuff/ltac2.v | 37 ++++++++++++++++++++++--------------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 36ea1ef4c1..86ab5afb17 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -9,12 +9,12 @@ Print Ltac2 foo. Import Control. -Ltac2 exact x := refine (fun _ => x). +Ltac2 exact x := refine (fun () => x). Print Ltac2 refine. Print Ltac2 exact. -Ltac2 foo' _ := ident:(bla). +Ltac2 foo' () := ident:(bla). Print Ltac2 foo'. @@ -36,7 +36,7 @@ Fail Ltac2 qux0 := Foo None. Ltac2 Type 'a ref := { mutable contents : 'a }. Fail Ltac2 qux0 := { contents := None }. -Ltac2 foo0 _ := { contents := None }. +Ltac2 foo0 () := { contents := None }. Print Ltac2 foo0. @@ -51,7 +51,7 @@ Print Ltac2 qux2. Import Control. -Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun _ => hyp x))). +Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). Print Ltac2 qux3. @@ -70,9 +70,9 @@ end in aux n. Print Ltac2 message_of_nat. -Ltac2 numgoals (_ : unit) := +Ltac2 numgoals () := let r := { contents := O } in - enter (fun _ => r.(contents) := S (r.(contents))); + enter (fun () => r.(contents) := S (r.(contents))); r.(contents). Print Ltac2 numgoals. @@ -80,19 +80,19 @@ Print Ltac2 numgoals. Goal True /\ False. Proof. let n := numgoals () in Message.print (message_of_nat n). -refine (fun _ => open_constr:((fun x => conj _ _) 0)); (). +refine (fun () => open_constr:((fun x => conj _ _) 0)); (). let n := numgoals () in Message.print (message_of_nat n). Fail (hyp ident:(x)). -Fail (enter (fun _ => hyp ident:(There_is_no_spoon); ())). +Fail (enter (fun () => hyp ident:(There_is_no_spoon); ())). -enter (fun _ => Message.print (Message.of_string "foo")). +enter (fun () => Message.print (Message.of_string "foo")). -enter (fun _ => Message.print (Message.of_constr (goal ()))). -Fail enter (fun _ => Message.print (Message.of_constr (qux3 ident:(x)))). -enter (fun _ => plus (fun _ => constr:(_); ()) (fun _ => ())). +enter (fun () => Message.print (Message.of_constr (goal ()))). +Fail enter (fun () => Message.print (Message.of_constr (qux3 ident:(x)))). +enter (fun () => plus (fun () => constr:(_); ()) (fun _ => ())). plus - (fun _ => enter (fun _ => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). + (fun () => enter (fun () => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). let x := { contents := 0 } in let x := x.(contents) := x.(contents) in x. Abort. @@ -101,7 +101,7 @@ Ltac2 Type exn ::= [ Foo ]. Goal True. Proof. -plus (fun _ => zero Foo) (fun _ => ()). +plus (fun () => zero Foo) (fun _ => ()). Abort. Ltac2 Type exn ::= [ Bar (string) ]. @@ -120,7 +120,7 @@ Abort. Goal True. Proof. -let x _ := plus (fun _ => 0) (fun _ => 1) in +let x () := plus (fun () => 0) (fun _ => 1) in match case x with | Val x => match x with @@ -129,3 +129,10 @@ match case x with | Err x => Message.print (Message.of_string "Err") end. Abort. + +Ltac2 rec do n tac := match Int.equal n 0 with +| true => () +| false => tac (); do (Int.sub n 1) tac +end. + +Print Ltac2 do. -- cgit v1.2.3 From fee254e2f7a343629df31d5a39780ca4698de571 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 27 Jul 2017 16:29:27 +0200 Subject: Cleaning up code in internalization. --- src/tac2entries.ml | 16 +++++++++++++--- src/tac2expr.mli | 11 ++++++++++- src/tac2intern.ml | 33 ++++++++++++++++++++------------- src/tac2print.ml | 4 ++-- 4 files changed, 45 insertions(+), 19 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 6fce739d30..5490f9d57f 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -78,7 +78,7 @@ let change_sp_label sp id = let push_typedef visibility sp kn (_, def) = match def with | GTydDef _ -> Tac2env.push_type visibility sp kn -| GTydAlg cstrs -> +| GTydAlg { galg_constructors = cstrs } -> (** Register constructors *) let iter (c, _) = let spc = change_sp_label sp c in @@ -107,7 +107,7 @@ let next i = let define_typedef kn (params, def as qdef) = match def with | GTydDef _ -> Tac2env.define_type kn qdef -| GTydAlg cstrs -> +| GTydAlg { galg_constructors = cstrs } -> (** Define constructors *) let constant = ref 0 in let nonconstant = ref 0 in @@ -665,7 +665,17 @@ let call ~default e = let register_prim_alg name params def = let id = Id.of_string name in let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in - let def = (params, GTydAlg def) in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) def in + let alg = { + galg_constructors = def; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + let def = (params, GTydAlg alg) in let def = { typdef_local = false; typdef_expr = def } in ignore (Lib.add_leaf id (inTypDef def)) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index b268e70cb3..e564dbde78 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -53,9 +53,18 @@ type 'a glb_typexpr = | GTypTuple of 'a glb_typexpr list | GTypRef of type_constant * 'a glb_typexpr list +type glb_alg_type = { + galg_constructors : (uid * int glb_typexpr list) list; + (** Constructors of the algebraic type *) + galg_nconst : int; + (** Number of constant constructors *) + galg_nnonconst : int; + (** Number of non-constant constructors *) +} + type glb_typedef = | GTydDef of int glb_typexpr option -| GTydAlg of (uid * int glb_typexpr list) list +| GTydAlg of glb_alg_type | GTydRec of (lid * mutable_flag * int glb_typexpr) list | GTydOpn diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 431b551191..86db803ea7 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -482,7 +482,7 @@ let check_elt_empty loc env t = match kind env t with | GTypRef (kn, _) -> let def = Tac2env.interp_type kn in match def with - | _, GTydAlg [] -> kn + | _, GTydAlg { galg_constructors = [] } -> kn | _ -> let name = env_name env in user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") @@ -856,17 +856,13 @@ and intern_case env loc e pl = let subst, tc = fresh_reftype env kn in let () = unify ~loc:(loc_of_tacexpr e) env t tc in let (params, def) = Tac2env.interp_type kn in - let cstrs = match def with + let galg = match def with | GTydAlg c -> c | _ -> assert false in - let count (const, nonconst) (c, args) = match args with - | [] -> (succ const, nonconst) - | _ :: _ -> (const, succ nonconst) - in - let nconst, nnonconst = List.fold_left count (0, 0) cstrs in - let const = Array.make nconst None in - let nonconst = Array.make nnonconst None in + let cstrs = galg.galg_constructors in + let const = Array.make galg.galg_nconst None in + let nonconst = Array.make galg.galg_nnonconst None in let ret = GTypVar (fresh_id env) in let rec intern_branch = function | [] -> () @@ -1114,7 +1110,17 @@ let intern_typedef self (ids, t) : glb_quant_typedef = | CTydAlg constrs -> let map (c, t) = (c, List.map intern t) in let constrs = List.map map constrs in - (count, GTydAlg constrs) + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) constrs in + let galg = { + galg_constructors = constrs; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + (count, GTydAlg galg) | CTydRec fields -> let map (c, mut, t) = (c, mut, intern t) in let fields = List.map map fields in @@ -1324,13 +1330,14 @@ let subst_typedef subst e = match e with | GTydDef t -> let t' = Option.smartmap (fun t -> subst_type subst t) t in if t' == t then e else GTydDef t' -| GTydAlg constrs -> +| GTydAlg galg -> let map (c, tl as p) = let tl' = List.smartmap (fun t -> subst_type subst t) tl in if tl' == tl then p else (c, tl') in - let constrs' = List.smartmap map constrs in - if constrs' == constrs then e else GTydAlg constrs' + let constrs' = List.smartmap map galg.galg_constructors in + if constrs' == galg.galg_constructors then e + else GTydAlg { galg with galg_constructors = constrs' } | GTydRec fields -> let map (c, mut, t as p) = let t' = subst_type subst t in diff --git a/src/tac2print.ml b/src/tac2print.ml index 2afcfb4a6e..aa8e1e98d5 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -175,7 +175,7 @@ let pr_glbexpr_gen lvl c = mt () (** FIXME when implemented *) | GTacCst (GCaseAlg tpe, n, cl) -> begin match Tac2env.interp_type tpe with - | _, GTydAlg def -> + | _, GTydAlg { galg_constructors = def } -> let paren = match lvl with | E0 -> paren | E1 | E2 | E3 | E4 | E5 -> fun x -> x @@ -202,7 +202,7 @@ let pr_glbexpr_gen lvl c = let br = match info with | GCaseAlg kn -> let def = match Tac2env.interp_type kn with - | _, GTydAlg def -> def + | _, GTydAlg { galg_constructors = def } -> def | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false in let br = order_branches cst_br ncst_br def in -- cgit v1.2.3 From 86e7ec3bd7b26b1d377c8397b62346f5e44f5d87 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 27 Jul 2017 16:50:25 +0200 Subject: Factorizing code for constructors and tuples. --- src/g_ltac2.ml4 | 23 ++-- src/tac2core.ml | 6 +- src/tac2entries.ml | 11 +- src/tac2expr.mli | 20 ++-- src/tac2intern.ml | 321 ++++++++++++++++++++++------------------------------ src/tac2intern.mli | 2 +- src/tac2print.ml | 24 ++-- tests/stuff/ltac2.v | 1 + 8 files changed, 186 insertions(+), 222 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index d7d376f88a..7ee9d7e282 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -47,15 +47,16 @@ GEXTEND Gram else CErrors.user_err ~loc:!@loc (Pp.str "Syntax error") | id = Prim.qualid -> pattern_of_qualid !@loc id - | "["; "]" -> CPatRef (!@loc, AbsKn Tac2core.Core.c_nil, []) + | "["; "]" -> CPatRef (!@loc, AbsKn (Other Tac2core.Core.c_nil), []) | p1 = tac2pat; "::"; p2 = tac2pat -> - CPatRef (!@loc, AbsKn Tac2core.Core.c_cons, [p1; p2]) + CPatRef (!@loc, AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) ] | "0" [ "_" -> CPatVar (Some !@loc, Anonymous) - | "()" -> CPatTup (Loc.tag ~loc:!@loc []) + | "()" -> CPatRef (!@loc, AbsKn (Tuple 0), []) | id = Prim.qualid -> pattern_of_qualid !@loc id - | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> CPatTup (Loc.tag ~loc:!@loc pl) ] + | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> + CPatRef (!@loc, AbsKn (Tuple (List.length pl)), pl) ] ] ; tac2expr: @@ -73,12 +74,14 @@ GEXTEND Gram [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, RelId qid, r) - | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> CTacTup (Loc.tag ~loc:!@loc (e0 :: el)) ] + | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> + let el = e0 :: el in + CTacApp (!@loc, CTacCst (!@loc, AbsKn (Tuple (List.length el))), el) ] | "0" [ "("; a = tac2expr LEVEL "5"; ")" -> a | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) - | "()" -> CTacTup (Loc.tag ~loc:!@loc []) - | "("; ")" -> CTacTup (Loc.tag ~loc:!@loc []) + | "()" -> CTacCst (!@loc, AbsKn (Tuple 0)) + | "("; ")" -> CTacCst (!@loc, AbsKn (Tuple 0)) | "["; a = LIST0 tac2expr LEVEL "1" SEP ";"; "]" -> CTacLst (Loc.tag ~loc:!@loc a) | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) | a = tactic_atom -> a ] @@ -104,7 +107,7 @@ GEXTEND Gram [ [ n = Prim.integer -> CTacAtm (Loc.tag ~loc:!@loc (AtmInt n)) | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) | id = Prim.qualid -> - if Tac2env.is_constructor (snd id) then CTacCst (RelId id) else CTacRef (RelId id) + if Tac2env.is_constructor (snd id) then CTacCst (!@loc, RelId id) else CTacRef (RelId id) | "@"; id = Prim.ident -> inj_ident !@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c @@ -123,7 +126,9 @@ GEXTEND Gram [ "5" RIGHTA [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> CTypTuple (!@loc, t :: tl) ] + [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + let tl = t :: tl in + CTypRef (!@loc, AbsKn (Tuple (List.length tl)), tl) ] | "1" LEFTA [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, RelId qid, [t]) ] | "0" diff --git a/src/tac2core.ml b/src/tac2core.ml index ab1eaec9d9..a3678d1ad0 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -844,7 +844,7 @@ let dummy_loc = Loc.make_loc (-1, -1) let rthunk e = let loc = Tac2intern.loc_of_tacexpr e in - let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn Core.t_unit, []))] in + let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other Core.t_unit), []))] in CTacFun (loc, var, e) let add_generic_scope s entry arg = @@ -905,9 +905,9 @@ let () = add_scope "opt" begin function let scope = Extend.Aopt scope in let act opt = match opt with | None -> - CTacCst (AbsKn Core.c_none) + CTacCst (dummy_loc, AbsKn (Other Core.c_none)) | Some x -> - CTacApp (dummy_loc, CTacCst (AbsKn Core.c_some), [act x]) + CTacApp (dummy_loc, CTacCst (dummy_loc, AbsKn (Other Core.c_some)), [act x]) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 5490f9d57f..70f1b583e0 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -655,7 +655,7 @@ let solve default tac = let call ~default e = let loc = loc_of_tacexpr e in - let (e, (_, t)) = intern e in + let (e, t) = intern e in let () = check_unit ~loc t in let tac = Tac2interp.interp Id.Map.empty e in solve default (Proofview.tclIGNORE tac) @@ -681,12 +681,17 @@ let register_prim_alg name params def = let coq_def n = KerName.make2 Tac2env.coq_prefix (Label.make n) +let def_unit = { + typdef_local = false; + typdef_expr = 0, GTydDef (Some (GTypRef (Tuple 0, []))); +} + let t_list = coq_def "list" let _ = Mltop.declare_cache_obj begin fun () -> - register_prim_alg "unit" 0 ["()", []]; + ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); register_prim_alg "list" 1 [ ("[]", []); - ("::", [GTypVar 0; GTypRef (t_list, [GTypVar 0])]); + ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); ]; end "ltac2_plugin" diff --git a/src/tac2expr.mli b/src/tac2expr.mli index e564dbde78..668bc0dad1 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -33,13 +33,16 @@ type ml_tactic_name = { mltac_tactic : string; } +type 'a or_tuple = +| Tuple of int +| Other of 'a + (** {5 Type syntax} *) type raw_typexpr = | CTypVar of Name.t located | CTypArrow of Loc.t * raw_typexpr * raw_typexpr -| CTypTuple of Loc.t * raw_typexpr list -| CTypRef of Loc.t * type_constant or_relid * raw_typexpr list +| CTypRef of Loc.t * type_constant or_tuple or_relid * raw_typexpr list type raw_typedef = | CTydDef of raw_typexpr option @@ -50,8 +53,7 @@ type raw_typedef = type 'a glb_typexpr = | GTypVar of 'a | GTypArrow of 'a glb_typexpr * 'a glb_typexpr -| GTypTuple of 'a glb_typexpr list -| GTypRef of type_constant * 'a glb_typexpr list +| GTypRef of type_constant or_tuple * 'a glb_typexpr list type glb_alg_type = { galg_constructors : (uid * int glb_typexpr list) list; @@ -82,17 +84,15 @@ type atom = (** Tactic expressions *) type raw_patexpr = | CPatVar of Name.t located -| CPatRef of Loc.t * ltac_constructor or_relid * raw_patexpr list -| CPatTup of raw_patexpr list located +| CPatRef of Loc.t * ltac_constructor or_tuple or_relid * raw_patexpr list type raw_tacexpr = | CTacAtm of atom located | CTacRef of ltac_constant or_relid -| CTacCst of ltac_constructor or_relid +| CTacCst of Loc.t * ltac_constructor or_tuple or_relid | CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list | CTacLet of Loc.t * rec_flag * (Name.t located * raw_typexpr option * raw_tacexpr) list * raw_tacexpr -| CTacTup of raw_tacexpr list located | CTacArr of raw_tacexpr list located | CTacLst of raw_tacexpr list located | CTacCnv of Loc.t * raw_tacexpr * raw_typexpr @@ -107,9 +107,7 @@ and raw_taccase = raw_patexpr * raw_tacexpr and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list -type case_info = -| GCaseTuple of int -| GCaseAlg of type_constant +type case_info = type_constant or_tuple type 'a open_match = { opn_match : 'a; diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 86db803ea7..e460111fc1 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -27,8 +27,8 @@ let t_array = coq_type "array" let t_unit = coq_type "unit" let t_list = coq_type "list" -let c_nil = GTacCst (GCaseAlg t_list, 0, []) -let c_cons e el = GTacCst (GCaseAlg t_list, 0, [e; el]) +let c_nil = GTacCst (Other t_list, 0, []) +let c_cons e el = GTacCst (Other t_list, 0, [e; el]) (** Union find *) @@ -191,12 +191,10 @@ let loc_of_tacexpr = function | CTacAtm (loc, _) -> Option.default dummy_loc loc | CTacRef (RelId (loc, _)) -> Option.default dummy_loc loc | CTacRef (AbsKn _) -> dummy_loc -| CTacCst (RelId (loc, _)) -> Option.default dummy_loc loc -| CTacCst (AbsKn _) -> dummy_loc +| CTacCst (loc, _) -> loc | CTacFun (loc, _, _) -> loc | CTacApp (loc, _, _) -> loc | CTacLet (loc, _, _, _) -> loc -| CTacTup (loc, _) -> Option.default dummy_loc loc | CTacArr (loc, _) -> Option.default dummy_loc loc | CTacLst (loc, _) -> Option.default dummy_loc loc | CTacCnv (loc, _, _) -> loc @@ -210,7 +208,6 @@ let loc_of_tacexpr = function let loc_of_patexpr = function | CPatVar (loc, _) -> Option.default dummy_loc loc | CPatRef (loc, _, _) -> loc -| CPatTup (loc, _) -> Option.default dummy_loc loc let error_nargs_mismatch loc nargs nfound = user_err ~loc (str "Constructor expects " ++ int nargs ++ @@ -225,7 +222,6 @@ let error_nparams_mismatch loc nargs nfound = let rec subst_type subst (t : 'a glb_typexpr) = match t with | GTypVar id -> subst id | GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) -| GTypTuple tl -> GTypTuple (List.map (fun t -> subst_type subst t) tl) | GTypRef (qid, args) -> GTypRef (qid, List.map (fun t -> subst_type subst t) args) @@ -237,7 +233,8 @@ let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with | RelId (loc, qid) -> let (dp, id) = repr_qualid qid in if DirPath.is_empty dp && Id.Map.mem id env.env_rec then - Id.Map.find id env.env_rec + let (kn, n) = Id.Map.find id env.env_rec in + (Other kn, n) else let kn = try Tac2env.locate_type qid @@ -245,17 +242,20 @@ let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) in let (nparams, _) = Tac2env.interp_type kn in - (kn, nparams) - | AbsKn kn -> + (Other kn, nparams) + | AbsKn (Other kn) -> let (nparams, _) = Tac2env.interp_type kn in - (kn, nparams) + (Other kn, nparams) + | AbsKn (Tuple n) -> + (Tuple n, n) in let nargs = List.length args in let () = if not (Int.equal nparams nargs) then let loc, qid = match rel with | RelId lid -> lid - | AbsKn kn -> Some loc, shortest_qualid_of_type kn + | AbsKn (Other kn) -> Some loc, shortest_qualid_of_type kn + | AbsKn (Tuple _) -> assert false in user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ @@ -263,7 +263,6 @@ let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with in GTypRef (kn, List.map (fun t -> intern_type env t) args) | CTypArrow (loc, t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) -| CTypTuple (loc, tl) -> GTypTuple (List.map (fun t -> intern_type env t) tl) let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = let (n, t) = t in @@ -280,8 +279,11 @@ let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = in subst_type substf t -let fresh_reftype env (kn : KerName.t) = - let (n, _) = Tac2env.interp_type kn in +let fresh_reftype env (kn : KerName.t or_tuple) = + let n = match kn with + | Other kn -> fst (Tac2env.interp_type kn) + | Tuple n -> n + in let subst = Array.init n (fun _ -> fresh_id env) in let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in (subst, t) @@ -310,9 +312,9 @@ let rec kind env t = match t with | None -> GTypVar id | Some t -> kind env t end -| GTypRef (kn, tl) -> +| GTypRef (Other kn, tl) -> if is_unfoldable kn then kind env (unfold env kn tl) else t -| GTypArrow _ | GTypTuple _ -> t +| GTypArrow _ | GTypRef (Tuple _, _) -> t exception Occur @@ -321,8 +323,6 @@ let rec occur_check env id t = match kind env t with | GTypArrow (t1, t2) -> let () = occur_check env id t1 in occur_check env id t2 -| GTypTuple tl -> - List.iter (fun t -> occur_check env id t) tl | GTypRef (kn, tl) -> List.iter (fun t -> occur_check env id t) tl @@ -331,24 +331,25 @@ exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr let unify_var env id t = match kind env t with | GTypVar id' -> if not (UF.equal id id') then UF.union id id' env.env_cst -| GTypArrow _ | GTypRef _ | GTypTuple _ -> +| GTypArrow _ | GTypRef _ -> try let () = occur_check env id t in UF.set id t env.env_cst with Occur -> raise (CannotUnify (GTypVar id, t)) +let eq_or_tuple eq t1 t2 = match t1, t2 with +| Tuple n1, Tuple n2 -> Int.equal n1 n2 +| Other o1, Other o2 -> eq o1 o2 +| _ -> false + let rec unify env t1 t2 = match kind env t1, kind env t2 with | GTypVar id, t | t, GTypVar id -> unify_var env id t | GTypArrow (t1, u1), GTypArrow (t2, u2) -> let () = unify env t1 t2 in unify env u1 u2 -| GTypTuple tl1, GTypTuple tl2 -> - if Int.equal (List.length tl1) (List.length tl2) then - List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 - else raise (CannotUnify (t1, t2)) | GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> - if KerName.equal kn1 kn2 then + if eq_or_tuple KerName.equal kn1 kn2 then List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 else raise (CannotUnify (t1, t2)) | _ -> raise (CannotUnify (t1, t2)) @@ -371,7 +372,7 @@ let unify_arrow ?loc env ft args = let ft = GTypVar (fresh_id env) in let () = unify_var env id (GTypArrow (t, ft)) in iter ft args true - | (GTypRef _ | GTypTuple _), _ :: _ -> + | GTypRef _, _ :: _ -> let name = env_name env in if is_fun then user_err ?loc (str "This function has type " ++ pr_glbtype name ft0 ++ @@ -395,10 +396,10 @@ let is_pure_constructor kn = let rec is_value = function | GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true | GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false -| GTacCst (GCaseTuple _, _, el) -> List.for_all is_value el +| GTacCst (Tuple _, _, el) -> List.for_all is_value el | GTacCst (_, _, []) -> true | GTacOpn (_, el) -> List.for_all is_value el -| GTacCst (GCaseAlg kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el | GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ | GTacWth _ -> false @@ -411,7 +412,6 @@ let is_rec_rhs = function let rec fv_type f t accu = match t with | GTypVar id -> f id accu | GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) -| GTypTuple tl -> List.fold_left (fun accu t -> fv_type f t accu) accu tl | GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl let fv_env env = @@ -468,18 +468,19 @@ let warn_redundant_clause = let check_elt_unit loc env t = let maybe_unit = match kind env t with | GTypVar _ -> true - | GTypArrow _ | GTypTuple _ -> false - | GTypRef (kn, _) -> KerName.equal kn t_unit + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false in if not maybe_unit then warn_not_unit ~loc () let check_elt_empty loc env t = match kind env t with | GTypVar _ -> user_err ~loc (str "Cannot infer an empty type for this expression") -| GTypArrow _ | GTypTuple _ -> +| GTypArrow _ | GTypRef (Tuple _, _) -> let name = env_name env in user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") -| GTypRef (kn, _) -> +| GTypRef (Other kn, _) -> let def = Tac2env.interp_type kn in match def with | _, GTydAlg { galg_constructors = [] } -> kn @@ -488,10 +489,14 @@ let check_elt_empty loc env t = match kind env t with user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") let check_unit ?loc t = - let maybe_unit = match t with + let env = empty_env () in + (** Should not matter, t should be closed. *) + let t = fresh_type_scheme env t in + let maybe_unit = match kind env t with | GTypVar _ -> true - | GTypArrow _ | GTypTuple _ -> false - | GTypRef (kn, _) -> KerName.equal kn t_unit + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false in if not maybe_unit then warn_not_unit ?loc () @@ -520,15 +525,11 @@ let get_constructor env var = match var with | RelId (loc, qid) -> let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in begin match c with - | Some knc -> - let kn = Tac2env.interp_constructor knc in - (kn, knc) + | Some knc -> Other knc | None -> CErrors.user_err ?loc (str "Unbound constructor " ++ pr_qualid qid) end -| AbsKn knc -> - let kn = Tac2env.interp_constructor knc in - (kn, knc) +| AbsKn knc -> knc let get_projection var = match var with | RelId (loc, qid) -> @@ -540,37 +541,33 @@ let get_projection var = match var with Tac2env.interp_projection kn let intern_atm env = function -| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (t_int, [])) -| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (t_string, [])) +| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (Other t_int, [])) +| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (Other t_string, [])) -let invalid_pattern ?loc kn t = - let pt = match t with - | GCaseAlg kn' -> pr_typref kn - | GCaseTuple n -> str "tuple" +let invalid_pattern ?loc kn kn' = + let pr t = match t with + | Other kn' -> str "type " ++ pr_typref kn' + | Tuple n -> str "tuple of size " ++ int n in - user_err ?loc (str "Invalid pattern, expected a pattern for type " ++ - pr_typref kn ++ str ", found a pattern of type " ++ pt) (** FIXME *) + user_err ?loc (str "Invalid pattern, expected a pattern for " ++ + pr kn ++ str ", found a pattern for " ++ pr kn') (** FIXME *) (** Pattern view *) type glb_patexpr = | GPatVar of Name.t -| GPatRef of ltac_constructor * glb_patexpr list -| GPatTup of glb_patexpr list +| GPatRef of ltac_constructor or_tuple * glb_patexpr list let rec intern_patexpr env = function | CPatVar (_, na) -> GPatVar na | CPatRef (_, qid, pl) -> - let (_, kn) = get_constructor env qid in + let kn = get_constructor env qid in GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) -| CPatTup (_, pl) -> - GPatTup (List.map (fun p -> intern_patexpr env p) pl) type pattern_kind = | PKind_empty -| PKind_variant of type_constant +| PKind_variant of type_constant or_tuple | PKind_open of type_constant -| PKind_tuple of int | PKind_any let get_pattern_kind env pl = match pl with @@ -582,11 +579,11 @@ let get_pattern_kind env pl = match pl with | [] -> PKind_any | p :: pl -> get_kind p pl end - | GPatRef (kn, pl) -> + | GPatRef (Other kn, pl) -> let data = Tac2env.interp_constructor kn in if Option.is_empty data.cdata_indx then PKind_open data.cdata_type - else PKind_variant data.cdata_type - | GPatTup tp -> PKind_tuple (List.length tp) + else PKind_variant (Other data.cdata_type) + | GPatRef (Tuple _, tp) -> PKind_variant (Tuple (List.length tp)) in get_kind p pl @@ -611,9 +608,8 @@ let rec intern_rec env = function let (_, _, sch) = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) end -| CTacCst qid as e -> - let loc = loc_of_tacexpr e in - let (_, kn) = get_constructor env qid in +| CTacCst (loc, qid) -> + let kn = get_constructor env qid in intern_constructor env loc kn [] | CTacFun (loc, bnd, e) -> (** Expand pattern: [fun p => t] becomes [fun x => match x with p => t end] *) @@ -646,9 +642,8 @@ let rec intern_rec env = function let (e, t) = intern_rec env e in let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in (GTacFun (nas, e), t) -| CTacApp (loc, CTacCst qid, args) as e -> - let (_, kn) = get_constructor env qid in - let loc = loc_of_tacexpr e in +| CTacApp (loc, CTacCst (_, qid), args) -> + let kn = get_constructor env qid in intern_constructor env loc kn args | CTacApp (loc, f, args) -> let loc = loc_of_tacexpr f in @@ -688,31 +683,22 @@ let rec intern_rec env = function (GTacLet (false, el, e), t) | CTacLet (loc, true, el, e) -> intern_let_rec env loc el e -| CTacTup (loc, []) -> - (GTacCst (GCaseAlg t_unit, 0, []), GTypRef (t_unit, [])) -| CTacTup (loc, el) -> - let fold e (el, tl) = - let (e, t) = intern_rec env e in - (e :: el, t :: tl) - in - let (el, tl) = List.fold_right fold el ([], []) in - (GTacCst (GCaseTuple (List.length el), 0, el), GTypTuple tl) | CTacArr (loc, []) -> let id = fresh_id env in - (GTacArr [], GTypRef (t_int, [GTypVar id])) + (GTacArr [], GTypRef (Other t_int, [GTypVar id])) | CTacArr (loc, e0 :: el) -> let (e0, t0) = intern_rec env e0 in let fold e el = intern_rec_with_constraint env e t0 :: el in let el = e0 :: List.fold_right fold el [] in - (GTacArr el, GTypRef (t_array, [t0])) + (GTacArr el, GTypRef (Other t_array, [t0])) | CTacLst (loc, []) -> let id = fresh_id env in - (c_nil, GTypRef (t_list, [GTypVar id])) + (c_nil, GTypRef (Other t_list, [GTypVar id])) | CTacLst (loc, e0 :: el) -> let (e0, t0) = intern_rec env e0 in let fold e el = c_cons (intern_rec_with_constraint env e t0) el in let el = c_cons e0 (List.fold_right fold el c_nil) in - (el, GTypRef (t_list, [t0])) + (el, GTypRef (Other t_list, [t0])) | CTacCnv (loc, e, tc) -> let (e, t) = intern_rec env e in let tc = intern_type env tc in @@ -733,7 +719,7 @@ let rec intern_rec env = function let (e, t) = intern_rec env e in let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (pinfo.pdata_type, params) in + let exp = GTypRef (Other pinfo.pdata_type, params) in let () = unify ~loc env t exp in let substf i = GTypVar subst.(i) in let ret = subst_type substf pinfo.pdata_ptyp in @@ -750,12 +736,12 @@ let rec intern_rec env = function in let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (pinfo.pdata_type, params) in + let exp = GTypRef (Other pinfo.pdata_type, params) in let e = intern_rec_with_constraint env e exp in let substf i = GTypVar subst.(i) in let ret = subst_type substf pinfo.pdata_ptyp in let r = intern_rec_with_constraint env r ret in - (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (t_unit, [])) + (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) | CTacExt (loc, ext) -> let open Genintern in let GenArg (Rawwit tag, _) = ext in @@ -766,7 +752,7 @@ let rec intern_rec env = function let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in let (_, ext) = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> generic_intern ist ext) () in - (GTacExt ext, GTypRef (tpe.ml_type, [])) + (GTacExt ext, GTypRef (Other tpe.ml_type, [])) and intern_rec_with_constraint env e exp = let loc = loc_of_tacexpr e in @@ -830,39 +816,21 @@ and intern_case env loc e pl = | PKind_empty -> let kn = check_elt_empty loc env t in let r = fresh_id env in - (GTacCse (e', GCaseAlg kn, [||], [||]), GTypVar r) - | PKind_tuple len -> - begin match pl with - | [] -> assert false - | [CPatTup (_, []), b] -> - let () = unify ~loc:(loc_of_tacexpr e) env t (GTypRef (t_unit, [])) in - let (b, tb) = intern_rec env b in - (GTacCse (e', GCaseAlg t_unit, [|b|], [||]), tb) - | [CPatTup (_, pl), b] -> - let map = function - | CPatVar (_, na) -> na - | p -> todo ~loc:(loc_of_patexpr p) () - in - let ids = List.map map pl in - let targs = List.map (fun _ -> GTypVar (fresh_id env)) pl in - let tc = GTypTuple targs in - let () = unify ~loc:(loc_of_tacexpr e) env t tc in - let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env ids targs in - let (b, tb) = intern_rec env b in - (GTacCse (e', GCaseTuple len, [||], [|Array.of_list ids, b|]), tb) - | (p, _) :: _ -> todo ~loc:(loc_of_patexpr p) () - end + (GTacCse (e', Other kn, [||], [||]), GTypVar r) | PKind_variant kn -> let subst, tc = fresh_reftype env kn in let () = unify ~loc:(loc_of_tacexpr e) env t tc in - let (params, def) = Tac2env.interp_type kn in - let galg = match def with - | GTydAlg c -> c - | _ -> assert false + let (nconst, nnonconst, arities) = match kn with + | Tuple 0 -> 1, 0, [0] + | Tuple n -> 0, 1, [n] + | Other kn -> + let (_, def) = Tac2env.interp_type kn in + let galg = match def with | GTydAlg c -> c | _ -> assert false in + let arities = List.map (fun (_, args) -> List.length args) galg.galg_constructors in + galg.galg_nconst, galg.galg_nnonconst, arities in - let cstrs = galg.galg_constructors in - let const = Array.make galg.galg_nconst None in - let nonconst = Array.make galg.galg_nnonconst None in + let const = Array.make nconst None in + let nonconst = Array.make nnonconst None in let ret = GTypVar (fresh_id env) in let rec intern_branch = function | [] -> () @@ -873,8 +841,8 @@ and intern_case env loc e pl = let () = check_redundant_clause rem in let (br', brT) = intern_rec env br in (** Fill all remaining branches *) - let fill (ncst, narg) (_, args) = - if List.is_empty args then + let fill (ncst, narg) arity = + if Int.equal arity 0 then let () = if Option.is_empty const.(ncst) then const.(ncst) <- Some br' in @@ -882,19 +850,25 @@ and intern_case env loc e pl = else let () = if Option.is_empty nonconst.(narg) then - let ids = Array.map_of_list (fun _ -> Anonymous) args in + let ids = Array.make arity Anonymous in nonconst.(narg) <- Some (ids, br') in (ncst, succ narg) in - let _ = List.fold_left fill (0, 0) cstrs in + let _ = List.fold_left fill (0, 0) arities in brT | CPatRef (loc, qid, args) -> - let (data, _) = get_constructor env qid in + let knc = get_constructor env qid in + let kn', index, arity = match knc with + | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) + | Other knc -> + let data = Tac2env.interp_constructor knc in + let index = Option.get data.cdata_indx in + Other data.cdata_type, index, data.cdata_args + in let () = - let kn' = data.cdata_type in - if not (KerName.equal kn kn') then - invalid_pattern ~loc kn (GCaseAlg kn') + if not (eq_or_tuple KerName.equal kn kn') then + invalid_pattern ~loc kn kn' in let get_id = function | CPatVar (_, na) -> na @@ -902,7 +876,7 @@ and intern_case env loc e pl = in let ids = List.map get_id args in let nids = List.length ids in - let nargs = List.length data.cdata_args in + let nargs = List.length arity in let () = if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids in @@ -912,13 +886,9 @@ and intern_case env loc e pl = let tpe = subst_type subst tpe in push_name id (monomorphic tpe) env in - let nenv = List.fold_left2 fold env ids data.cdata_args in + let nenv = List.fold_left2 fold env ids arity in let (br', brT) = intern_rec nenv br in let () = - let index = match data.cdata_indx with - | Some i -> i - | None -> assert false - in if List.is_empty args then if Option.is_empty const.(index) then const.(index) <- Some br' else warn_redundant_clause ~loc () @@ -928,8 +898,6 @@ and intern_case env loc e pl = else warn_redundant_clause ~loc () in brT - | CPatTup (loc, tup) -> - invalid_pattern ?loc kn (GCaseTuple (List.length tup)) in let () = unify ~loc:(loc_of_tacexpr br) env ret tbr in intern_branch rem @@ -941,10 +909,10 @@ and intern_case env loc e pl = in let const = Array.map map const in let nonconst = Array.map map nonconst in - let ce = GTacCse (e', GCaseAlg kn, const, nonconst) in + let ce = GTacCse (e', kn, const, nonconst) in (ce, ret) | PKind_open kn -> - let subst, tc = fresh_reftype env kn in + let subst, tc = fresh_reftype env (Other kn) in let () = unify ~loc:(loc_of_tacexpr e) env t tc in let ret = GTypVar (fresh_id env) in let rec intern_branch map = function @@ -961,15 +929,19 @@ and intern_case env loc e pl = | GPatRef (knc, args) -> let get = function | GPatVar na -> na - | GPatRef _ | GPatTup _ -> + | GPatRef _ -> user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) in let loc = loc_of_patexpr pat in + let knc = match knc with + | Other knc -> knc + | Tuple n -> invalid_pattern ~loc (Other kn) (Tuple n) + in let ids = List.map get args in let data = Tac2env.interp_constructor knc in let () = if not (KerName.equal kn data.cdata_type) then - invalid_pattern ~loc kn (GCaseAlg data.cdata_type) + invalid_pattern ~loc (Other kn) (Other data.cdata_type) in let nids = List.length ids in let nargs = List.length data.cdata_args in @@ -992,29 +964,36 @@ and intern_case env loc e pl = KNmap.add knc (Anonymous, Array.of_list ids, br') map in intern_branch map rem - | GPatTup tup -> - invalid_pattern ~loc kn (GCaseTuple (List.length tup)) in let (map, def) = intern_branch KNmap.empty pl in (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) -and intern_constructor env loc kn args = +and intern_constructor env loc kn args = match kn with +| Other kn -> let cstr = interp_constructor kn in let nargs = List.length cstr.cdata_args in if Int.equal nargs (List.length args) then let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in let substf i = GTypVar subst.(i) in let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in - let ans = GTypRef (cstr.cdata_type, List.init cstr.cdata_prms (fun i -> GTypVar subst.(i))) in + let targs = List.init cstr.cdata_prms (fun i -> GTypVar subst.(i)) in + let ans = GTypRef (Other cstr.cdata_type, targs) in let map arg tpe = intern_rec_with_constraint env arg tpe in let args = List.map2 map args types in match cstr.cdata_indx with | Some idx -> - (GTacCst (GCaseAlg cstr.cdata_type, idx, args), ans) + (GTacCst (Other cstr.cdata_type, idx, args), ans) | None -> (GTacOpn (kn, args), ans) else error_nargs_mismatch loc nargs (List.length args) +| Tuple n -> + assert (Int.equal n (List.length args)); + let types = List.init n (fun i -> GTypVar (fresh_id env)) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + let ans = GTypRef (Tuple n, types) in + GTacCst (Tuple n, 0, args), ans and intern_record env loc fs = let map (proj, e) = @@ -1062,7 +1041,7 @@ and intern_record env loc fs = in let args = Array.map_to_list Option.get args in let tparam = List.init params (fun i -> GTypVar subst.(i)) in - (GTacCst (GCaseAlg kn, 0, args), GTypRef (kn, tparam)) + (GTacCst (Other kn, 0, args), GTypRef (Other kn, tparam)) let normalize env (count, vars) (t : UF.elt glb_typexpr) = let get_var id = @@ -1154,8 +1133,6 @@ let rec ids_of_pattern accu = function | CPatVar (_, Name id) -> Id.Set.add id accu | CPatRef (_, _, pl) -> List.fold_left ids_of_pattern accu pl -| CPatTup (_, pl) -> - List.fold_left ids_of_pattern accu pl let rec globalize ids e = match e with | CTacAtm _ -> e @@ -1165,9 +1142,9 @@ let rec globalize ids e = match e with | ArgVar _ -> e | ArgArg kn -> CTacRef (AbsKn kn) end -| CTacCst qid -> - let (_, knc) = get_constructor () qid in - CTacCst (AbsKn knc) +| CTacCst (loc, qid) -> + let knc = get_constructor () qid in + CTacCst (loc, AbsKn knc) | CTacFun (loc, bnd, e) -> let fold (pats, accu) (pat, t) = let accu = ids_of_pattern accu pat in @@ -1193,9 +1170,6 @@ let rec globalize ids e = match e with in let bnd = List.map map bnd in CTacLet (loc, isrec, bnd, e) -| CTacTup (loc, el) -> - let el = List.map (fun e -> globalize ids e) el in - CTacTup (loc, el) | CTacArr (loc, el) -> let el = List.map (fun e -> globalize ids e) el in CTacArr (loc, el) @@ -1239,18 +1213,21 @@ and globalize_case ids (p, e) = and globalize_pattern ids p = match p with | CPatVar _ -> p | CPatRef (loc, cst, pl) -> - let (_, knc) = get_constructor () cst in + let knc = get_constructor () cst in let cst = AbsKn knc in let pl = List.map (fun p -> globalize_pattern ids p) pl in CPatRef (loc, cst, pl) -| CPatTup (loc, pl) -> - let pl = List.map (fun p -> globalize_pattern ids p) pl in - CPatTup (loc, pl) (** Kernel substitution *) open Mod_subst +let subst_or_tuple f subst o = match o with +| Tuple _ -> o +| Other v -> + let v' = f subst v in + if v' == v then o else Other v' + let rec subst_type subst t = match t with | GTypVar _ -> t | GTypArrow (t1, t2) -> @@ -1258,20 +1235,11 @@ let rec subst_type subst t = match t with let t2' = subst_type subst t2 in if t1' == t1 && t2' == t2 then t else GTypArrow (t1', t2') -| GTypTuple tl -> - let tl'= List.smartmap (fun t -> subst_type subst t) tl in - if tl' == tl then t else GTypTuple tl' | GTypRef (kn, tl) -> - let kn' = subst_kn subst kn in + let kn' = subst_or_tuple subst_kn subst kn in let tl' = List.smartmap (fun t -> subst_type subst t) tl in if kn' == kn && tl' == tl then t else GTypRef (kn', tl') -let subst_case_info subst ci = match ci with -| GCaseAlg kn -> - let kn' = subst_kn subst kn in - if kn' == kn then ci else GCaseAlg kn' -| GCaseTuple _ -> ci - let rec subst_expr subst e = match e with | GTacAtm _ | GTacVar _ | GTacPrm _ -> e | GTacRef kn -> GTacRef (subst_kn subst kn) @@ -1284,18 +1252,13 @@ let rec subst_expr subst e = match e with | GTacArr el -> GTacArr (List.map (fun e -> subst_expr subst e) el) | GTacCst (t, n, el) as e0 -> - let t' = match t with - | GCaseAlg kn -> - let kn' = subst_kn subst kn in - if kn' == kn then t else GCaseAlg kn' - | GCaseTuple _ -> t - in + let t' = subst_or_tuple subst_kn subst t in let el' = List.smartmap (fun e -> subst_expr subst e) el in if t' == t && el' == el then e0 else GTacCst (t', n, el') | GTacCse (e, ci, cse0, cse1) -> let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in - let ci' = subst_case_info subst ci in + let ci' = subst_or_tuple subst_kn subst ci in GTacCse (subst_expr subst e, ci', cse0', cse1') | GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> let e' = subst_expr subst e in @@ -1358,7 +1321,7 @@ let subst_type_scheme subst (prm, t as sch) = let subst_or_relid subst ref = match ref with | RelId _ -> ref | AbsKn kn -> - let kn' = subst_kn subst kn in + let kn' = subst_or_tuple subst_kn subst kn in if kn' == kn then ref else AbsKn kn' let rec subst_rawtype subst t = match t with @@ -1367,9 +1330,6 @@ let rec subst_rawtype subst t = match t with let t1' = subst_rawtype subst t1 in let t2' = subst_rawtype subst t2 in if t1' == t1 && t2' == t2 then t else CTypArrow (loc, t1', t2') -| CTypTuple (loc, tl) -> - let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in - if tl' == tl then t else CTypTuple (loc, tl') | CTypRef (loc, ref, tl) -> let ref' = subst_or_relid subst ref in let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in @@ -1391,16 +1351,8 @@ let rec subst_rawpattern subst p = match p with | CPatVar _ -> p | CPatRef (loc, c, pl) -> let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in - let c' = match c with - | RelId _ -> c - | AbsKn kn -> - let kn' = subst_kn subst kn in - if kn' == kn then c else AbsKn kn' - in + let c' = subst_or_relid subst c in if pl' == pl && c' == c then p else CPatRef (loc, c', pl') -| CPatTup (loc, pl) -> - let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in - if pl' == pl then p else CPatTup (loc, pl') (** Used for notations *) let rec subst_rawexpr subst t = match t with @@ -1408,9 +1360,9 @@ let rec subst_rawexpr subst t = match t with | CTacRef ref -> let ref' = subst_tacref subst ref in if ref' == ref then t else CTacRef ref' -| CTacCst ref -> - let ref' = subst_tacref subst ref in - if ref' == ref then t else CTacCst ref' +| CTacCst (loc, ref) -> + let ref' = subst_or_relid subst ref in + if ref' == ref then t else CTacCst (loc, ref') | CTacFun (loc, bnd, e) -> let map (na, t as p) = let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in @@ -1432,9 +1384,6 @@ let rec subst_rawexpr subst t = match t with let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in if bnd' == bnd && e' == e then t else CTacLet (loc, isrec, bnd', e') -| CTacTup (loc, el) -> - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if el' == el then t else CTacTup (loc, el') | CTacArr (loc, el) -> let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in if el' == el then t else CTacArr (loc, el') diff --git a/src/tac2intern.mli b/src/tac2intern.mli index b2604c4ea7..ddec8eb7e4 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -21,7 +21,7 @@ val intern_open_type : raw_typexpr -> type_scheme (** Check that a term is a value. Only values are safe to marshall between processes. *) val is_value : glb_tacexpr -> bool -val check_unit : ?loc:Loc.t -> int glb_typexpr -> unit +val check_unit : ?loc:Loc.t -> type_scheme -> unit val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr diff --git a/src/tac2print.ml b/src/tac2print.ml index aa8e1e98d5..28f9516f65 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -30,20 +30,23 @@ type typ_level = | T1 | T0 +let t_unit = + KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string "unit")) + let pr_typref kn = Libnames.pr_qualid (Tac2env.shortest_qualid_of_type kn) let pr_glbtype_gen pr lvl c = let rec pr_glbtype lvl = function | GTypVar n -> str "'" ++ str (pr n) - | GTypRef (kn, []) -> pr_typref kn - | GTypRef (kn, [t]) -> + | GTypRef (Other kn, []) -> pr_typref kn + | GTypRef (Other kn, [t]) -> let paren = match lvl with | T5_r | T5_l | T2 | T1 -> fun x -> x | T0 -> paren in paren (pr_glbtype lvl t ++ spc () ++ pr_typref kn) - | GTypRef (kn, tl) -> + | GTypRef (Other kn, tl) -> let paren = match lvl with | T5_r | T5_l | T2 | T1 -> fun x -> x | T0 -> paren @@ -55,7 +58,9 @@ let pr_glbtype_gen pr lvl c = | T5_l | T2 | T1 | T0 -> paren in paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) - | GTypTuple tl -> + | GTypRef (Tuple 0, []) -> + Libnames.pr_qualid (Tac2env.shortest_qualid_of_type t_unit) + | GTypRef (Tuple _, tl) -> let paren = match lvl with | T5_r | T5_l -> fun x -> x | T2 | T1 | T0 -> paren @@ -165,7 +170,8 @@ let pr_glbexpr_gen lvl c = in let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in paren (str "let" ++ spc () ++ mut ++ bnd ++ str "in" ++ spc () ++ pr_glbexpr E5 e) - | GTacCst (GCaseTuple _, _, cl) -> + | GTacCst (Tuple 0, _, _) -> str "()" + | GTacCst (Tuple _, _, cl) -> let paren = match lvl with | E0 | E1 -> paren | E2 | E3 | E4 | E5 -> fun x -> x @@ -173,7 +179,7 @@ let pr_glbexpr_gen lvl c = paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) | GTacArr cl -> mt () (** FIXME when implemented *) - | GTacCst (GCaseAlg tpe, n, cl) -> + | GTacCst (Other tpe, n, cl) -> begin match Tac2env.interp_type tpe with | _, GTydAlg { galg_constructors = def } -> let paren = match lvl with @@ -200,7 +206,7 @@ let pr_glbexpr_gen lvl c = | GTacCse (e, info, cst_br, ncst_br) -> let e = pr_glbexpr E5 e in let br = match info with - | GCaseAlg kn -> + | Other kn -> let def = match Tac2env.interp_type kn with | _, GTydAlg { galg_constructors = def } -> def | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false @@ -217,8 +223,8 @@ let pr_glbexpr_gen lvl c = hov 2 (pr_glbexpr E5 p)) ++ spc () in prlist pr_branch br - | GCaseTuple n -> - let (vars, p) = ncst_br.(0) in + | Tuple n -> + let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in let p = pr_glbexpr E5 p in let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in str "|" ++ spc () ++ paren vars ++ spc () ++ str "=>" ++ spc () ++ p diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 86ab5afb17..4950a20ec4 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -120,6 +120,7 @@ Abort. Goal True. Proof. + let x () := plus (fun () => 0) (fun _ => 1) in match case x with | Val x => -- cgit v1.2.3 From 4b863ed5a4c9545ecfd25dc22a83edd3c47aab80 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 28 Jul 2017 15:23:16 +0200 Subject: Allowing generic patterns in let-bindings. --- src/g_ltac2.ml4 | 18 ++++-- src/tac2entries.ml | 4 +- src/tac2expr.mli | 2 +- src/tac2intern.ml | 170 +++++++++++++++++++++++++++++------------------------ 4 files changed, 111 insertions(+), 83 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 7ee9d7e282..21612f9a25 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -117,10 +117,20 @@ GEXTEND Gram ] ] ; let_clause: - [ [ id = binder; ":="; te = tac2expr -> - (id, None, te) - | id = binder; args = LIST1 input_fun; ":="; te = tac2expr -> - (id, None, CTacFun (!@loc, args, te)) ] ] + [ [ binder = let_binder; ":="; te = tac2expr -> + let (pat, fn) = binder in + let te = match fn with None -> te | Some args -> CTacFun (!@loc, args, te) in + (pat, None, te) + ] ] + ; + let_binder: + [ [ pats = LIST1 input_fun -> + match pats with + | [CPatVar _ as pat, None] -> (pat, None) + | (CPatVar (_, Name id) as pat, None) :: args -> (pat, Some args) + | [pat, None] -> (pat, None) + | _ -> CErrors.user_err ~loc:!@loc (str "Invalid pattern") + ] ] ; tac2type: [ "5" RIGHTA diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 70f1b583e0..7bc4c75510 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -266,7 +266,7 @@ let inline_rec_tactic tactics = in (** Fresh variables to abstract over the function patterns *) let _, vars = List.fold_left fold_var (avoid, []) pat in - let map_body ((loc, id), _, e) = (loc, Name id), None, e in + let map_body ((loc, id), _, e) = CPatVar (loc, Name id), None, e in let bnd = List.map map_body tactics in let pat_of_id (loc, id) = (CPatVar (loc, Name id), None) @@ -552,7 +552,7 @@ let perform_notation syn st = let mk loc args = let map (na, e) = let loc = loc_of_tacexpr e in - (Loc.tag ~loc na, None, e) + (CPatVar (Loc.tag ~loc na), None, e) in let bnd = List.map map args in CTacLet (loc, false, bnd, syn.synext_exp) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 668bc0dad1..10d8c1d421 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -92,7 +92,7 @@ type raw_tacexpr = | CTacCst of Loc.t * ltac_constructor or_tuple or_relid | CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list -| CTacLet of Loc.t * rec_flag * (Name.t located * raw_typexpr option * raw_tacexpr) list * raw_tacexpr +| CTacLet of Loc.t * rec_flag * (raw_patexpr * raw_typexpr option * raw_tacexpr) list * raw_tacexpr | CTacArr of raw_tacexpr list located | CTacLst of raw_tacexpr list located | CTacCnv of Loc.t * raw_tacexpr * raw_typexpr diff --git a/src/tac2intern.ml b/src/tac2intern.ml index e460111fc1..16e0bc8cbe 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -590,13 +590,53 @@ let get_pattern_kind env pl = match pl with (** Internalization *) (** Used to generate a fresh tactic variable for pattern-expansion *) -let fresh_var env = +let fresh_var avoid = let bad id = - Id.Map.mem id env.env_var || + Id.Set.mem id avoid || (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) in Namegen.next_ident_away_from (Id.of_string "p") bad +let add_name accu = function +| Name id -> Id.Set.add id accu +| Anonymous -> accu + +let rec ids_of_pattern accu = function +| CPatVar (_, Anonymous) -> accu +| CPatVar (_, Name id) -> Id.Set.add id accu +| CPatRef (_, _, pl) -> + List.fold_left ids_of_pattern accu pl + +let loc_of_relid = function +| RelId (loc, _) -> Option.default dummy_loc loc +| AbsKn _ -> dummy_loc + +(** Expand pattern: [p => t] becomes [x => match x with p => t end] *) +let expand_pattern avoid bnd = + let fold (avoid, bnd) (pat, t) = + let na, expand = match pat with + | CPatVar (_, na) -> + (** Don't expand variable patterns *) + na, None + | _ -> + let loc = loc_of_patexpr pat in + let id = fresh_var avoid in + let qid = RelId (Loc.tag ~loc (qualid_of_ident id)) in + Name id, Some qid + in + let avoid = ids_of_pattern avoid pat in + let avoid = add_name avoid na in + (avoid, (na, pat, expand) :: bnd) + in + let (_, bnd) = List.fold_left fold (avoid, []) bnd in + let fold e (na, pat, expand) = match expand with + | None -> e + | Some qid -> CTacCse (loc_of_relid qid, CTacRef qid, [pat, e]) + in + let expand e = List.fold_left fold e bnd in + let nas = List.rev_map (fun (na, _, _) -> na) bnd in + (nas, expand) + let rec intern_rec env = function | CTacAtm (_, atm) -> intern_atm env atm | CTacRef qid -> @@ -612,35 +652,15 @@ let rec intern_rec env = function let kn = get_constructor env qid in intern_constructor env loc kn [] | CTacFun (loc, bnd, e) -> - (** Expand pattern: [fun p => t] becomes [fun x => match x with p => t end] *) - let fold (env, bnd, tl) (pat, t) = - let t = match t with - | None -> GTypVar (fresh_id env) - | Some t -> intern_type env t - in - let na, expand = match pat with - | CPatVar (_, na) -> - (** Don't expand variable patterns *) - na, None - | _ -> - let loc = loc_of_patexpr pat in - let id = fresh_var env in - let qid = RelId (Loc.tag ~loc (qualid_of_ident id)) in - Name id, Some qid - in - let env = push_name na (monomorphic t) env in - (env, (na, pat, expand) :: bnd, t :: tl) + let map (_, t) = match t with + | None -> GTypVar (fresh_id env) + | Some t -> intern_type env t in - let (env, bnd, tl) = List.fold_left fold (env, [], []) bnd in - let fold e (na, pat, expand) = match expand with - | None -> e - | Some qid -> - CTacCse (loc, CTacRef qid, [pat, e]) - in - let e = List.fold_left fold e bnd in - let nas = List.rev_map (fun (na, _, _) -> na) bnd in - let (e, t) = intern_rec env e in - let t = List.fold_left (fun accu t -> GTypArrow (t, accu)) t tl in + let tl = List.map map bnd in + let (nas, exp) = expand_pattern (Id.Map.domain env.env_var) bnd in + let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env nas tl in + let (e, t) = intern_rec env (exp e) in + let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in (GTacFun (nas, e), t) | CTacApp (loc, CTacCst (_, qid), args) -> let kn = get_constructor env qid in @@ -656,33 +676,20 @@ let rec intern_rec env = function let (args, t) = List.fold_right fold args ([], []) in let ret = unify_arrow ~loc env ft t in (GTacApp (f, args), ret) -| CTacLet (loc, false, el, e) -> - let fold accu ((loc, na), _, _) = match na with - | Anonymous -> accu - | Name id -> - if Id.Set.mem id accu then - user_err ?loc (str "Variable " ++ Id.print id ++ str " is bound several \ +| CTacLet (loc, is_rec, el, e) -> + let fold accu (pat, _, e) = + let ids = ids_of_pattern Id.Set.empty pat in + let common = Id.Set.inter ids accu in + if Id.Set.is_empty common then Id.Set.union ids accu + else + let id = Id.Set.choose common in + let loc = loc_of_patexpr pat in + user_err ~loc (str "Variable " ++ Id.print id ++ str " is bound several \ times in this matching") - else Id.Set.add id accu in - let _ = List.fold_left fold Id.Set.empty el in - let fold ((loc, na), tc, e) (el, p) = - let (e, t) = intern_rec env e in - let () = match tc with - | None -> () - | Some tc -> - let tc = intern_type env tc in - unify ?loc env t tc - in - let t = if is_value e then abstract_var env t else monomorphic t in - ((na, e) :: el), ((na, t) :: p) - in - let (el, p) = List.fold_right fold el ([], []) in - let nenv = List.fold_left (fun accu (na, t) -> push_name na t env) env p in - let (e, t) = intern_rec nenv e in - (GTacLet (false, el, e), t) -| CTacLet (loc, true, el, e) -> - intern_let_rec env loc el e + let ids = List.fold_left fold Id.Set.empty el in + if is_rec then intern_let_rec env loc ids el e + else intern_let env loc ids el e | CTacArr (loc, []) -> let id = fresh_id env in (GTacArr [], GTypRef (Other t_int, [GTypVar id])) @@ -760,17 +767,38 @@ and intern_rec_with_constraint env e exp = let () = unify ~loc env t exp in e -and intern_let_rec env loc el e = - let fold accu ((loc, na), _, _) = match na with - | Anonymous -> accu - | Name id -> - if Id.Set.mem id accu then - user_err ?loc (str "Variable " ++ Id.print id ++ str " is bound several \ - times in this matching") - else Id.Set.add id accu +and intern_let env loc ids el e = + let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in + let fold (pat, t, e) (avoid, accu) = + let nas, exp = expand_pattern avoid [pat, t] in + let na = match nas with [x] -> x | _ -> assert false in + let avoid = List.fold_left add_name avoid nas in + (avoid, (na, exp, t, e) :: accu) in - let _ = List.fold_left fold Id.Set.empty el in - let map env ((loc, na), t, e) = + let (_, el) = List.fold_right fold el (avoid, []) in + let fold (na, exp, tc, e) (body, el, p) = + let (e, t) = match tc with + | None -> intern_rec env e + | Some tc -> + let tc = intern_type env tc in + (intern_rec_with_constraint env e tc, tc) + in + let t = if is_value e then abstract_var env t else monomorphic t in + (exp body, (na, e) :: el, (na, t) :: p) + in + let (e, el, p) = List.fold_right fold el (e, [], []) in + let env = List.fold_left (fun accu (na, t) -> push_name na t accu) env p in + let (e, t) = intern_rec env e in + (GTacLet (false, el, e), t) + +and intern_let_rec env loc ids el e = + let map env (pat, t, e) = + let loc, na = match pat with + | CPatVar na -> na + | CPatRef _ -> + let loc = loc_of_patexpr pat in + user_err ~loc (str "This kind of pattern is forbidden in let-rec bindings") + in let id = fresh_id env in let env = push_name na (monomorphic (GTypVar id)) env in (env, (loc, na, t, e, id)) @@ -1116,10 +1144,6 @@ let intern_open_type t = (** Globalization *) -let add_name accu = function -| Name id -> Id.Set.add id accu -| Anonymous -> accu - let get_projection0 var = match var with | RelId (loc, qid) -> let kn = try Tac2env.locate_projection qid with Not_found -> @@ -1128,12 +1152,6 @@ let get_projection0 var = match var with kn | AbsKn kn -> kn -let rec ids_of_pattern accu = function -| CPatVar (_, Anonymous) -> accu -| CPatVar (_, Name id) -> Id.Set.add id accu -| CPatRef (_, _, pl) -> - List.fold_left ids_of_pattern accu pl - let rec globalize ids e = match e with | CTacAtm _ -> e | CTacRef ref -> @@ -1160,7 +1178,7 @@ let rec globalize ids e = match e with let el = List.map (fun e -> globalize ids e) el in CTacApp (loc, e, el) | CTacLet (loc, isrec, bnd, e) -> - let fold accu ((_, na), _, _) = add_name accu na in + let fold accu (pat, _, _) = ids_of_pattern accu pat in let ext = List.fold_left fold Id.Set.empty bnd in let eids = Id.Set.union ext ids in let e = globalize eids e in -- cgit v1.2.3 From 8aef0199bed6fde2233704deda4116453fca869f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 28 Jul 2017 18:05:58 +0200 Subject: Moving the Ltac2 FFI to a separate file. --- _CoqProject | 2 + src/ltac2_plugin.mlpack | 1 + src/tac2core.ml | 164 ++++++++---------------------------------------- src/tac2core.mli | 44 ------------- src/tac2ffi.ml | 122 +++++++++++++++++++++++++++++++++++ src/tac2ffi.mli | 78 +++++++++++++++++++++++ src/tac2stdlib.ml | 4 +- 7 files changed, 233 insertions(+), 182 deletions(-) create mode 100644 src/tac2ffi.ml create mode 100644 src/tac2ffi.mli diff --git a/_CoqProject b/_CoqProject index e3ad3987bd..6c9393628d 100644 --- a/_CoqProject +++ b/_CoqProject @@ -13,6 +13,8 @@ src/tac2interp.ml src/tac2interp.mli src/tac2entries.ml src/tac2entries.mli +src/tac2ffi.ml +src/tac2ffi.mli src/tac2core.ml src/tac2core.mli src/tac2stdlib.ml diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index dc78207291..1d7b655dce 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -3,6 +3,7 @@ Tac2print Tac2intern Tac2interp Tac2entries +Tac2ffi Tac2core Tac2stdlib G_ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml index a3678d1ad0..6d9ede4421 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -18,30 +18,9 @@ open Proofview.Notations (** Standard values *) -let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) +module Value = Tac2ffi -let val_tag t = match val_tag t with -| Val.Base t -> t -| _ -> assert false - -let val_constr = val_tag (topwit Stdarg.wit_constr) -let val_ident = val_tag (topwit Stdarg.wit_ident) -let val_pattern = Val.create "ltac2:pattern" -let val_pp = Val.create "ltac2:pp" -let val_sort = Val.create "ltac2:sort" -let val_cast = Val.create "ltac2:cast" -let val_inductive = Val.create "ltac2:inductive" -let val_constant = Val.create "ltac2:constant" -let val_constructor = Val.create "ltac2:constructor" -let val_projection = Val.create "ltac2:projection" -let val_univ = Val.create "ltac2:universe" -let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ = - Val.create "ltac2:kont" - -let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = -match Val.eq tag tag' with -| None -> assert false -| Some Refl -> v +let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) module Core = struct @@ -67,108 +46,19 @@ end open Core let v_unit = ValInt 0 -let v_nil = ValInt 0 -let v_cons v vl = ValBlk (0, [|v; vl|]) - -module Value = -struct - -let of_unit () = v_unit - -let to_unit = function -| ValInt 0 -> () -| _ -> assert false - -let of_int n = ValInt n -let to_int = function -| ValInt n -> n -| _ -> assert false - -let of_bool b = if b then ValInt 0 else ValInt 1 - -let to_bool = function -| ValInt 0 -> true -| ValInt 1 -> false -| _ -> assert false - -let of_char n = ValInt (Char.code n) -let to_char = function -| ValInt n -> Char.chr n -| _ -> assert false - -let of_string s = ValStr s -let to_string = function -| ValStr s -> s -| _ -> assert false - -let rec of_list = function -| [] -> v_nil -| x :: l -> v_cons x (of_list l) - -let rec to_list = function -| ValInt 0 -> [] -| ValBlk (0, [|v; vl|]) -> v :: to_list vl -| _ -> assert false - -let of_ext tag c = - ValExt (Val.Dyn (tag, c)) - -let to_ext tag = function -| ValExt e -> extract_val tag e -| _ -> assert false - -let of_constr c = of_ext val_constr c -let to_constr c = to_ext val_constr c - -let of_ident c = of_ext val_ident c -let to_ident c = to_ext val_ident c - -let of_pattern c = of_ext val_pattern c -let to_pattern c = to_ext val_pattern c - -(** FIXME: handle backtrace in Ltac2 exceptions *) -let of_exn c = match fst c with -| LtacError (kn, c) -> ValOpn (kn, c) -| _ -> of_ext val_exn c - -let to_exn c = match c with -| ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) -| _ -> to_ext val_exn c - -let of_option = function -| None -> ValInt 0 -| Some c -> ValBlk (0, [|c|]) - -let to_option = function -| ValInt 0 -> None -| ValBlk (0, [|c|]) -> Some c -| _ -> assert false - -let of_pp c = of_ext val_pp c -let to_pp c = to_ext val_pp c - -let of_tuple cl = ValBlk (0, cl) -let to_tuple = function -| ValBlk (0, cl) -> cl -| _ -> assert false - -let of_array = of_tuple -let to_array = to_tuple let of_name c = match c with -| Anonymous -> of_option None -| Name id -> of_option (Some (of_ident id)) +| Anonymous -> Value.of_option None +| Name id -> Value.of_option (Some (Value.of_ident id)) let of_instance sigma u = let u = Univ.Instance.to_array (EConstr.EInstance.kind sigma u) in - of_array (Array.map (fun v -> of_ext val_univ v) u) + Value.of_array (Array.map (fun v -> Value.of_ext Value.val_univ v) u) let of_rec_declaration (nas, ts, cs) = - (of_array (Array.map of_name nas), - of_array (Array.map of_constr ts), - of_array (Array.map of_constr cs)) - -end + (Value.of_array (Array.map of_name nas), + Value.of_array (Array.map Value.of_constr ts), + Value.of_array (Array.map Value.of_constr cs)) let val_valexpr = Val.create "ltac2:valexpr" @@ -395,28 +285,28 @@ let prm_constr_kind : ml_tactic = function Value.of_array (Array.map Value.of_constr args) |]) | Sort s -> - ValBlk (4, [|Value.of_ext val_sort s|]) + ValBlk (4, [|Value.of_ext Value.val_sort s|]) | Cast (c, k, t) -> ValBlk (5, [| Value.of_constr c; - Value.of_ext val_cast k; + Value.of_ext Value.val_cast k; Value.of_constr t; |]) | Prod (na, t, u) -> ValBlk (6, [| - Value.of_name na; + of_name na; Value.of_constr t; Value.of_constr u; |]) | Lambda (na, t, c) -> ValBlk (7, [| - Value.of_name na; + of_name na; Value.of_constr t; Value.of_constr c; |]) | LetIn (na, b, t, c) -> ValBlk (8, [| - Value.of_name na; + of_name na; Value.of_constr b; Value.of_constr t; Value.of_constr c; @@ -428,18 +318,18 @@ let prm_constr_kind : ml_tactic = function |]) | Const (cst, u) -> ValBlk (10, [| - Value.of_ext val_constant cst; - Value.of_instance sigma u; + Value.of_ext Value.val_constant cst; + of_instance sigma u; |]) | Ind (ind, u) -> ValBlk (11, [| - Value.of_ext val_inductive ind; - Value.of_instance sigma u; + Value.of_ext Value.val_inductive ind; + of_instance sigma u; |]) | Construct (cstr, u) -> ValBlk (12, [| - Value.of_ext val_constructor cstr; - Value.of_instance sigma u; + Value.of_ext Value.val_constructor cstr; + of_instance sigma u; |]) | Case (_, c, t, bl) -> ValBlk (13, [| @@ -448,7 +338,7 @@ let prm_constr_kind : ml_tactic = function Value.of_array (Array.map (fun c -> Value.of_constr c) bl); |]) | Fix ((recs, i), def) -> - let (nas, ts, cs) = Value.of_rec_declaration def in + let (nas, ts, cs) = of_rec_declaration def in ValBlk (14, [| Value.of_array (Array.map Value.of_int recs); Value.of_int i; @@ -457,7 +347,7 @@ let prm_constr_kind : ml_tactic = function cs; |]) | CoFix (i, def) -> - let (nas, ts, cs) = Value.of_rec_declaration def in + let (nas, ts, cs) = of_rec_declaration def in ValBlk (15, [| Value.of_int i; nas; @@ -466,7 +356,7 @@ let prm_constr_kind : ml_tactic = function |]) | Proj (p, c) -> ValBlk (16, [| - Value.of_ext val_projection p; + Value.of_ext Value.val_projection p; Value.of_constr c; |]) end @@ -584,7 +474,7 @@ let prm_case : ml_tactic = function Proofview.tclCASE (thaw f) >>= begin function | Proofview.Next (x, k) -> let k = { - clos_env = Id.Map.singleton k_var (Value.of_ext val_kont k); + clos_env = Id.Map.singleton k_var (Value.of_ext Value.val_kont k); clos_var = [Name e_var]; clos_exp = GTacPrm (prm_apply_kont_h, [GTacVar k_var; GTacVar e_var]); } in @@ -595,7 +485,7 @@ let prm_case : ml_tactic = function (** 'a kont -> exn -> 'a *) let prm_apply_kont : ml_tactic = function -| [k; e] -> (Value.to_ext val_kont k) (Value.to_exn e) +| [k; e] -> (Value.to_ext Value.val_kont k) (Value.to_exn e) | _ -> assert false (** int -> int -> (unit -> 'a) -> 'a *) @@ -768,7 +658,7 @@ let interp_constr flags ist (c, _) = Proofview.V82.wrap_exceptions begin fun () -> let ist = to_lvar ist in let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = Val.Dyn (val_constr, c) in + let c = Val.Dyn (Value.val_constr, c) in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c end @@ -791,7 +681,7 @@ let () = define_ml_object Stdarg.wit_open_constr obj let () = - let interp _ id = return (Val.Dyn (val_ident, id)) in + let interp _ id = return (Val.Dyn (Value.val_ident, id)) in let obj = { ml_type = t_ident; ml_interp = interp; @@ -799,7 +689,7 @@ let () = define_ml_object Stdarg.wit_ident obj let () = - let interp _ c = return (Val.Dyn (val_pattern, c)) in + let interp _ c = return (Val.Dyn (Value.val_pattern, c)) in let obj = { ml_type = t_pattern; ml_interp = interp; diff --git a/src/tac2core.mli b/src/tac2core.mli index 41c79b2c65..07ff6cd539 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -25,47 +25,3 @@ val t_string : type_constant val t_array : type_constant end - -(** {5 Ltac2 FFI} *) - -(** These functions allow to convert back and forth between OCaml and Ltac2 - data representation. The [to_*] functions raise an anomaly whenever the data - has not expected shape. *) - -module Value : -sig - -val of_unit : unit -> valexpr -val to_unit : valexpr -> unit - -val of_int : int -> valexpr -val to_int : valexpr -> int - -val of_bool : bool -> valexpr -val to_bool : valexpr -> bool - -val of_char : char -> valexpr -val to_char : valexpr -> char - -val of_list : valexpr list -> valexpr -val to_list : valexpr -> valexpr list - -val of_constr : EConstr.t -> valexpr -val to_constr : valexpr -> EConstr.t - -val of_exn : Exninfo.iexn -> valexpr -val to_exn : valexpr -> Exninfo.iexn - -val of_ident : Id.t -> valexpr -val to_ident : valexpr -> Id.t - -val of_array : valexpr array -> valexpr -val to_array : valexpr -> valexpr array - -val of_tuple : valexpr array -> valexpr -val to_tuple : valexpr -> valexpr array - -val of_option : valexpr option -> valexpr -val to_option : valexpr -> valexpr option - -end diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml new file mode 100644 index 0000000000..5f1341ea80 --- /dev/null +++ b/src/tac2ffi.ml @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t +| _ -> assert false + +let val_constr = val_tag (topwit Stdarg.wit_constr) +let val_ident = val_tag (topwit Stdarg.wit_ident) +let val_pattern = Val.create "ltac2:pattern" +let val_pp = Val.create "ltac2:pp" +let val_sort = Val.create "ltac2:sort" +let val_cast = Val.create "ltac2:cast" +let val_inductive = Val.create "ltac2:inductive" +let val_constant = Val.create "ltac2:constant" +let val_constructor = Val.create "ltac2:constructor" +let val_projection = Val.create "ltac2:projection" +let val_univ = Val.create "ltac2:universe" +let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ = + Val.create "ltac2:kont" + +let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v + +(** Conversion functions *) + +let of_unit () = ValInt 0 + +let to_unit = function +| ValInt 0 -> () +| _ -> assert false + +let of_int n = ValInt n +let to_int = function +| ValInt n -> n +| _ -> assert false + +let of_bool b = if b then ValInt 0 else ValInt 1 + +let to_bool = function +| ValInt 0 -> true +| ValInt 1 -> false +| _ -> assert false + +let of_char n = ValInt (Char.code n) +let to_char = function +| ValInt n -> Char.chr n +| _ -> assert false + +let of_string s = ValStr s +let to_string = function +| ValStr s -> s +| _ -> assert false + +let rec of_list = function +| [] -> ValInt 0 +| x :: l -> ValBlk (0, [| x; of_list l |]) + +let rec to_list = function +| ValInt 0 -> [] +| ValBlk (0, [|v; vl|]) -> v :: to_list vl +| _ -> assert false + +let of_ext tag c = + ValExt (Val.Dyn (tag, c)) + +let to_ext tag = function +| ValExt e -> extract_val tag e +| _ -> assert false + +let of_constr c = of_ext val_constr c +let to_constr c = to_ext val_constr c + +let of_ident c = of_ext val_ident c +let to_ident c = to_ext val_ident c + +let of_pattern c = of_ext val_pattern c +let to_pattern c = to_ext val_pattern c + +(** FIXME: handle backtrace in Ltac2 exceptions *) +let of_exn c = match fst c with +| LtacError (kn, c) -> ValOpn (kn, c) +| _ -> of_ext val_exn c + +let to_exn c = match c with +| ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) +| _ -> to_ext val_exn c + +let of_option = function +| None -> ValInt 0 +| Some c -> ValBlk (0, [|c|]) + +let to_option = function +| ValInt 0 -> None +| ValBlk (0, [|c|]) -> Some c +| _ -> assert false + +let of_pp c = of_ext val_pp c +let to_pp c = to_ext val_pp c + +let of_tuple cl = ValBlk (0, cl) +let to_tuple = function +| ValBlk (0, cl) -> cl +| _ -> assert false + +let of_array = of_tuple +let to_array = to_tuple diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli new file mode 100644 index 0000000000..d72d0452a0 --- /dev/null +++ b/src/tac2ffi.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr +val to_unit : valexpr -> unit + +val of_int : int -> valexpr +val to_int : valexpr -> int + +val of_bool : bool -> valexpr +val to_bool : valexpr -> bool + +val of_char : char -> valexpr +val to_char : valexpr -> char + +val of_string : string -> valexpr +val to_string : valexpr -> string + +val of_list : valexpr list -> valexpr +val to_list : valexpr -> valexpr list + +val of_constr : EConstr.t -> valexpr +val to_constr : valexpr -> EConstr.t + +val of_exn : Exninfo.iexn -> valexpr +val to_exn : valexpr -> Exninfo.iexn + +val of_ident : Id.t -> valexpr +val to_ident : valexpr -> Id.t + +val of_array : valexpr array -> valexpr +val to_array : valexpr -> valexpr array + +val of_tuple : valexpr array -> valexpr +val to_tuple : valexpr -> valexpr array + +val of_option : valexpr option -> valexpr +val to_option : valexpr -> valexpr option + +val of_pattern : Pattern.constr_pattern -> valexpr +val to_pattern : valexpr -> Pattern.constr_pattern + +val of_pp : Pp.t -> valexpr +val to_pp : valexpr -> Pp.t + +val of_ext : 'a Val.typ -> 'a -> valexpr +val to_ext : 'a Val.typ -> valexpr -> 'a + +(** {5 Dynamic tags} *) + +val val_constr : EConstr.t Val.typ +val val_ident : Id.t Val.typ +val val_pattern : Pattern.constr_pattern Val.typ +val val_pp : Pp.t Val.typ +val val_sort : ESorts.t Val.typ +val val_cast : Constr.cast_kind Val.typ +val val_inductive : inductive Val.typ +val val_constant : Constant.t Val.typ +val val_constructor : constructor Val.typ +val val_projection : Projection.t Val.typ +val val_univ : Univ.universe_level Val.typ +val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 89a8d98693..25d83c06fb 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -12,12 +12,14 @@ open Tac2expr open Tac2core open Proofview.Notations +module Value = Tac2ffi + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } let return x = Proofview.tclUNIT x -let v_unit = Tac2core.Value.of_unit () +let v_unit = Value.of_unit () let lift tac = tac <*> return v_unit -- cgit v1.2.3 From 23f10f3a1a0fd6498cad975b39af5dd3a8559f06 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 28 Jul 2017 18:32:22 +0200 Subject: Parameterizing FFI functions for parameterized types. --- src/tac2core.ml | 49 +++++++++++++++++++++---------------------------- src/tac2ffi.ml | 22 ++++++++++++---------- src/tac2ffi.mli | 12 ++++++------ src/tac2stdlib.ml | 17 ++++++++--------- 4 files changed, 47 insertions(+), 53 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 6d9ede4421..f28c5c5dcf 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -48,17 +48,17 @@ open Core let v_unit = ValInt 0 let of_name c = match c with -| Anonymous -> Value.of_option None -| Name id -> Value.of_option (Some (Value.of_ident id)) +| Anonymous -> Value.of_option Value.of_ident None +| Name id -> Value.of_option Value.of_ident (Some id) let of_instance sigma u = let u = Univ.Instance.to_array (EConstr.EInstance.kind sigma u) in - Value.of_array (Array.map (fun v -> Value.of_ext Value.val_univ v) u) + Value.of_array (fun v -> Value.of_ext Value.val_univ v) u let of_rec_declaration (nas, ts, cs) = - (Value.of_array (Array.map of_name nas), - Value.of_array (Array.map Value.of_constr ts), - Value.of_array (Array.map Value.of_constr cs)) + (Value.of_array of_name nas, + Value.of_array Value.of_constr ts, + Value.of_array Value.of_constr cs) let val_valexpr = Val.create "ltac2:valexpr" @@ -183,11 +183,8 @@ let prm_ident_to_string : ml_tactic = function let prm_ident_of_string : ml_tactic = function | [s] -> let s = Value.to_string s in - let id = - try Value.of_option (Some (Value.of_ident (Id.of_string s))) - with _ -> Value.of_option None - in - return id + let id = try Some (Id.of_string s) with _ -> None in + return (Value.of_option Value.of_ident id) | _ -> assert false (** Int *) @@ -282,7 +279,7 @@ let prm_constr_kind : ml_tactic = function | Evar (evk, args) -> ValBlk (3, [| Value.of_int (Evar.repr evk); - Value.of_array (Array.map Value.of_constr args) + Value.of_array Value.of_constr args; |]) | Sort s -> ValBlk (4, [|Value.of_ext Value.val_sort s|]) @@ -314,7 +311,7 @@ let prm_constr_kind : ml_tactic = function | App (c, cl) -> ValBlk (9, [| Value.of_constr c; - Value.of_array (Array.map Value.of_constr cl) + Value.of_array Value.of_constr cl; |]) | Const (cst, u) -> ValBlk (10, [| @@ -335,12 +332,12 @@ let prm_constr_kind : ml_tactic = function ValBlk (13, [| Value.of_constr c; Value.of_constr t; - Value.of_array (Array.map (fun c -> Value.of_constr c) bl); + Value.of_array Value.of_constr bl; |]) | Fix ((recs, i), def) -> let (nas, ts, cs) = of_rec_declaration def in ValBlk (14, [| - Value.of_array (Array.map Value.of_int recs); + Value.of_array Value.of_int recs; Value.of_int i; nas; ts; @@ -378,7 +375,7 @@ let prm_pattern_matches : ml_tactic = function | Some ans -> let ans = Id.Map.bindings ans in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - return (Value.of_list (List.map of_pair ans)) + return (Value.of_list of_pair ans) end end | _ -> assert false @@ -393,7 +390,7 @@ let prm_pattern_matches_subterm : ml_tactic = function | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_list (List.map of_pair ans) |] in + let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_list of_pair ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in pf_apply begin fun env sigma -> @@ -441,19 +438,16 @@ let prm_once : ml_tactic = function (** (unit -> unit) list -> unit *) let prm_dispatch : ml_tactic = function | [l] -> - let l = Value.to_list l in - let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in + let l = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) l in Proofview.tclDISPATCH l >>= fun () -> return v_unit | _ -> assert false (** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) let prm_extend : ml_tactic = function | [lft; tac; rgt] -> - let lft = Value.to_list lft in - let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let lft = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) lft in let tac = Proofview.tclIGNORE (thaw tac) in - let rgt = Value.to_list rgt in - let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in + let rgt = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) rgt in Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit | _ -> assert false @@ -540,18 +534,17 @@ let prm_hyps : ml_tactic = function | [_] -> pf_apply begin fun env _ -> let open Context.Named.Declaration in - let hyps = Environ.named_context env in + let hyps = List.rev (Environ.named_context env) in let map = function | LocalAssum (id, t) -> let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id; Value.of_option None; Value.of_constr t|] + Value.of_tuple [|Value.of_ident id; Value.of_option Value.of_constr None; Value.of_constr t|] | LocalDef (id, c, t) -> let c = EConstr.of_constr c in let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id; Value.of_option (Some (Value.of_constr c)); Value.of_constr t|] + Value.of_tuple [|Value.of_ident id; Value.of_option Value.of_constr (Some c); Value.of_constr t|] in - let hyps = List.rev_map map hyps in - return (Value.of_list hyps) + return (Value.of_list map hyps) end | _ -> assert false diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 5f1341ea80..74e2b02aeb 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -67,13 +67,13 @@ let to_string = function | ValStr s -> s | _ -> assert false -let rec of_list = function +let rec of_list f = function | [] -> ValInt 0 -| x :: l -> ValBlk (0, [| x; of_list l |]) +| x :: l -> ValBlk (0, [| f x; of_list f l |]) -let rec to_list = function +let rec to_list f = function | ValInt 0 -> [] -| ValBlk (0, [|v; vl|]) -> v :: to_list vl +| ValBlk (0, [|v; vl|]) -> f v :: to_list f vl | _ -> assert false let of_ext tag c = @@ -101,13 +101,13 @@ let to_exn c = match c with | ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) | _ -> to_ext val_exn c -let of_option = function +let of_option f = function | None -> ValInt 0 -| Some c -> ValBlk (0, [|c|]) +| Some c -> ValBlk (0, [|f c|]) -let to_option = function +let to_option f = function | ValInt 0 -> None -| ValBlk (0, [|c|]) -> Some c +| ValBlk (0, [|c|]) -> Some (f c) | _ -> assert false let of_pp c = of_ext val_pp c @@ -118,5 +118,7 @@ let to_tuple = function | ValBlk (0, cl) -> cl | _ -> assert false -let of_array = of_tuple -let to_array = to_tuple +let of_array f vl = ValBlk (0, Array.map f vl) +let to_array f = function +| ValBlk (0, vl) -> Array.map f vl +| _ -> assert false diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index d72d0452a0..3f429995ce 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -32,8 +32,8 @@ val to_char : valexpr -> char val of_string : string -> valexpr val to_string : valexpr -> string -val of_list : valexpr list -> valexpr -val to_list : valexpr -> valexpr list +val of_list : ('a -> valexpr) -> 'a list -> valexpr +val to_list : (valexpr -> 'a) -> valexpr -> 'a list val of_constr : EConstr.t -> valexpr val to_constr : valexpr -> EConstr.t @@ -44,14 +44,14 @@ val to_exn : valexpr -> Exninfo.iexn val of_ident : Id.t -> valexpr val to_ident : valexpr -> Id.t -val of_array : valexpr array -> valexpr -val to_array : valexpr -> valexpr array +val of_array : ('a -> valexpr) -> 'a array -> valexpr +val to_array : (valexpr -> 'a) -> valexpr -> 'a array val of_tuple : valexpr array -> valexpr val to_tuple : valexpr -> valexpr array -val of_option : valexpr option -> valexpr -val to_option : valexpr -> valexpr option +val of_option : ('a -> valexpr) -> 'a option -> valexpr +val to_option : (valexpr -> 'a) -> valexpr -> 'a option val of_pattern : Pattern.constr_pattern -> valexpr val to_pattern : valexpr -> Pattern.constr_pattern diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 25d83c06fb..0aeccbd9c6 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -112,45 +112,44 @@ let () = define_prim0 "tac_split" (Tactics.split_with_bindings false [NoBindings let () = define_prim0 "tac_esplit" (Tactics.split_with_bindings true [NoBindings]) let () = define_prim1 "tac_rename" begin fun ids -> - let ids = Value.to_list ids in let map c = match Value.to_tuple c with | [|x; y|] -> (Value.to_ident x, Value.to_ident y) | _ -> assert false in - let ids = List.map map ids in + let ids = Value.to_list map ids in Tactics.rename_hyp ids end let () = define_prim1 "tac_revert" begin fun ids -> - let ids = List.map Value.to_ident (Value.to_list ids) in + let ids = Value.to_list Value.to_ident ids in Tactics.revert ids end let () = define_prim0 "tac_admit" Proofview.give_up let () = define_prim2 "tac_fix" begin fun idopt n -> - let idopt = Option.map Value.to_ident (Value.to_option idopt) in + let idopt = Value.to_option Value.to_ident idopt in let n = Value.to_int n in Tactics.fix idopt n end let () = define_prim1 "tac_cofix" begin fun idopt -> - let idopt = Option.map Value.to_ident (Value.to_option idopt) in + let idopt = Value.to_option Value.to_ident idopt in Tactics.cofix idopt end let () = define_prim1 "tac_clear" begin fun ids -> - let ids = List.map Value.to_ident (Value.to_list ids) in + let ids = Value.to_list Value.to_ident ids in Tactics.clear ids end let () = define_prim1 "tac_keep" begin fun ids -> - let ids = List.map Value.to_ident (Value.to_list ids) in + let ids = Value.to_list Value.to_ident ids in Tactics.keep ids end let () = define_prim1 "tac_clearbody" begin fun ids -> - let ids = List.map Value.to_ident (Value.to_list ids) in + let ids = Value.to_list Value.to_ident ids in Tactics.clear_body ids end @@ -161,7 +160,7 @@ let () = define_prim1 "tac_absurd" begin fun c -> end let () = define_prim1 "tac_subst" begin fun ids -> - let ids = List.map Value.to_ident (Value.to_list ids) in + let ids = Value.to_list Value.to_ident ids in Equality.subst ids end -- cgit v1.2.3 From 0f72b089de52ad7d26d71e56003b140fa5012635 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 28 Jul 2017 17:53:42 +0200 Subject: Exporting more internals from Coq implementation. --- src/tac2core.ml | 9 ++++ src/tac2env.ml | 3 ++ src/tac2env.mli | 3 ++ src/tac2stdlib.ml | 125 +++++++++++++++++++++++++++++++++++++++++++++++----- tests/stuff/ltac2.v | 8 +++- theories/Control.v | 7 +++ theories/Std.v | 51 +++++++++++++++++---- 7 files changed, 185 insertions(+), 21 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index f28c5c5dcf..515cadc525 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -557,6 +557,14 @@ let prm_refine : ml_tactic = function end >>= fun () -> return v_unit | _ -> assert false +let prm_with_holes : ml_tactic = function +| [x; f] -> + Proofview.tclEVARMAP >>= fun sigma0 -> + thaw x >>= fun ans -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> + Tacticals.New.tclWITHHOLES false (interp_app f [ans]) sigma +| _ -> assert false (** Registering *) @@ -615,6 +623,7 @@ let () = Tac2env.define_primitive (pname "goal") prm_goal let () = Tac2env.define_primitive (pname "hyp") prm_hyp let () = Tac2env.define_primitive (pname "hyps") prm_hyps let () = Tac2env.define_primitive (pname "refine") prm_refine +let () = Tac2env.define_primitive (pname "with_holes") prm_with_holes (** ML types *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 2094898ced..a75500eae7 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -239,6 +239,9 @@ let interp_ml_object t = MLType.obj t let coq_prefix = MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) +let std_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) + (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2" diff --git a/src/tac2env.mli b/src/tac2env.mli index e26109b691..fea03c4285 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -106,6 +106,9 @@ val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object val coq_prefix : ModPath.t (** Path where primitive datatypes are defined in Ltac2 plugin. *) +val std_prefix : ModPath.t +(** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) + (** {5 Generic arguments} *) val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 0aeccbd9c6..7c7b539113 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Names open Locus open Misctypes open Tac2expr @@ -14,6 +15,57 @@ open Proofview.Notations module Value = Tac2ffi +let to_pair f g = function +| ValBlk (0, [| x; y |]) -> (f x, g y) +| _ -> assert false + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let to_qhyp = function +| ValBlk (0, [| i |]) -> AnonHyp (Value.to_int i) +| ValBlk (1, [| id |]) -> NamedHyp (Value.to_ident id) +| _ -> assert false + +let to_bindings = function +| ValInt 0 -> NoBindings +| ValBlk (0, [| vl |]) -> + ImplicitBindings (Value.to_list Value.to_constr vl) +| ValBlk (1, [| vl |]) -> + ExplicitBindings ((Value.to_list (fun p -> None, to_pair to_qhyp Value.to_constr p) vl)) +| _ -> assert false + +let to_constr_with_bindings = function +| ValBlk (0, [| c; bnd |]) -> (Value.to_constr c, to_bindings bnd) +| _ -> assert false + +let to_int_or_var i = ArgArg (Value.to_int i) + +let to_occurrences f = function +| ValInt 0 -> AllOccurrences +| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list f vl) +| ValInt 1 -> NoOccurrences +| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list f vl) +| _ -> assert false + +let to_hyp_location_flag = function +| ValInt 0 -> InHyp +| ValInt 1 -> InHypTypeOnly +| ValInt 2 -> InHypValueOnly +| _ -> assert false + +let to_clause = function +| ValBlk (0, [| hyps; concl |]) -> + let cast = function + | ValBlk (0, [| hyp; occ; flag |]) -> + ((to_occurrences to_int_or_var occ, Value.to_ident hyp), to_hyp_location_flag flag) + | _ -> assert false + in + let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in + { onhyps = hyps; concl_occs = to_occurrences to_int_or_var concl; } +| _ -> assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -50,6 +102,29 @@ let define_prim2 name tac = in Tac2env.define_primitive (pname name) tac +(** Tactics from Tacexpr *) + +let () = define_prim2 "tac_eelim" begin fun c copt -> + let c = to_constr_with_bindings c in + let copt = Value.to_option to_constr_with_bindings copt in + Tactics.elim true None c copt +end + +let () = define_prim1 "tac_ecase" begin fun c -> + let c = to_constr_with_bindings c in + Tactics.general_case_analysis true None c +end + +let () = define_prim1 "tac_egeneralize" begin fun cl -> + let cast = function + | ValBlk (0, [| c; occs; na |]) -> + ((to_occurrences Value.to_int c, Value.to_constr c), to_name na) + | _ -> assert false + in + let cl = Value.to_list cast cl in + Tactics.new_generalize_gen cl +end + (** Tactics from coretactics *) let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity @@ -76,10 +151,26 @@ let () = define_prim1 "tac_cut" begin fun c -> Tactics.cut c end -let () = define_prim0 "tac_left" (Tactics.left_with_bindings false NoBindings) -let () = define_prim0 "tac_eleft" (Tactics.left_with_bindings true NoBindings) -let () = define_prim0 "tac_right" (Tactics.right_with_bindings false NoBindings) -let () = define_prim0 "tac_eright" (Tactics.right_with_bindings true NoBindings) +let () = define_prim1 "tac_left" begin fun bnd -> + let bnd = to_bindings bnd in + Tactics.left_with_bindings false bnd +end +let () = define_prim1 "tac_eleft" begin fun bnd -> + let bnd = to_bindings bnd in + Tactics.left_with_bindings true bnd +end +let () = define_prim1 "tac_right" begin fun bnd -> + let bnd = to_bindings bnd in + Tactics.right_with_bindings false bnd +end +let () = define_prim1 "tac_eright" begin fun bnd -> + let bnd = to_bindings bnd in + Tactics.right_with_bindings true bnd +end + +let () = define_prim1 "tac_introsuntil" begin fun h -> + Tactics.intros_until (to_qhyp h) +end let () = define_prim1 "tac_exactnocheck" begin fun c -> Tactics.exact_no_check (Value.to_constr c) @@ -96,20 +187,32 @@ end let () = define_prim0 "tac_constructor" (Tactics.any_constructor false None) let () = define_prim0 "tac_econstructor" (Tactics.any_constructor true None) -let () = define_prim1 "tac_constructorn" begin fun n -> +let () = define_prim2 "tac_constructorn" begin fun n bnd -> let n = Value.to_int n in - Tactics.constructor_tac false None n NoBindings + let bnd = to_bindings bnd in + Tactics.constructor_tac false None n bnd end -let () = define_prim1 "tac_econstructorn" begin fun n -> +let () = define_prim2 "tac_econstructorn" begin fun n bnd -> let n = Value.to_int n in - Tactics.constructor_tac true None n NoBindings + let bnd = to_bindings bnd in + Tactics.constructor_tac true None n bnd end -let () = define_prim0 "tac_symmetry" (Tactics.intros_symmetry Locusops.onConcl) +let () = define_prim1 "tac_symmetry" begin fun cl -> + let cl = to_clause cl in + Tactics.intros_symmetry cl +end -let () = define_prim0 "tac_split" (Tactics.split_with_bindings false [NoBindings]) -let () = define_prim0 "tac_esplit" (Tactics.split_with_bindings true [NoBindings]) +let () = define_prim1 "tac_split" begin fun bnd -> + let bnd = to_bindings bnd in + Tactics.split_with_bindings false [bnd] +end + +let () = define_prim1 "tac_esplit" begin fun bnd -> + let bnd = to_bindings bnd in + Tactics.split_with_bindings true [bnd] +end let () = define_prim1 "tac_rename" begin fun ids -> let map c = match Value.to_tuple c with diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 4950a20ec4..35546ef6c1 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -120,7 +120,6 @@ Abort. Goal True. Proof. - let x () := plus (fun () => 0) (fun _ => 1) in match case x with | Val x => @@ -131,6 +130,13 @@ match case x with end. Abort. +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +refine (fun () => '(fun H => _)). +Std.ecase (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). +refine (fun () => 'eq_refl). +Qed. + Ltac2 rec do n tac := match Int.equal n 0 with | true => () | false => tac (); do (Int.sub n 1) tac diff --git a/theories/Control.v b/theories/Control.v index a6d46a89a8..a8b92aced2 100644 --- a/theories/Control.v +++ b/theories/Control.v @@ -54,3 +54,10 @@ Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" (** Refinement *) Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". + +(** Evars *) + +Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_holes". +(** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if + all evars generated by the call to [x] have not been solved when [f] + returns. *) diff --git a/theories/Std.v b/theories/Std.v index 5cc1622ba9..a9eced6cbb 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -8,8 +8,39 @@ Require Import Ltac2.Init. +(** ML-facing types *) + +Ltac2 Type hypothesis := [ AnonHyp (int) | NamedHyp (ident) ]. + +Ltac2 Type bindings := [ +| NoBindings +| ImplicitBindings (constr list) +| ExplicitBindings ((hypothesis * constr) list) +]. + +Ltac2 Type constr_with_bindings := constr * bindings. + +Ltac2 Type occurrences := [ +| AllOccurrences +| AllOccurrencesBut (int list) +| NoOccurrences +| OnlyOccurrences (int list) +]. + +Ltac2 Type hyp_location_flag := [ InHyp | InHypTypeOnly | InHypValueOnly ]. + +Ltac2 Type clause := { + on_hyps : (ident * occurrences * hyp_location_flag) list option; + on_concl : occurrences; +}. + (** Standard, built-in tactics. See Ltac1 for documentation. *) +Ltac2 @ external eelim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_eelim". +Ltac2 @ external ecase : constr_with_bindings -> unit := "ltac2" "tac_ecase". + +Ltac2 @ external egeneralize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_egeneralize". + Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". @@ -20,20 +51,22 @@ Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". -Ltac2 @ external left : unit -> unit := "ltac2" "tac_left". -Ltac2 @ external eleft : unit -> unit := "ltac2" "tac_eleft". -Ltac2 @ external right : unit -> unit := "ltac2" "tac_right". -Ltac2 @ external eright : unit -> unit := "ltac2" "tac_eright". +Ltac2 @ external left : bindings -> unit := "ltac2" "tac_left". +Ltac2 @ external eleft : bindings -> unit := "ltac2" "tac_eleft". +Ltac2 @ external right : bindings -> unit := "ltac2" "tac_right". +Ltac2 @ external eright : bindings -> unit := "ltac2" "tac_eright". Ltac2 @ external constructor : unit -> unit := "ltac2" "tac_constructor". Ltac2 @ external econstructor : unit -> unit := "ltac2" "tac_econstructor". -Ltac2 @ external split : unit -> unit := "ltac2" "tac_split". -Ltac2 @ external esplit : unit -> unit := "ltac2" "tac_esplit". +Ltac2 @ external split : bindings -> unit := "ltac2" "tac_split". +Ltac2 @ external esplit : bindings -> unit := "ltac2" "tac_esplit". + +Ltac2 @ external constructor_n : int -> bindings -> unit := "ltac2" "tac_constructorn". +Ltac2 @ external econstructor_n : int -> bindings -> unit := "ltac2" "tac_econstructorn". -Ltac2 @ external constructor_n : int -> unit := "ltac2" "tac_constructorn". -Ltac2 @ external econstructor_n : int -> unit := "ltac2" "tac_econstructorn". +Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". -Ltac2 @ external symmetry : unit -> unit := "ltac2" "tac_symmetry". +Ltac2 @ external symmetry : clause -> unit := "ltac2" "tac_symmetry". Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". -- cgit v1.2.3 From f9e7c43b5884f5231f14ec7b008b1eb660026a0e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 31 Jul 2017 22:07:55 +0200 Subject: Adding new scopes for standard Ltac structures. --- _CoqProject | 2 ++ src/g_ltac2.ml4 | 63 +++++++++++++++++++++++++++++++++++++++++++++---- src/ltac2_plugin.mlpack | 1 + src/tac2core.ml | 27 ++++++++++++++++++++- src/tac2core.mli | 13 ++++++++-- src/tac2entries.ml | 3 +++ src/tac2entries.mli | 5 ++++ src/tac2quote.ml | 63 +++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2quote.mli | 32 +++++++++++++++++++++++++ tests/example2.v | 15 ++++++++++++ 10 files changed, 216 insertions(+), 8 deletions(-) create mode 100644 src/tac2quote.ml create mode 100644 src/tac2quote.mli create mode 100644 tests/example2.v diff --git a/_CoqProject b/_CoqProject index 6c9393628d..ab73af1295 100644 --- a/_CoqProject +++ b/_CoqProject @@ -17,6 +17,8 @@ src/tac2ffi.ml src/tac2ffi.mli src/tac2core.ml src/tac2core.mli +src/tac2quote.ml +src/tac2quote.mli src/tac2stdlib.ml src/tac2stdlib.mli src/g_ltac2.ml4 diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 21612f9a25..4a2f615df9 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -9,12 +9,29 @@ open Pp open Util open Names +open Tok open Pcoq open Constrexpr open Misctypes open Tac2expr open Ltac_plugin +let err () = raise Stream.Failure + +(* idem for (x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + Gram.Entry.of_parser "test_lpar_idnum_coloneq" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ | INT _ -> + (match stream_nth 2 strm with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + let tac2expr = Tac2entries.Pltac.tac2expr let tac2type = Gram.entry_create "tactic:tac2type" let tac2def_val = Gram.entry_create "tactic:tac2def_val" @@ -24,11 +41,12 @@ let tac2def_syn = Gram.entry_create "tactic:tac2def_syn" let tac2mode = Gram.entry_create "vernac:ltac2_command" let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) -let inj_constr loc c = inj_wit Stdarg.wit_constr loc c let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c -let inj_ident loc c = inj_wit Stdarg.wit_ident loc c let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c +let mk_constr ~loc kn args = + CTacApp (loc, CTacCst (loc, AbsKn (Other kn)), args) + let pattern_of_qualid loc id = if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) else @@ -108,11 +126,11 @@ GEXTEND Gram | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) | id = Prim.qualid -> if Tac2env.is_constructor (snd id) then CTacCst (!@loc, RelId id) else CTacRef (RelId id) - | "@"; id = Prim.ident -> inj_ident !@loc id + | "@"; id = Prim.ident -> Tac2quote.of_ident ~loc:!@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_constr !@loc c + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_constr ~loc:!@loc c | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c - | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> inj_ident !@loc c + | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> Tac2quote.of_ident ~loc:!@loc c | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> inj_pattern !@loc c ] ] ; @@ -256,6 +274,41 @@ GEXTEND Gram ; END +(** Quotation scopes used by notations *) + +open Tac2entries.Pltac + +GEXTEND Gram + GLOBAL: q_ident q_bindings; + q_ident: + [ [ id = Prim.ident -> Tac2quote.of_ident ~loc:!@loc id + | "$"; id = Prim.ident -> Tac2quote.of_variable ~loc:!@loc id + ] ] + ; + simple_binding: + [ [ "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (NamedHyp id, Tac2quote.of_constr ~loc:!@loc c) + | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (AnonHyp n, Tac2quote.of_constr ~loc:!@loc c) + ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + Tac2quote.of_bindings ~loc:!@loc (ExplicitBindings bl) + | bl = LIST1 Constr.constr -> + let bl = List.map (fun c -> Tac2quote.of_constr ~loc:!@loc c) bl in + Tac2quote.of_bindings ~loc:!@loc (Misctypes.ImplicitBindings bl) + ] ] + ; + q_bindings: + [ [ "with"; bl = bindings -> bl + | -> mk_constr ~loc:!@loc Tac2core.Core.c_no_bindings [] + ] ] + ; +END + +(** Extension of constr syntax *) + GEXTEND Gram Pcoq.Constr.operconstr: LEVEL "0" [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 1d7b655dce..8d2d7dc0f4 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -5,5 +5,6 @@ Tac2interp Tac2entries Tac2ffi Tac2core +Tac2quote Tac2stdlib G_ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml index 515cadc525..111ef1c8eb 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -21,6 +21,7 @@ open Proofview.Notations module Value = Tac2ffi let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) +let std_core n = KerName.make2 Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) module Core = struct @@ -41,6 +42,15 @@ let c_cons = coq_core "::" let c_none = coq_core "None" let c_some = coq_core "Some" +let t_bindings = std_core "bindings" +let c_no_bindings = std_core "NoBindings" +let c_implicit_bindings = std_core "ImplicitBindings" +let c_explicit_bindings = std_core "ExplicitBindings" + +let t_qhyp = std_core "hypothesis" +let c_named_hyp = std_core "NamedHyp" +let c_anon_hyp = std_core "AnonHyp" + end open Core @@ -835,5 +845,20 @@ let () = add_scope "tactic" begin function | _ -> scope_fail () end -let () = add_generic_scope "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = add_scope "ident" begin function +| [] -> + let scope = Extend.Aentry Tac2entries.Pltac.q_ident in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "bindings" begin function +| [] -> + let scope = Extend.Aentry Tac2entries.Pltac.q_bindings in + let act tac = rthunk tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr diff --git a/src/tac2core.mli b/src/tac2core.mli index 07ff6cd539..118b7aaa42 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -16,12 +16,21 @@ module Core : sig val t_list : type_constant -val c_nil : ltac_constant -val c_cons : ltac_constant +val c_nil : ltac_constructor +val c_cons : ltac_constructor val t_int : type_constant val t_option : type_constant val t_string : type_constant val t_array : type_constant +val t_bindings : type_constant +val c_no_bindings : ltac_constructor +val c_implicit_bindings : ltac_constant +val c_explicit_bindings : ltac_constant + +val t_qhyp : type_constant +val c_anon_hyp : ltac_constructor +val c_named_hyp : ltac_constructor + end diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 7bc4c75510..d293a87975 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -23,6 +23,9 @@ open Vernacexpr module Pltac = struct let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" + +let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" +let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 71e8150057..4d5a234daf 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -54,4 +54,9 @@ val call : default:bool -> raw_tacexpr -> unit module Pltac : sig val tac2expr : raw_tacexpr Pcoq.Gram.entry + +(** Quoted entries. They directly return an Ltac2 expression *) + +val q_ident : raw_tacexpr Pcoq.Gram.entry +val q_bindings : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2quote.ml b/src/tac2quote.ml new file mode 100644 index 0000000000..2d9521d30c --- /dev/null +++ b/src/tac2quote.ml @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constructor Core.c_nil [] +| e :: l -> + constructor ?loc Core.c_cons [e; of_list ?loc l] + +let of_qhyp ?loc = function +| AnonHyp n -> constructor Core.c_anon_hyp [of_int ?loc n] +| NamedHyp id -> constructor Core.c_named_hyp [of_ident ?loc id] + +let of_bindings ?loc = function +| NoBindings -> + constructor ?loc Core.c_no_bindings [] +| ImplicitBindings tl -> + constructor ?loc Core.c_implicit_bindings [of_list ?loc tl] +| ExplicitBindings tl -> + let tl = List.map (fun (loc, (qhyp, e)) -> of_pair ?loc (of_qhyp ?loc qhyp, e)) tl in + constructor ?loc Core.c_explicit_bindings [of_list ?loc tl] diff --git a/src/tac2quote.mli b/src/tac2quote.mli new file mode 100644 index 0000000000..ba6a878d50 --- /dev/null +++ b/src/tac2quote.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ltac_constructor -> raw_tacexpr list -> raw_tacexpr + +val of_int : ?loc:Loc.t -> int -> raw_tacexpr + +val of_pair : ?loc:Loc.t -> raw_tacexpr * raw_tacexpr -> raw_tacexpr + +val of_variable : ?loc:Loc.t -> Id.t -> raw_tacexpr + +val of_ident : ?loc:Loc.t -> Id.t -> raw_tacexpr + +val of_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr + +val of_list : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr + +val of_bindings : ?loc:Loc.t -> raw_tacexpr bindings -> raw_tacexpr diff --git a/tests/example2.v b/tests/example2.v new file mode 100644 index 0000000000..14a6b68e18 --- /dev/null +++ b/tests/example2.v @@ -0,0 +1,15 @@ +Require Import Ltac2.Ltac2. + +Ltac2 Notation "split" bnd(bindings) := Std.split (bnd ()). + +Goal exists n, n = 0. +Proof. +split with (x := 0). +Std.reflexivity (). +Qed. + +Goal exists n, n = 0. +Proof. +split with 0. +split. +Qed. -- cgit v1.2.3 From 9eb7f16fc890a1bf3a1332332ed349513905ed66 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 00:35:09 +0200 Subject: Do not thunk notations preemptively. One has to rely on the 'thunk' token to produce such thunks. --- src/tac2core.ml | 22 +++++++++++++++------- tests/example2.v | 2 +- tests/stuff/ltac2.v | 2 +- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 111ef1c8eb..e0a65dde2d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -753,7 +753,7 @@ let add_generic_scope s entry arg = let parse = function | [] -> let scope = Extend.Aentry entry in - let act x = rthunk (CTacExt (dummy_loc, in_gen (rawwit arg) x)) in + let act x = CTacExt (dummy_loc, in_gen (rawwit arg) x) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () in @@ -818,7 +818,7 @@ end let () = add_scope "self" begin function | [] -> let scope = Extend.Aself in - let act tac = rthunk tac in + let act tac = tac in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end @@ -826,7 +826,7 @@ end let () = add_scope "next" begin function | [] -> let scope = Extend.Anext in - let act tac = rthunk tac in + let act tac = tac in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end @@ -835,12 +835,12 @@ let () = add_scope "tactic" begin function | [] -> (** Default to level 5 parsing *) let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, 5) in - let act tac = rthunk tac in + let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt (loc, n)] -> let () = if n < 0 || n > 5 then scope_fail () in let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, n) in - let act tac = rthunk tac in + let act tac = tac in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end @@ -848,7 +848,7 @@ end let () = add_scope "ident" begin function | [] -> let scope = Extend.Aentry Tac2entries.Pltac.q_ident in - let act tac = rthunk tac in + let act tac = tac in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end @@ -856,7 +856,15 @@ end let () = add_scope "bindings" begin function | [] -> let scope = Extend.Aentry Tac2entries.Pltac.q_bindings in - let act tac = rthunk tac in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + +let () = add_scope "thunk" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let act e = rthunk (act e) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end diff --git a/tests/example2.v b/tests/example2.v index 14a6b68e18..5efbf90b34 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -1,6 +1,6 @@ Require Import Ltac2.Ltac2. -Ltac2 Notation "split" bnd(bindings) := Std.split (bnd ()). +Ltac2 Notation "split" bnd(bindings) := Std.split bnd. Goal exists n, n = 0. Proof. diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 35546ef6c1..ece6fca06a 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -111,7 +111,7 @@ Proof. Fail zero (Bar "lol"). Abort. -Ltac2 Notation "refine!" c(constr) := refine c. +Ltac2 Notation "refine!" c(thunk(constr)) := refine c. Goal True. Proof. -- cgit v1.2.3 From 6fdec59bbd3fc67ff3b0c48193201c1739aa7f70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 00:44:51 +0200 Subject: Adding documentation from the CEP. --- doc/ltac2.md | 642 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 642 insertions(+) create mode 100644 doc/ltac2.md diff --git a/doc/ltac2.md b/doc/ltac2.md new file mode 100644 index 0000000000..38a56d3d6b --- /dev/null +++ b/doc/ltac2.md @@ -0,0 +1,642 @@ +# Summary + +The Ltac tactic language is probably one of the ingredients of the success of +Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: + +- has nothing like intended semantics +- is very non-uniform due to organic growth +- lacks expressivity and requires programming-by-hacking +- is slow +- is error-prone and fragile +- has an intricate implementation + +This has a lot of terrible consequences, most notably the fact that it is never +clear whether some observed behaviour is a bug or a proper one. + +Following the need of users that start developing huge projects relying +critically on Ltac, we believe that we should offer a proper modern language +that features at least the following: + +- at least informal, predictible semantics +- a typing system +- standard programming facilities (i.e. datatypes) + +This document describes the implementation of such a language. The +implementation of Ltac as of Coq 8.7 will be referred to as Ltac1. + +# General design + +There are various alternatives to Ltac1, such that Mtac or Rtac for instance. +While those alternatives can be quite distinct from Ltac1, we designed +Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +aforementioned defects. + +In particular, Ltac2 is: +- a member of the ML family of languages, i.e. + * a call-by-value functional language + * with effects + * together with Hindley-Milner type system +- a language featuring meta-programming facilities for the manipulation of + Coq-side terms +- a language featuring notation facilities to help writing palatable scripts + +We describe more in details each point in the remainder of this document. + +# ML component + +The call-by-value functional language fragment is easy to implement. + +## Type Syntax + +At the level of terms, we simply elaborate on Ltac1 syntax, which is quite +close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. + +``` +TYPE := +| "(" TYPE₀ "," ... "," TYPEₙ ")" TYPECONST +| "(" TYPE₀ "*" ... "*" TYPEₙ ")" +| TYPE₁ "->" TYPE₂ +| TYPEVAR + +TYPECONST := ( MODPATH "." )* LIDENT + +TYPEVAR := "'" LIDENT + +TYPEPARAMS := "(" TYPEVAR₀ "," ... "," TYPEVARₙ ")" +``` + +The set of base types can be extended thanks to the usual ML type +declarations such as algebraic datatypes and records. + +Built-in types include: +- `int`, machine integers (size not specified, in practice inherited from OCaml) +- `string`, mutable strings +- `'a array`, mutable arrays +- `exn`, exceptions +- `constr`, kernel-side terms +- `pattern`, term patterns +- `ident`, well-formed identifiers + +## Type declarations + +One can define new types by the following commands. + +``` +VERNAC ::= +| "Ltac2" "Type" TYPEPARAMS LIDENT +| "Ltac2" "Type" RECFLAG TYPEPARAMS LIDENT ":=" TYPEDEF + +RECFLAG := ( "rec" ) +``` + +The first command defines an abstract type. It has no use for the end user and +is dedicated to types representing data coming from the OCaml world. + +The second command defines a type with a manifest. There are four possible +kinds of such definitions: alias, variant, record and open variant types. + +``` +TYPEDEF := +| TYPE +| "[" CONSTRUCTORDEF₀ "|" ... "|" CONSTRUCTORDEFₙ "]" +| "{" FIELDDEF₀ ";" ... ";" FIELDDEFₙ "}" +| "[" "..." "]" + +CONSTRUCTORDEF := +| IDENT ( "(" TYPE₀ "," ... "," TYPE₀ ")" ) + +FIELDDEF := +| MUTFLAG IDENT ":" TYPE + +MUTFLAG := ( "mutable" ) +``` + +Aliases are just a name for a given type expression and are transparently +unfoldable to it. They cannot be recursive. + +Variants are sum types defined by constructors and eliminated by +pattern-matching. They can be recursive, but the `RECFLAG` must be explicitly +set. Pattern-maching must be exhaustive. + +Records are product types with named fields and eliminated by projection. +Likewise they can be recursive if the `RECFLAG` is set. + +Open variants are a special kind of variant types whose constructors are not +statically defined, but can instead by extended dynamically. A typical example +is the standard `exn` type. Pattern-matching must always include a catch-all +clause. They can be extended by the following command. + +VERNAC ::= +| "Ltac2" "Type" TYPEPARAMS QUALID ":=" "[" CONSTRUCTORDEF "]" + +## Term Syntax + +The syntax of the functional fragment is very close to the one of Ltac1, except +that it adds a true pattern-matching feature. + +``` +VAR := LIDENT + +QUALID := ( MODPATH "." )* LIDENT + +CONSTRUCTOR := UIDENT + +TERM := +| QUALID +| CONSTRUCTOR TERM₀ ... TERMₙ +| TERM TERM₀ ... TERMₙ +| "fun" VAR "=>" TERM +| "let" VAR ":=" TERM "in" TERM +| "let" "rec" VAR ":=" TERM "in" TERM +| "match" TERM "with" BRANCH* "end" +| INT +| STRING +| "[|" TERM₀ ";" ... ";" TERMₙ "|]" +| "(" TERM₀ "," ... "," TERMₙ ")" +| "{" FIELD+ "}" +| TERM "." "(" QUALID ")" +| TERM₁ "." "(" QUALID ")" ":=" TERM₂ +| "["; TERM₀ ";" ... ";" TERMₙ "]" +| TERM₁ "::" TERM₂ +| ... + +BRANCH := +| PATTERN "=>" TERM + +PATTERN := +| VAR +| "_" +| "(" PATTERN₀ "," ... "," PATTERNₙ ")" +| CONSTRUCTOR PATTERN₀ ... PATTERNₙ +| "[" "]" +| PATTERN₁ "::" PATTERN₂ + +FIELD := +| QUALID ":=" TERM + +``` + +In practice, there is some additional syntactic sugar that allows e.g. to +bind a variable and match on it at the same time, in the usual ML style. + +There is a dedicated syntax for list and array litterals. + +Limitations: for now, deep pattern matching is not implemented yet. + +## Reduction + +We use the usual ML call-by-value reduction, with an otherwise unspecified +evaluation order. + +Note that this is already a departure from Ltac1 which uses heuristic to +decide when evaluating an expression, e.g. the following do not evaluate the +same way. + +``` +foo (idtac; let x := 0 in bar) + +foo (let x := 0 in bar) +``` + +Instead of relying on the `idtac` hack, we would now require an explicit thunk +not to compute the argument, and `foo` would have e.g. type +`(unit -> unit) -> unit`. + +``` +foo (fun () -> let x := 0 in bar) +``` + +## Typing + +Typing is strict and follows Hindley-Milner system. We will not implement the +current hackish subtyping semantics, and one will have to resort to conversion +functions. See notations though to make things more palatable. + +In this setting, all usual argument-free tactics have type `unit -> unit`, but +one can return as well a value of type `τ` thanks to terms of type `unit -> τ`, +or take additional arguments. + +## Effects + +Regarding effects, nothing involved here, except that instead of using the +standard IO monad as the ambient effectful world, Ltac2 is going to use the +tactic monad. + +Note that the order of evaluation of application is *not* specified and is +implementation-dependent, as in OCaml. + +We recall that the `Proofview.tactic` monad is essentially a IO monad together +with backtracking state representing the proof state. + +Intuitively a thunk of type `unit -> 'a` can do the following: +- It can perform non-backtracking IO like printing and setting mutable variables +- It can fail in a non-recoverable way +- It can use first-class backtrack. The proper way to figure that is that we + morally have the following isomorphism: + `(unit -> 'a) ~ unit -> ('a + (exn -> 'a))` i.e. thunks can produce a list + of results waiting for failure exceptions. +- It can access a backtracking proof state, made out amongst other things of + the current evar assignation and the list of goals under focus. + +### Standard IO + +The Ltac2 language features non-backtracking IO, notably mutable data and +printing operations. + +Mutable fields of records can be modified using the set syntax + +### Fatal errors + +The Ltac2 language provides non-backtracking exceptions through the +following primitive in module `Control`. + +``` +val throw : exn -> 'a +``` + +Contrarily to backtracking exceptions from the next section, this kind of error +is never caught by backtracking primitives, that is, throwing an exception +destroys the stack. This is materialized by the following equation, where `E` +is an evaluation context. + +``` +E[throw e] ≡ throw e +``` + +There is currently no way to catch such an exception and it is a design choice. +There might be at some future point a way to catch it in a brutal way, +destroying all backtrack and return values. + +### Backtrack + +In Ltac2, we have the following backtracking primitives, defined in the +`Control` module. + +``` +Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. + +val zero : exn -> 'a +val plus : (unit -> 'a) -> (exn -> 'a) -> 'a +val case : (unit -> 'a) -> ('a * (exn -> 'a)) result +``` + +If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +list concatenation, while `case` is pattern-matching. + +The backtracking is first-class, i.e. one can write +`plus "x" (fun () -> "y") : string` producing a backtracking string. + +These operations are expected to satisfy a few equations, most notably that they +form a monoid compatible with sequentialization. + +``` +plus t zero ≡ t () +plus (fun () -> zero e) f ≡ f e +plus (plus t f) g ≡ plus t (fun e -> plus (f e) g) + +case (fun () -> zero e) ≡ Err e +case (fun () -> plus (fun () -> t) f) ≡ Val t f + +let x := zero e in u ≡ fail e +let x := plus t f in u ≡ plus (fun () -> let x := t in u) (fun e -> let x := f e in u) + +(t, u, f, g, e values) +``` + +### Goals + +A goal is given by the data of its conclusion and hypotheses, i.e. it can be +represented as `[Γ ⊢ A]`. + +The tactic monad naturally operates over the whole proofview, which may +represent several goals, including none. Thus, there is no such thing as +*the current goal*. Goals are naturally ordered, though. + +It is natural to do the same in Ltac2, but we must provide a way to get access +to a given goal. This is the role of the `enter` primitive, that applies a +tactic to each currently focussed goal in turn. + +``` +val enter : (unit -> unit) -> unit +``` + +It is guaranteed that when evaluating `enter f`, `f` is called with exactly one +goal under focus. Note that `f` may be called several times, or never, depending +on the number of goals under focus before the call to `enter`. + +A more expressive primitive allows to retrieve the data returned by each tactic +and store it in a list. + +``` +val enter_val : (unit -> 'a) -> 'a list +``` + +Accessing the goal data is then implicit in the Ltac2 primitives, and may fail +if the invariants are not respected. The two essential functions for observing +goals are given below. + +``` +val hyp : ident -> constr +val goal : unit -> constr +``` + +The two above functions fail if there is not exactly one goal under focus. +In addition, `hyp` may also fail if there is no hypothesis with the +corresponding name. + +# Meta-programming + +## Overview + +One of the horrendous implementation issues of Ltac is the fact that it is +never clear whether an object refers to the object world or the meta-world. +This is an incredible source of slowness, as the interpretation must be +aware of bound variables and must use heuristics to decide whether a variable +is a proper one or referring to something in the Ltac context. + +Likewise, in Ltac1, constr parsing is implicit, so that `foo 0` is +not `foo` applied to the Ltac integer expression `0` (Ltac does have a +non-first-class notion of integers), but rather the Coq term `Datatypes.O`. + +We should stop doing that! We need to mark when quoting and unquoting, although +we need to do that in a short and elegant way so as not to be too cumbersome +to the user. + +## Syntax example + +Here is a suggestive example of a reasonable syntax. + +``` +let var := "H" in (* a string *) +let c := << fun $var$ => 0 >> (* the Coq term "fun H => 0" *) +let c' := << let x := $c$ in nat >> (* the Coq term "let x := fun H => 0 in nat" *) +... +``` + +## Term quotation + +### Syntax + +It is better to define primitively the quoting syntax to build terms, as this +is more robust to changes. + +``` +t, u ::= ... | << constr >> +``` + +The `constr` datatype have the same syntax as the usual Coq +terms, except that it also allows antiquotations of the form `$t$` whose type +is statically inferred from the position, e.g. + +``` +<< let $t$ := $u$ >> (** [t] is an ident, [u] is a constr *) +``` + +As the term syntax implicitly allows to inject other classes without marking, +antiquotations can refer explicitly to which class they belong to overcome this +limitation. + +``` +<< $ident:t$ >> (** [t] is an ident, and the corresponding constr is [GVar t] *) +<< $ref:t$ >> (** [t] is a reference, and the corresponding constr is [GRef t] *) +``` + +### Semantics + +Interpretation of a quoted constr is done in two phases, internalization and +evaluation. +- During internalization, variables are resolved and antiquotations are + type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq + implementation terminology, potentially ill-typed as a Coq term. +- During evaluation, a quoted term is fully evaluated to a kernel term, and is + in particular type-checked in the current environment. + +Internalization is part of the static semantics, i.e. it is done at typing +time, while evaluation is part of the dynamic semantics, i.e. it is done when +a term gets effectively computed. + +#### Static semantics + +The typing rule of a quoted constr is given below, where the `eᵢ` refer to +antiquoted terms. + +``` + Γ ⊢ e₁ : unit Γ ⊢ eₙ : unit +==================================== + Γ ⊢ << c{$e₁$, ..., $eₙ$} >> : constr +``` + +Note that the **static** environment of typing of antiquotations is **not** +expanded by the binders from the term. Namely, it means that the following +expression will **not** type-check. +``` +<< fun x : nat => $exact x$ >> +``` + +There is a simple reason for that, which is that the following expression would +not make sense in general. +``` +<< fun x : nat => $clear x; exact x$ >> +``` + +Rather, the tactic writer has to resort to the **dynamic** environment, and must +write instead something that amounts to the following. +``` +<< fun x : nat => $exact (hyp "x")$ >> +``` + +Obviously, we need to provide syntactic sugar to make this tractable. See the +corresponding section for more details. + +#### Dynamic semantics + +Evaluation of a quoted term is described below. +- The quoted term is evaluated by the pretyper. +- Antiquotations are evaluated in a context where there is exactly one goal +under focus, with the hypotheses coming from the current environment extended +with the bound variables of the term, and the resulting term is fed into the +quoted term. + +Relative orders of evaluation of antiquotations and quoted term is not +specified. + +## Patterns + +Terms can be used in pattern position just as any Ltac constructor. The accepted +syntax is a subset of the constr syntax in Ltac term position, where +antiquotations are variables binding in the right-hand side. + +Constructors and destructors can be derived from this. E.g. the previous +var-manipulating functions can be defined as follows. + +``` +let mkVar : ident -> constr = fun id -> << $ident:id$ >> + +let destVar : constr -> ident = function +| << $ident:x$ >> -> x +| _ -> fail () +``` + +One should be careful in patterns not to mix the syntax for evars with the one +for bound variables. + +The usual match construction from Ltac1 can be derived from those primitive +operations. We should provide syntactic sugar to do so. + +We need to decide how to handle bound variables in antiquotations, both in term +and pattern position. Should they bind? Should they not? What is the semantics +of the following snippet? + +``` +let foo = function << let x := t in $p$ >> -> p +let bar p = << let x := t in $p$ >> +``` + +What about the various kind of constrs? Untyped vs. typed, plus caring about +the context? + +### Lists and Gallina `match` + +It should be possible to manipulate Gallina `match` statements in a relatively +pain-free way. For this reason, there should be a way to match on lists: + +``` +let replace_args = function << $f$ $a1 .. an$ >> + << $g$ $b1 .. bn$ >> + -> << $f$ $b1 .. bn$ >> +let head = function << $f$ $a1 .. an$ >> -> << $f$ >> +let args : constr -> constr list = function << $f$ $a1 .. an$ >> -> [a1 ; .. ; an] +let apply (f : constr) : constr list -> constr = function +| $a1 .. an$ -> << $f$ $a1 .. an$ >> +let complicated_identity v = (let f = head v in let xs = args v in apply f xs) + +let open_term_under_binders = function << fun $a1 .. an$ => $body$ >> -> << $body$ >> +let binders : constr -> ident list = function << fun $a1 .. an$ => $body$ >> -> [a1 ; .. ; an] +let close_term (body : constr) : ident list -> constr = function $a1 .. an$ -> << fun $a1 .. an$ => $body$ >> +let complicated_function_identity v = + let b = open_term_under_binders v in + let xs = binders v in + close_term body xs +``` + +We could implement the `@?P` pattern as something like the desugaring rule: +``` +rule + (match term with + | (@?P a1 .. an)) + ~> + let P = type_check (<< fun $a1 .. an$ => $term$ >>) in ... +``` +The call to `type_check` ensures that there are no remaining holes in the term. +It is, perhaps, overkill. + +Then we could destructure a `match` via syntax like: +``` +let match_to_eta = function +| << match $t$ as $t'$ in $Ty$ return $P$ with + | $c1$ => $v1$ + .. + | $cm$ => $vm$ + end >> + -> << match $t$ in $Ty$ return $Ty$ with + | $c1$ => $c1$ + .. + | $cm$ => $cm$ + end >> +``` +which would take something like `match b with true => 0 | false => 1 end` and +return `match b with true => true | false => false end`. + +We should be able to construct the eliminators for inductive types +in Ltac 2.0, using this syntax to generate the bodies, together with some +primitives for acquiring the relevant types. + + +**Questions**: +- What exactly are the semantics of `..`? +- Should it be `$a1 .. an$` or `$a1$ .. $an$`? +- This syntax suggests that when open terms are used in binding positions, + unbound variables should become binding patterns. That is, if you have + `v` which has been constructed as `<< @cons _ $x$ $xs$ >>`, then + `<< fun ls : list nat => match ls with $v$ => $v$ | _ => nil end >>` should + be the eta-expansion of `ls`. Is this desired semantics? Are there issues + with it? + +# Notations + +Notations are the crux of the usability of Ltac. We should be able to recover +a feeling similar to the old implementation by using and abusing notations. +This would be done at at level totally different from the semantics, which +is not what is happening as of today. + +## Scopes + +We would like to attach some scopes to identifiers, so that it could be possible +to write e.g. + +``` +Ltac intro : string -> unit := ... + +Goal True -> True. +Proof. +intro "H". (** We require the quote here, as this is not a notation *) +Undo. +Top.intro "H". (** An alternative way, by fully qualifying the tactic *) +Abort. + +Tactic Notation "intro" ident(i) := intro i. + +Goal True -> True. +Proof. +intro H. +(** This sequence of tokens is elaborated at parsing time into [Top.intro "H"] + thanks to the above notation. *) +Undo. +Top.intro "H". +(** Here, the core tactic is still reachable using the fully qualified name *) +Abort. +``` + +A typical notation that would be useful is the Coq term one, so that the +following is possible. + +``` +Ltac destruct : constr -> unit := ... + +Tactic Notation "destruct" constr(x) := destruct x. + +Goal False -> True. +Proof. +intro H. (** assuming we have the previous notation in scope *) +destruct H. (** H is interpreted in the current goal? *) +Undo. +Top.destruct << H >> (** alternative without notation *) +``` + +Another one, probably useful for transition, would be a scope `legacy_constr` +that parses an identifier s.t. `legacy_constr(H)` elaborates to +`hyp H + mkVar H`. + +One should be able to define new scopes, by giving them a qualified name, +a old scope used for the parsing rule, and an expansion macro. We can maybe +unify such a scope creation process with the tactic notation one? + +## Syntactic sugar + +A few dedicated syntaxes should be built-in into Ltac2 for easy manipulation +of Coq-specific data. + +### Identifiers + +We need to write identifiers as easily as strings. What about `#foo` standing +for the identifier `foo`? + +### Hypotheses + +We need to be able to access easily a hypothesis from its name. What about +`` `foo `` being a shorthand for `hyp "foo"`? This needs to be accessible inside +terms as well. + +# Transition path + +TODO -- cgit v1.2.3 From 60e581f6fbcf033e134291016351492d9df7e319 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 02:01:09 +0200 Subject: Fixup doc --- doc/ltac2.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/ltac2.md b/doc/ltac2.md index 38a56d3d6b..e2aa4cfb3b 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -126,8 +126,10 @@ statically defined, but can instead by extended dynamically. A typical example is the standard `exn` type. Pattern-matching must always include a catch-all clause. They can be extended by the following command. +``` VERNAC ::= | "Ltac2" "Type" TYPEPARAMS QUALID ":=" "[" CONSTRUCTORDEF "]" +``` ## Term Syntax -- cgit v1.2.3 From 21087463e0a14bd101e01683c6dd7850fcccb395 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 02:03:30 +0200 Subject: Fixup doc --- doc/ltac2.md | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index e2aa4cfb3b..abd5493cec 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -263,6 +263,8 @@ is an evaluation context. ``` E[throw e] ≡ throw e + +(e value) ``` There is currently no way to catch such an exception and it is a design choice. @@ -286,7 +288,7 @@ If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is list concatenation, while `case` is pattern-matching. The backtracking is first-class, i.e. one can write -`plus "x" (fun () -> "y") : string` producing a backtracking string. +`plus "x" (fun () => "y") : string` producing a backtracking string. These operations are expected to satisfy a few equations, most notably that they form a monoid compatible with sequentialization. @@ -299,7 +301,7 @@ plus (plus t f) g ≡ plus t (fun e -> plus (f e) g) case (fun () -> zero e) ≡ Err e case (fun () -> plus (fun () -> t) f) ≡ Val t f -let x := zero e in u ≡ fail e +let x := zero e in u ≡ zero e let x := plus t f in u ≡ plus (fun () -> let x := t in u) (fun e -> let x := f e in u) (t, u, f, g, e values) -- cgit v1.2.3 From 7cd31681eb5e3ccc7e7e920bb7eebe92827f6b16 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 11:37:45 +0200 Subject: More in documentation. --- doc/ltac2.md | 385 ++++++++++++++++++++++++++--------------------------------- 1 file changed, 167 insertions(+), 218 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index abd5493cec..fee19e5df0 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -185,6 +185,20 @@ There is a dedicated syntax for list and array litterals. Limitations: for now, deep pattern matching is not implemented yet. +## Ltac Definitions + +One can define a new global Ltac2 value using the following syntax. +``` +VERNAC ::= +| "Ltac2" RECFLAG LIDENT ":=" TERM +``` + +For semantic reasons, the body of the Ltac2 definition must be a syntactical +value, i.e. a function, a constant or a pure constructor recursively applied to +values. + +If the `RECFLAG` is set, the tactic is expanded into a recursive binding. + ## Reduction We use the usual ML call-by-value reduction, with an otherwise unspecified @@ -235,8 +249,8 @@ Intuitively a thunk of type `unit -> 'a` can do the following: - It can fail in a non-recoverable way - It can use first-class backtrack. The proper way to figure that is that we morally have the following isomorphism: - `(unit -> 'a) ~ unit -> ('a + (exn -> 'a))` i.e. thunks can produce a list - of results waiting for failure exceptions. + `(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a + lazy list of results where each tail is waiting for a continuation exception. - It can access a backtracking proof state, made out amongst other things of the current evar assignation and the list of goals under focus. @@ -245,7 +259,12 @@ Intuitively a thunk of type `unit -> 'a` can do the following: The Ltac2 language features non-backtracking IO, notably mutable data and printing operations. -Mutable fields of records can be modified using the set syntax +Mutable fields of records can be modified using the set syntax. Likewise, +built-in types like `string` and `array` feature imperative assignment. See +modules `String` and `Array` respectively. + +A few printing primitives are provided in the `Message` module, allowing to +display information to the user. ### Fatal errors @@ -328,14 +347,7 @@ It is guaranteed that when evaluating `enter f`, `f` is called with exactly one goal under focus. Note that `f` may be called several times, or never, depending on the number of goals under focus before the call to `enter`. -A more expressive primitive allows to retrieve the data returned by each tactic -and store it in a list. - -``` -val enter_val : (unit -> 'a) -> 'a list -``` - -Accessing the goal data is then implicit in the Ltac2 primitives, and may fail +Accessing the goal data is then implicit in the Ltac2 primitives, and may panic if the invariants are not respected. The two essential functions for observing goals are given below. @@ -344,7 +356,7 @@ val hyp : ident -> constr val goal : unit -> constr ``` -The two above functions fail if there is not exactly one goal under focus. +The two above functions panic if there is not exactly one goal under focus. In addition, `hyp` may also fail if there is no hypothesis with the corresponding name. @@ -366,94 +378,106 @@ We should stop doing that! We need to mark when quoting and unquoting, although we need to do that in a short and elegant way so as not to be too cumbersome to the user. -## Syntax example - -Here is a suggestive example of a reasonable syntax. +## Generic Syntax for Quotations +In general, quotations can be introduced in term by the following syntax, where +`QUOTENTRY` is some parsing entry. ``` -let var := "H" in (* a string *) -let c := << fun $var$ => 0 >> (* the Coq term "fun H => 0" *) -let c' := << let x := $c$ in nat >> (* the Coq term "let x := fun H => 0 in nat" *) -... +TERM ::= +| QUOTNAME ":" "(" QUOTENTRY ")" + +QUOTNAME := IDENT ``` -## Term quotation +The current implementation recognizes the following built-in quotations: +- "ident", which parses identifiers (type `Init.ident`). +- "constr", which parses Coq terms and produces an-evar free term at runtime + (type `Init.constr`). +- "open_constr", which parses Coq terms and produces a term potentially with + holes at runtime (type `Init.constr` as well). +- "pattern", which parses Coq patterns and produces a pattern used for term + matching (type `Init.pattern`). -### Syntax +The following syntactic sugar is provided for two common cases. +- `@id` is the same as ident:(id) +- `'t` is the same as open_constr:(t) -It is better to define primitively the quoting syntax to build terms, as this -is more robust to changes. +## Term Antiquotations -``` -t, u ::= ... | << constr >> -``` +### Syntax -The `constr` datatype have the same syntax as the usual Coq -terms, except that it also allows antiquotations of the form `$t$` whose type -is statically inferred from the position, e.g. +One can also insert Ltac2 code into Coq term, similarly to what was possible in +Ltac1. ``` -<< let $t$ := $u$ >> (** [t] is an ident, [u] is a constr *) +COQCONSTR ::= +| "ltac2" ":" "(" TERM ")" ``` -As the term syntax implicitly allows to inject other classes without marking, -antiquotations can refer explicitly to which class they belong to overcome this -limitation. - -``` -<< $ident:t$ >> (** [t] is an ident, and the corresponding constr is [GVar t] *) -<< $ref:t$ >> (** [t] is a reference, and the corresponding constr is [GRef t] *) -``` +Antiquoted terms are expected to have type `unit`, as they are only evaluated +for their side-effects. ### Semantics -Interpretation of a quoted constr is done in two phases, internalization and +Interpretation of a quoted Coq term is done in two phases, internalization and evaluation. -- During internalization, variables are resolved and antiquotations are - type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq - implementation terminology, potentially ill-typed as a Coq term. -- During evaluation, a quoted term is fully evaluated to a kernel term, and is - in particular type-checked in the current environment. -Internalization is part of the static semantics, i.e. it is done at typing -time, while evaluation is part of the dynamic semantics, i.e. it is done when -a term gets effectively computed. +- Internalization is part of the static semantics, i.e. it is done at Ltac2 + typing time. +- Evaluation is part of the dynamic semantics, i.e. it is done when + a term gets effectively computed by Ltac2. #### Static semantics -The typing rule of a quoted constr is given below, where the `eᵢ` refer to -antiquoted terms. +During internalization, Coq variables are resolved and antiquotations are +type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq +implementation terminology. Note that although it went through the +type-checking of *Ltac2*, the resulting term has not been fully computed and +is potentially ill-typed as a Coq term. ``` - Γ ⊢ e₁ : unit Γ ⊢ eₙ : unit -==================================== - Γ ⊢ << c{$e₁$, ..., $eₙ$} >> : constr +Ltac2 Definition myconstr () := constr:(nat -> 0). +// Valid with type `unit -> constr`, but will fail at runtime. ``` -Note that the **static** environment of typing of antiquotations is **not** -expanded by the binders from the term. Namely, it means that the following +Term antiquotations are type-checked in the enclosing Ltac2 typing context +of the corresponding term expression. For instance, the following with +type-check. + +``` +let x := '0 in constr:(1 + ltac2:(exact x)) +// type constr +``` + +Beware that the typing environment of typing of antiquotations is **not** +expanded by the Coq binders from the term. Namely, it means that the following expression will **not** type-check. ``` -<< fun x : nat => $exact x$ >> +constr:(fun x : nat => ltac2:(exact x)) +// Error: Unbound variable 'x' ``` There is a simple reason for that, which is that the following expression would not make sense in general. ``` -<< fun x : nat => $clear x; exact x$ >> +constr:(fun x : nat => ltac2:(clear @x; exact x)) ``` -Rather, the tactic writer has to resort to the **dynamic** environment, and must -write instead something that amounts to the following. +Rather, the tactic writer has to resort to the **dynamic** goal environment, +and must write instead explicitly that she is accessing a hypothesis, typically +as follows. ``` -<< fun x : nat => $exact (hyp "x")$ >> +constr:(fun x : nat => ltac2:(hyp @x)) ``` -Obviously, we need to provide syntactic sugar to make this tractable. See the -corresponding section for more details. +The `ltac2:(hyp @x)` pattern is so common that we provide a dedicated Coq +term notation for it. #### Dynamic semantics +During evaluation, a quoted term is fully evaluated to a kernel term, and is +in particular type-checked in the current environment. + Evaluation of a quoted term is described below. - The quoted term is evaluated by the pretyper. - Antiquotations are evaluated in a context where there is exactly one goal @@ -464,183 +488,108 @@ quoted term. Relative orders of evaluation of antiquotations and quoted term is not specified. -## Patterns - -Terms can be used in pattern position just as any Ltac constructor. The accepted -syntax is a subset of the constr syntax in Ltac term position, where -antiquotations are variables binding in the right-hand side. - -Constructors and destructors can be derived from this. E.g. the previous -var-manipulating functions can be defined as follows. - +For instance, in the following example, `tac` will be evaluated in a context +with exactly one goal under focus, whose last hypothesis is `H : nat`. The +whole expression will thus evaluate to the term `fun H : nat => nat`. ``` -let mkVar : ident -> constr = fun id -> << $ident:id$ >> - -let destVar : constr -> ident = function -| << $ident:x$ >> -> x -| _ -> fail () +let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ())) ``` -One should be careful in patterns not to mix the syntax for evars with the one -for bound variables. - -The usual match construction from Ltac1 can be derived from those primitive -operations. We should provide syntactic sugar to do so. - -We need to decide how to handle bound variables in antiquotations, both in term -and pattern position. Should they bind? Should they not? What is the semantics -of the following snippet? - -``` -let foo = function << let x := t in $p$ >> -> p -let bar p = << let x := t in $p$ >> -``` +Many standard tactics perform type-checking of their argument before going +further. It is your duty to ensure that terms are well-typed when calling +such tactics. Failure to do so will result in non-recoverable exceptions. -What about the various kind of constrs? Untyped vs. typed, plus caring about -the context? - -### Lists and Gallina `match` - -It should be possible to manipulate Gallina `match` statements in a relatively -pain-free way. For this reason, there should be a way to match on lists: - -``` -let replace_args = function << $f$ $a1 .. an$ >> - << $g$ $b1 .. bn$ >> - -> << $f$ $b1 .. bn$ >> -let head = function << $f$ $a1 .. an$ >> -> << $f$ >> -let args : constr -> constr list = function << $f$ $a1 .. an$ >> -> [a1 ; .. ; an] -let apply (f : constr) : constr list -> constr = function -| $a1 .. an$ -> << $f$ $a1 .. an$ >> -let complicated_identity v = (let f = head v in let xs = args v in apply f xs) - -let open_term_under_binders = function << fun $a1 .. an$ => $body$ >> -> << $body$ >> -let binders : constr -> ident list = function << fun $a1 .. an$ => $body$ >> -> [a1 ; .. ; an] -let close_term (body : constr) : ident list -> constr = function $a1 .. an$ -> << fun $a1 .. an$ => $body$ >> -let complicated_function_identity v = - let b = open_term_under_binders v in - let xs = binders v in - close_term body xs -``` - -We could implement the `@?P` pattern as something like the desugaring rule: -``` -rule - (match term with - | (@?P a1 .. an)) - ~> - let P = type_check (<< fun $a1 .. an$ => $term$ >>) in ... -``` -The call to `type_check` ensures that there are no remaining holes in the term. -It is, perhaps, overkill. - -Then we could destructure a `match` via syntax like: -``` -let match_to_eta = function -| << match $t$ as $t'$ in $Ty$ return $P$ with - | $c1$ => $v1$ - .. - | $cm$ => $vm$ - end >> - -> << match $t$ in $Ty$ return $Ty$ with - | $c1$ => $c1$ - .. - | $cm$ => $cm$ - end >> -``` -which would take something like `match b with true => 0 | false => 1 end` and -return `match b with true => true | false => false end`. - -We should be able to construct the eliminators for inductive types -in Ltac 2.0, using this syntax to generate the bodies, together with some -primitives for acquiring the relevant types. +## Patterns +Terms can be used in pattern position just as any Ltac constructor. The accepted +syntax is a subset of the constr syntax in Ltac term position. It does not +allow antiquotations. -**Questions**: -- What exactly are the semantics of `..`? -- Should it be `$a1 .. an$` or `$a1$ .. $an$`? -- This syntax suggests that when open terms are used in binding positions, - unbound variables should become binding patterns. That is, if you have - `v` which has been constructed as `<< @cons _ $x$ $xs$ >>`, then - `<< fun ls : list nat => match ls with $v$ => $v$ | _ => nil end >>` should - be the eta-expansion of `ls`. Is this desired semantics? Are there issues - with it? +Patterns quotations are typically used with the matching functions provided +in the `Pattern` module. # Notations -Notations are the crux of the usability of Ltac. We should be able to recover +Notations are the crux of the usability of Ltac1. We should be able to recover a feeling similar to the old implementation by using and abusing notations. -This would be done at at level totally different from the semantics, which -is not what is happening as of today. ## Scopes -We would like to attach some scopes to identifiers, so that it could be possible -to write e.g. +A scope is a name given to a grammar entry used to produce some Ltac2 expression +at parsing time. Scopes are described using a form of S-expression. ``` -Ltac intro : string -> unit := ... - -Goal True -> True. -Proof. -intro "H". (** We require the quote here, as this is not a notation *) -Undo. -Top.intro "H". (** An alternative way, by fully qualifying the tactic *) -Abort. - -Tactic Notation "intro" ident(i) := intro i. - -Goal True -> True. -Proof. -intro H. -(** This sequence of tokens is elaborated at parsing time into [Top.intro "H"] - thanks to the above notation. *) -Undo. -Top.intro "H". -(** Here, the core tactic is still reachable using the fully qualified name *) -Abort. +SCOPE := +| STRING +| INT +| LIDENT ( "(" SCOPE₀ "," ... "," SCOPEₙ ")" ) +``` + +A few scopes contain antiquotation features. For sake of uniformity, all +antiquotations are introduced by the syntax `"$" VAR`. + +The following scopes are built-in. +- constr: + + parses `c = COQCONSTR` and produces `constr:(c)` +- ident: + + parses `id = IDENT` and produces `ident:(id)` + + parses `"$" (x = IDENT)` and produces the variable `x` +- list0(*scope*): + + if *scope* parses `ENTRY`, parses ̀`(x₀, ..., xₙ = ENTRY*)` and produces + `[x₀; ...; xₙ]`. +- list0(*scope*, sep = STRING): + + if *scope* parses `ENTRY`, parses `(x₀ = ENTRY, "sep", ..., "sep", xₙ = ENTRY)` + and produces `[x₀; ...; xₙ]`. +- list1: same as list0 (with or without separator) but parses `ENTRY+` instead + of `ENTRY*`. +- opt(*scope*) + + if *scope* parses `ENTRY`, parses `ENTRY?` and produces either `None` or + `Some x` where `x` is the parsed expression. +- self: + + parses a Ltac2 expression at the current level and return it as is. +- next: + + parses a Ltac2 expression at the next level and return it as is. +- tactic(n = INT): + + parses a Ltac2 expression at the provided level *n* and return it as is. +- thunk(*scope*): + parses the same as *scope*, and if *e* is the parsed expression, returns + `fun () => e`. + +For now there is no way to declare new scopes from Ltac2 side, but this is +planned. + +## Notations + +The Ltac2 parser can be extended by syntactic notations. ``` +VERNAC ::= +| "Ltac2" "Notation" TOKEN+ LEVEL? ":=" TERM -A typical notation that would be useful is the Coq term one, so that the -following is possible. +LEVEL := ":" INT +TOKEN := +| VAR "(" SCOPE ")" +| STRING ``` -Ltac destruct : constr -> unit := ... -Tactic Notation "destruct" constr(x) := destruct x. +A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded +to the provided body where every token from the notation is let-bound to the +corresponding generated expression. -Goal False -> True. -Proof. -intro H. (** assuming we have the previous notation in scope *) -destruct H. (** H is interpreted in the current goal? *) -Undo. -Top.destruct << H >> (** alternative without notation *) +For instance, assume we perform: +``` +Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. +``` +Then the following expression +``` +let y := @X in foo (nat -> nat) x ?y +``` +will expand at parsing time to +``` +let y := @X in +let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids ``` -Another one, probably useful for transition, would be a scope `legacy_constr` -that parses an identifier s.t. `legacy_constr(H)` elaborates to -`hyp H + mkVar H`. - -One should be able to define new scopes, by giving them a qualified name, -a old scope used for the parsing rule, and an expansion macro. We can maybe -unify such a scope creation process with the tactic notation one? - -## Syntactic sugar - -A few dedicated syntaxes should be built-in into Ltac2 for easy manipulation -of Coq-specific data. - -### Identifiers - -We need to write identifiers as easily as strings. What about `#foo` standing -for the identifier `foo`? - -### Hypotheses - -We need to be able to access easily a hypothesis from its name. What about -`` `foo `` being a shorthand for `hyp "foo"`? This needs to be accessible inside -terms as well. - -# Transition path - -TODO +Beware that the order of evaluation of multiple let-bindings is not specified, +so that you may have to resort to thunking to ensure that side-effects are +performed at the right time. -- cgit v1.2.3 From 8a8fd265158fa3fe7eea65b50c3da722e81fa688 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 14:43:30 +0200 Subject: Binding more primitive tactics. --- src/tac2core.ml | 2 +- src/tac2ffi.ml | 3 ++ src/tac2ffi.mli | 3 ++ src/tac2stdlib.ml | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/stuff/ltac2.v | 8 ++++++ theories/Std.v | 25 +++++++++++++++++ 6 files changed, 120 insertions(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index e0a65dde2d..fef16dcc06 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -325,7 +325,7 @@ let prm_constr_kind : ml_tactic = function |]) | Const (cst, u) -> ValBlk (10, [| - Value.of_ext Value.val_constant cst; + Value.of_constant cst; of_instance sigma u; |]) | Ind (ind, u) -> diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 74e2b02aeb..49b49d92fd 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -122,3 +122,6 @@ let of_array f vl = ValBlk (0, Array.map f vl) let to_array f = function | ValBlk (0, vl) -> Array.map f vl | _ -> assert false + +let of_constant c = of_ext val_constant c +let to_constant c = to_ext val_constant c diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 3f429995ce..b69ca9a382 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -59,6 +59,9 @@ val to_pattern : valexpr -> Pattern.constr_pattern val of_pp : Pp.t -> valexpr val to_pp : valexpr -> Pp.t +val of_constant : Constant.t -> valexpr +val to_constant : valexpr -> Constant.t + val of_ext : 'a Val.typ -> 'a -> valexpr val to_ext : 'a Val.typ -> valexpr -> 'a diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 7c7b539113..e093b5c97f 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -9,6 +9,7 @@ open Names open Locus open Misctypes +open Genredexpr open Tac2expr open Tac2core open Proofview.Notations @@ -66,6 +67,24 @@ let to_clause = function { onhyps = hyps; concl_occs = to_occurrences to_int_or_var concl; } | _ -> assert false +let to_evaluable_ref = function +| ValBlk (0, [| id |]) -> EvalVarRef (Value.to_ident id) +| ValBlk (1, [| cst |]) -> EvalConstRef (Value.to_constant cst) +| _ -> assert false + +let to_red_flag = function +| ValBlk (0, [| beta; iota; fix; cofix; zeta; delta; const |]) -> + { + rBeta = Value.to_bool beta; + rMatch = Value.to_bool iota; + rFix = Value.to_bool fix; + rCofix = Value.to_bool cofix; + rZeta = Value.to_bool zeta; + rDelta = Value.to_bool delta; + rConst = Value.to_list to_evaluable_ref const; + } +| _ -> assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -81,6 +100,8 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit +let thaw f = Tac2interp.interp_app f [v_unit] + let define_prim0 name tac = let tac = function | [_] -> lift tac @@ -102,6 +123,13 @@ let define_prim2 name tac = in Tac2env.define_primitive (pname name) tac +let define_prim3 name tac = + let tac = function + | [x; y; z] -> lift (tac x y z) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + (** Tactics from Tacexpr *) let () = define_prim2 "tac_eelim" begin fun c copt -> @@ -125,6 +153,58 @@ let () = define_prim1 "tac_egeneralize" begin fun cl -> Tactics.new_generalize_gen cl end +let () = define_prim2 "tac_pose" begin fun idopt c -> + let na = to_name idopt in + let c = Value.to_constr c in + Tactics.letin_tac None na c None Locusops.nowhere +end + +let () = define_prim3 "tac_set" begin fun idopt c cl -> + let na = to_name idopt in + let cl = to_clause cl in + Proofview.tclEVARMAP >>= fun sigma -> + thaw c >>= fun c -> + let c = Value.to_constr c in + Tactics.letin_pat_tac false None na (sigma, c) cl +end + +let () = define_prim3 "tac_eset" begin fun idopt c cl -> + let na = to_name idopt in + let cl = to_clause cl in + Proofview.tclEVARMAP >>= fun sigma -> + thaw c >>= fun c -> + let c = Value.to_constr c in + Tactics.letin_pat_tac true None na (sigma, c) cl +end + +let () = define_prim1 "tac_red" begin fun cl -> + let cl = to_clause cl in + Tactics.reduce (Red false) cl +end + +let () = define_prim1 "tac_hnf" begin fun cl -> + let cl = to_clause cl in + Tactics.reduce Hnf cl +end + +let () = define_prim2 "tac_cbv" begin fun flags cl -> + let flags = to_red_flag flags in + let cl = to_clause cl in + Tactics.reduce (Cbv flags) cl +end + +let () = define_prim2 "tac_cbn" begin fun flags cl -> + let flags = to_red_flag flags in + let cl = to_clause cl in + Tactics.reduce (Cbn flags) cl +end + +let () = define_prim2 "tac_lazy" begin fun flags cl -> + let flags = to_red_flag flags in + let cl = to_clause cl in + Tactics.reduce (Lazy flags) cl +end + (** Tactics from coretactics *) let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index ece6fca06a..6b30d42c09 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -143,3 +143,11 @@ Ltac2 rec do n tac := match Int.equal n 0 with end. Print Ltac2 do. + +Goal forall x, 1 + x = x + 1. +Proof. +refine (fun () => '(fun x => _)). +Std.cbv { + Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; + Std.rZeta := true; Std.rDelta := false; rConst := []; +} { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. diff --git a/theories/Std.v b/theories/Std.v index a9eced6cbb..3070c2e005 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -34,6 +34,21 @@ Ltac2 Type clause := { on_concl : occurrences; }. +Ltac2 Type evaluable_reference := [ +| EvalVarRef (ident) +| EvalConstRef (constant) +]. + +Ltac2 Type red_flags := { + rBeta : bool; + rMatch : bool; + rFix : bool; + rCofix : bool; + rZeta : bool; + rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) + rConst : evaluable_reference list +}. + (** Standard, built-in tactics. See Ltac1 for documentation. *) Ltac2 @ external eelim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_eelim". @@ -41,6 +56,16 @@ Ltac2 @ external ecase : constr_with_bindings -> unit := "ltac2" "tac_ecase". Ltac2 @ external egeneralize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_egeneralize". +Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". +Ltac2 @ external set : ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_set". +Ltac2 @ external eset : ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_eset". + +Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". +Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". +Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". +Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". +Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". + Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". -- cgit v1.2.3 From 30fc910b01f61ce3691ed63a0908c1c60cee76dd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 16:46:29 +0200 Subject: Fix documentation. --- doc/ltac2.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index fee19e5df0..7a3b2181f8 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -467,11 +467,11 @@ Rather, the tactic writer has to resort to the **dynamic** goal environment, and must write instead explicitly that she is accessing a hypothesis, typically as follows. ``` -constr:(fun x : nat => ltac2:(hyp @x)) +constr:(fun x : nat => ltac2:(exact (hyp @x))) ``` -The `ltac2:(hyp @x)` pattern is so common that we provide a dedicated Coq -term notation for it. +The `ltac2:(exact (hyp @x))` pattern is so common that we provide dedicated +Ltac2 and Coq term notations for it. #### Dynamic semantics -- cgit v1.2.3 From c3be78f96b91a042944f9bee66bf0ea8d929a37d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 16:56:27 +0200 Subject: Introducing the all-mighty intro-patterns. --- _CoqProject | 1 + src/g_ltac2.ml4 | 73 ++++++++++++++++++++++++++++++++++++++++++++++------- src/tac2core.ml | 22 ++++++++++------ src/tac2core.mli | 6 ++--- src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 36 ++++++++++++++++++++++++++ src/tac2quote.ml | 57 ++++++++++++++++++++++++++++++++++++++--- src/tac2quote.mli | 7 +++++ src/tac2stdlib.ml | 43 +++++++++++++++++++++++++++++++ theories/Std.v | 27 ++++++++++++++++++++ 11 files changed, 250 insertions(+), 24 deletions(-) create mode 100644 src/tac2qexpr.mli diff --git a/_CoqProject b/_CoqProject index ab73af1295..b8064c46a4 100644 --- a/_CoqProject +++ b/_CoqProject @@ -17,6 +17,7 @@ src/tac2ffi.ml src/tac2ffi.mli src/tac2core.ml src/tac2core.mli +src/tac2qexpr.mli src/tac2quote.ml src/tac2quote.mli src/tac2stdlib.ml diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 4a2f615df9..b058680645 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -14,6 +14,7 @@ open Pcoq open Constrexpr open Misctypes open Tac2expr +open Tac2qexpr open Ltac_plugin let err () = raise Stream.Failure @@ -44,9 +45,6 @@ let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c -let mk_constr ~loc kn args = - CTacApp (loc, CTacCst (loc, AbsKn (Other kn)), args) - let pattern_of_qualid loc id = if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) else @@ -278,14 +276,19 @@ END open Tac2entries.Pltac +let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) + GEXTEND Gram - GLOBAL: q_ident q_bindings; - q_ident: - [ [ id = Prim.ident -> Tac2quote.of_ident ~loc:!@loc id - | "$"; id = Prim.ident -> Tac2quote.of_variable ~loc:!@loc id + GLOBAL: q_ident q_bindings q_intropatterns; + ident_or_anti: + [ [ id = Prim.ident -> QExpr id + | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; - simple_binding: + q_ident: + [ [ id = ident_or_anti -> Tac2quote.of_anti ~loc:!@loc Tac2quote.of_ident id ] ] + ; + simple_binding: [ [ "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> Loc.tag ~loc:!@loc (NamedHyp id, Tac2quote.of_constr ~loc:!@loc c) | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> @@ -302,9 +305,61 @@ GEXTEND Gram ; q_bindings: [ [ "with"; bl = bindings -> bl - | -> mk_constr ~loc:!@loc Tac2core.Core.c_no_bindings [] + | -> Tac2quote.of_bindings ~loc:!@loc Misctypes.NoBindings ] ] ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> l ]] + ; +(* ne_intropatterns: *) +(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) +(* ; *) + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> QIntroOrPattern tc + | "()" -> QIntroAndPattern [] + | "("; si = simple_intropattern; ")" -> QIntroAndPattern [si] + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + QIntroAndPattern (si::tc) + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + let rec pairify = function + | ([]|[_]|[_;_]) as l -> l + | t::q -> [t; (QIntroAction (QIntroOrAndPattern (QIntroAndPattern (pairify q))))] + in QIntroAndPattern (pairify (si::tc)) ] ] + ; + equality_intropattern: + [ [ "->" -> QIntroRewrite true + | "<-" -> QIntroRewrite false + | "[="; tc = intropatterns; "]" -> QIntroInjection tc ] ] + ; + naming_intropattern: + [ [ LEFTQMARK; prefix = ident_or_anti -> QIntroFresh prefix + | LEFTQMARK -> QIntroAnonymous + | id = ident_or_anti -> QIntroIdentifier id ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> l + | "*" -> QIntroForthcoming true + | "**" -> QIntroForthcoming false ]] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed -> +(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) + (** TODO: handle %pat *) + pat + ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> QIntroAction (QIntroOrAndPattern pat) + | pat = equality_intropattern -> QIntroAction pat + | "_" -> QIntroAction QIntroWildcard + | pat = naming_intropattern -> QIntroNaming pat ] ] + ; + q_intropatterns: + [ [ ipat = intropatterns -> Tac2quote.of_intro_patterns ~loc:!@loc ipat ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index fef16dcc06..266e3b5f11 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -42,10 +42,8 @@ let c_cons = coq_core "::" let c_none = coq_core "None" let c_some = coq_core "Some" -let t_bindings = std_core "bindings" -let c_no_bindings = std_core "NoBindings" -let c_implicit_bindings = std_core "ImplicitBindings" -let c_explicit_bindings = std_core "ExplicitBindings" +let c_true = coq_core "true" +let c_false = coq_core "false" let t_qhyp = std_core "hypothesis" let c_named_hyp = std_core "NamedHyp" @@ -853,6 +851,14 @@ let () = add_scope "ident" begin function | _ -> scope_fail () end +let () = add_scope "thunk" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let act e = rthunk (act e) in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + let () = add_scope "bindings" begin function | [] -> let scope = Extend.Aentry Tac2entries.Pltac.q_bindings in @@ -861,10 +867,10 @@ let () = add_scope "bindings" begin function | _ -> scope_fail () end -let () = add_scope "thunk" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let act e = rthunk (act e) in +let () = add_scope "intropatterns" begin function +| [] -> + let scope = Extend.Aentry Tac2entries.Pltac.q_intropatterns in + let act tac = tac in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end diff --git a/src/tac2core.mli b/src/tac2core.mli index 118b7aaa42..6fd48e85f7 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -24,10 +24,8 @@ val t_option : type_constant val t_string : type_constant val t_array : type_constant -val t_bindings : type_constant -val c_no_bindings : ltac_constructor -val c_implicit_bindings : ltac_constant -val c_explicit_bindings : ltac_constant +val c_true : ltac_constructor +val c_false : ltac_constructor val t_qhyp : type_constant val c_anon_hyp : ltac_constructor diff --git a/src/tac2entries.ml b/src/tac2entries.ml index d293a87975..d7ee07e9e2 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -26,6 +26,7 @@ let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" +let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 4d5a234daf..e5031fdba2 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -59,4 +59,5 @@ val tac2expr : raw_tacexpr Pcoq.Gram.entry val q_ident : raw_tacexpr Pcoq.Gram.entry val q_bindings : raw_tacexpr Pcoq.Gram.entry +val q_intropatterns : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli new file mode 100644 index 0000000000..794281cc75 --- /dev/null +++ b/src/tac2qexpr.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* f ?loc x +| QAnti (loc, id) -> of_variable ?loc id + let of_ident ?loc id = inj_wit ?loc Stdarg.wit_ident id let of_constr ?loc c = inj_wit ?loc Stdarg.wit_constr c +let of_bool ?loc b = + let c = if b then Core.c_true else Core.c_false in + constructor ?loc c [] + let rec of_list ?loc = function | [] -> constructor Core.c_nil [] | e :: l -> @@ -55,9 +70,45 @@ let of_qhyp ?loc = function let of_bindings ?loc = function | NoBindings -> - constructor ?loc Core.c_no_bindings [] + std_constructor ?loc "NoBindings" [] | ImplicitBindings tl -> - constructor ?loc Core.c_implicit_bindings [of_list ?loc tl] + std_constructor ?loc "ImplicitBindings" [of_list ?loc tl] | ExplicitBindings tl -> let tl = List.map (fun (loc, (qhyp, e)) -> of_pair ?loc (of_qhyp ?loc qhyp, e)) tl in - constructor ?loc Core.c_explicit_bindings [of_list ?loc tl] + std_constructor ?loc "ExplicitBindings" [of_list ?loc tl] + +let rec of_intro_pattern ?loc = function +| QIntroForthcoming b -> + std_constructor ?loc "IntroForthcoming" [of_bool b] +| QIntroNaming iname -> + std_constructor ?loc "IntroNaming" [of_intro_pattern_naming iname] +| QIntroAction iact -> + std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] + +and of_intro_pattern_naming ?loc = function +| QIntroIdentifier id -> + std_constructor ?loc "IntroIdentifier" [of_anti ?loc of_ident id] +| QIntroFresh id -> + std_constructor ?loc "IntroFresh" [of_anti ?loc of_ident id] +| QIntroAnonymous -> + std_constructor ?loc "IntroAnonymous" [] + +and of_intro_pattern_action ?loc = function +| QIntroWildcard -> + std_constructor ?loc "IntroWildcard" [] +| QIntroOrAndPattern pat -> + std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern ?loc pat] +| QIntroInjection il -> + std_constructor ?loc "IntroInjection" [of_intro_patterns ?loc il] +| QIntroRewrite b -> + std_constructor ?loc "IntroRewrite" [of_bool ?loc b] + +and of_or_and_intro_pattern ?loc = function +| QIntroOrPattern ill -> + let ill = List.map (of_intro_patterns ?loc) ill in + std_constructor ?loc "IntroOrPattern" [of_list ?loc ill] +| QIntroAndPattern il -> + std_constructor ?loc "IntroAndPattern" [of_intro_patterns ?loc il] + +and of_intro_patterns ?loc l = + of_list ?loc (List.map (of_intro_pattern ?loc) l) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index ba6a878d50..32973ff5ba 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -8,6 +8,7 @@ open Names open Misctypes +open Tac2qexpr open Tac2expr (** Syntactic quoting of expressions. *) @@ -17,6 +18,8 @@ open Tac2expr val constructor : ?loc:Loc.t -> ltac_constructor -> raw_tacexpr list -> raw_tacexpr +val of_anti : ?loc:Loc.t -> (?loc:Loc.t -> 'a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr + val of_int : ?loc:Loc.t -> int -> raw_tacexpr val of_pair : ?loc:Loc.t -> raw_tacexpr * raw_tacexpr -> raw_tacexpr @@ -30,3 +33,7 @@ val of_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr val of_list : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr val of_bindings : ?loc:Loc.t -> raw_tacexpr bindings -> raw_tacexpr + +val of_intro_pattern : ?loc:Loc.t -> intro_pattern -> raw_tacexpr + +val of_intro_patterns : ?loc:Loc.t -> intro_pattern list -> raw_tacexpr diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index e093b5c97f..44fad48955 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -85,6 +85,39 @@ let to_red_flag = function } | _ -> assert false +let rec to_intro_pattern = function +| ValBlk (0, [| b |]) -> IntroForthcoming (Value.to_bool b) +| ValBlk (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) +| ValBlk (2, [| act |]) -> IntroAction (to_intro_pattern_action act) +| _ -> assert false + +and to_intro_pattern_naming = function +| ValBlk (0, [| id |]) -> IntroIdentifier (Value.to_ident id) +| ValBlk (1, [| id |]) -> IntroFresh (Value.to_ident id) +| ValInt 0 -> IntroAnonymous +| _ -> assert false + +and to_intro_pattern_action = function +| ValInt 0 -> IntroWildcard +| ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) +| ValBlk (1, [| inj |]) -> + let map ipat = Loc.tag (to_intro_pattern ipat) in + IntroInjection (Value.to_list map inj) +| ValBlk (2, [| _ |]) -> IntroApplyOn (assert false, assert false) (** TODO *) +| ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) +| _ -> assert false + +and to_or_and_intro_pattern = function +| ValBlk (0, [| ill |]) -> + IntroOrPattern (Value.to_list to_intro_patterns ill) +| ValBlk (1, [| il |]) -> + IntroAndPattern (to_intro_patterns il) +| _ -> assert false + +and to_intro_patterns il = + let map ipat = Loc.tag (to_intro_pattern ipat) in + Value.to_list map il + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -132,6 +165,16 @@ let define_prim3 name tac = (** Tactics from Tacexpr *) +let () = define_prim1 "tac_intros" begin fun ipat -> + let ipat = to_intro_patterns ipat in + Tactics.intros_patterns false ipat +end + +let () = define_prim1 "tac_eintros" begin fun ipat -> + let ipat = to_intro_patterns ipat in + Tactics.intros_patterns true ipat +end + let () = define_prim2 "tac_eelim" begin fun c copt -> let c = to_constr_with_bindings c in let copt = Value.to_option to_constr_with_bindings copt in diff --git a/theories/Std.v b/theories/Std.v index 3070c2e005..a27790c35d 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -49,8 +49,35 @@ Ltac2 Type red_flags := { rConst : evaluable_reference list }. +Ltac2 Type 'a not_implemented. + +Ltac2 Type rec intro_pattern := [ +| IntroForthcoming (bool) +| IntroNaming (intro_pattern_naming) +| IntroAction (intro_pattern_action) +] +with intro_pattern_naming := [ +| IntroIdentifier (ident) +| IntroFresh (ident) +| IntroAnonymous +] +with intro_pattern_action := [ +| IntroWildcard +| IntroOrAndPattern (or_and_intro_pattern) +| IntroInjection (intro_pattern list) +| IntroApplyOn ((constr * intro_pattern) not_implemented) (* Not Implemented yet *) +| IntroRewrite (bool) +] +with or_and_intro_pattern := [ +| IntroOrPattern (intro_pattern list list) +| IntroAndPattern (intro_pattern list) +]. + (** Standard, built-in tactics. See Ltac1 for documentation. *) +Ltac2 @ external intros : intro_pattern list -> unit := "ltac2" "tac_intros". +Ltac2 @ external eintros : intro_pattern list -> unit := "ltac2" "tac_eintros". + Ltac2 @ external eelim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_eelim". Ltac2 @ external ecase : constr_with_bindings -> unit := "ltac2" "tac_ecase". -- cgit v1.2.3 From 73ecd7e2f0136234f73f405a569858f2b0ecee9b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 16:56:27 +0200 Subject: Fix parsing of fresh ident antiquotations. --- src/g_ltac2.ml4 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index b058680645..a09e99aa6b 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -335,8 +335,9 @@ GEXTEND Gram | "[="; tc = intropatterns; "]" -> QIntroInjection tc ] ] ; naming_intropattern: - [ [ LEFTQMARK; prefix = ident_or_anti -> QIntroFresh prefix - | LEFTQMARK -> QIntroAnonymous + [ [ LEFTQMARK; id = Prim.ident -> QIntroFresh (QExpr id) + | "?$"; id = Prim.ident -> QIntroFresh (QAnti (Loc.tag ~loc:!@loc id)) + | "?" -> QIntroAnonymous | id = ident_or_anti -> QIntroIdentifier id ] ] ; nonsimple_intropattern: -- cgit v1.2.3 From 6d8b31504efce96ec6d3011763ced0c631cf576a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 20:35:19 +0200 Subject: Don't reuse Coq AST for binding quotations. This allows antiquotations in binding lists. --- src/g_ltac2.ml4 | 27 ++++++++++++++++++--------- src/tac2qexpr.mli | 6 ++++++ src/tac2quote.ml | 8 ++++---- src/tac2quote.mli | 2 +- tests/example2.v | 6 ++++++ 5 files changed, 35 insertions(+), 14 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index a09e99aa6b..71fb59acf8 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -19,7 +19,7 @@ open Ltac_plugin let err () = raise Stream.Failure -(* idem for (x:=t) and (1:=t) *) +(* lookahead for (x:=t), (?x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Gram.Entry.of_parser "test_lpar_idnum_coloneq" (fun strm -> @@ -30,6 +30,13 @@ let test_lpar_idnum_coloneq = (match stream_nth 2 strm with | KEYWORD ":=" -> () | _ -> err ()) + | LEFTQMARK -> + (match stream_nth 2 strm with + | IDENT _ -> + (match stream_nth 3 strm with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) | _ -> err ()) | _ -> err ()) @@ -282,30 +289,32 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropatterns; ident_or_anti: [ [ id = Prim.ident -> QExpr id - | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + | LEFTQMARK; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; q_ident: [ [ id = ident_or_anti -> Tac2quote.of_anti ~loc:!@loc Tac2quote.of_ident id ] ] ; simple_binding: - [ [ "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (NamedHyp id, Tac2quote.of_constr ~loc:!@loc c) + [ [ "("; LEFTQMARK; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), Tac2quote.of_constr ~loc:!@loc c) | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (AnonHyp n, Tac2quote.of_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QExpr (AnonHyp n), Tac2quote.of_constr ~loc:!@loc c) + | "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (QExpr (NamedHyp id), Tac2quote.of_constr ~loc:!@loc c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - Tac2quote.of_bindings ~loc:!@loc (ExplicitBindings bl) + QExplicitBindings bl | bl = LIST1 Constr.constr -> let bl = List.map (fun c -> Tac2quote.of_constr ~loc:!@loc c) bl in - Tac2quote.of_bindings ~loc:!@loc (Misctypes.ImplicitBindings bl) + QImplicitBindings bl ] ] ; q_bindings: - [ [ "with"; bl = bindings -> bl - | -> Tac2quote.of_bindings ~loc:!@loc Misctypes.NoBindings + [ [ "with"; bl = bindings -> Tac2quote.of_bindings ~loc:!@loc bl + | -> Tac2quote.of_bindings ~loc:!@loc QNoBindings ] ] ; intropatterns: diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 794281cc75..b68efe73ac 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -9,6 +9,7 @@ open Util open Loc open Names +open Tac2expr (** Quoted variants of Ltac syntactic categories. Contrarily to the former, they sometimes allow anti-quotations. Used for notation scopes. *) @@ -17,6 +18,11 @@ type 'a or_anti = | QExpr of 'a | QAnti of Id.t located +type bindings = +| QImplicitBindings of raw_tacexpr list +| QExplicitBindings of (Misctypes.quantified_hypothesis or_anti * raw_tacexpr) Loc.located list +| QNoBindings + type intro_pattern = | QIntroForthcoming of bool | QIntroNaming of intro_pattern_naming diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 96a3a5d9b8..488bcb5201 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -69,12 +69,12 @@ let of_qhyp ?loc = function | NamedHyp id -> constructor Core.c_named_hyp [of_ident ?loc id] let of_bindings ?loc = function -| NoBindings -> +| QNoBindings -> std_constructor ?loc "NoBindings" [] -| ImplicitBindings tl -> +| QImplicitBindings tl -> std_constructor ?loc "ImplicitBindings" [of_list ?loc tl] -| ExplicitBindings tl -> - let tl = List.map (fun (loc, (qhyp, e)) -> of_pair ?loc (of_qhyp ?loc qhyp, e)) tl in +| QExplicitBindings tl -> + let tl = List.map (fun (loc, (qhyp, e)) -> of_pair ?loc (of_anti ?loc of_qhyp qhyp, e)) tl in std_constructor ?loc "ExplicitBindings" [of_list ?loc tl] let rec of_intro_pattern ?loc = function diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 32973ff5ba..c9ee270d38 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -32,7 +32,7 @@ val of_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr val of_list : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr -val of_bindings : ?loc:Loc.t -> raw_tacexpr bindings -> raw_tacexpr +val of_bindings : ?loc:Loc.t -> bindings -> raw_tacexpr val of_intro_pattern : ?loc:Loc.t -> intro_pattern -> raw_tacexpr diff --git a/tests/example2.v b/tests/example2.v index 5efbf90b34..ffdb723ffb 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -13,3 +13,9 @@ Proof. split with 0. split. Qed. + +Goal exists n, n = 0. +Proof. +let myvar := Std.NamedHyp @x in split with (?myvar := 0). +split. +Qed. -- cgit v1.2.3 From 33e2bfe7a5eb9867634be82262ad041460709bcb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 20:52:52 +0200 Subject: Expanding unification variables in typechecking error messages. --- src/tac2intern.ml | 37 +++++++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 10 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 16e0bc8cbe..32ed211ad0 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -316,6 +316,27 @@ let rec kind env t = match t with if is_unfoldable kn then kind env (unfold env kn tl) else t | GTypArrow _ | GTypRef (Tuple _, _) -> t +(** Normalize unification variables without unfolding type aliases *) +let rec nf env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> nf env t + end +| GTypRef (kn, tl) -> + let tl = List.map (fun t -> nf env t) tl in + GTypRef (kn, tl) +| GTypArrow (t, u) -> + let t = nf env t in + let u = nf env u in + GTypArrow (t, u) + +let pr_glbtype env t = + let t = nf env t in + let name = env_name env in + pr_glbtype name t + exception Occur let rec occur_check env id t = match kind env t with @@ -357,9 +378,8 @@ let rec unify env t1 t2 = match kind env t1, kind env t2 with let unify ?loc env t1 t2 = try unify env t1 t2 with CannotUnify (u1, u2) -> - let name = env_name env in - user_err ?loc (str "This expression has type " ++ pr_glbtype name t1 ++ - str " but an expression was expected of type " ++ pr_glbtype name t2) + user_err ?loc (str "This expression has type " ++ pr_glbtype env t1 ++ + str " but an expression was expected of type " ++ pr_glbtype env t2) let unify_arrow ?loc env ft args = let ft0 = ft in @@ -373,12 +393,11 @@ let unify_arrow ?loc env ft args = let () = unify_var env id (GTypArrow (t, ft)) in iter ft args true | GTypRef _, _ :: _ -> - let name = env_name env in if is_fun then - user_err ?loc (str "This function has type " ++ pr_glbtype name ft0 ++ + user_err ?loc (str "This function has type " ++ pr_glbtype env ft0 ++ str " and is applied to too many arguments") else - user_err ?loc (str "This expression has type " ++ pr_glbtype name ft0 ++ + user_err ?loc (str "This expression has type " ++ pr_glbtype env ft0 ++ str " and is not a function") in iter ft args false @@ -478,15 +497,13 @@ let check_elt_empty loc env t = match kind env t with | GTypVar _ -> user_err ~loc (str "Cannot infer an empty type for this expression") | GTypArrow _ | GTypRef (Tuple _, _) -> - let name = env_name env in - user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") + user_err ~loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") | GTypRef (Other kn, _) -> let def = Tac2env.interp_type kn in match def with | _, GTydAlg { galg_constructors = [] } -> kn | _ -> - let name = env_name env in - user_err ~loc (str "Type " ++ pr_glbtype name t ++ str " is not an empty type") + user_err ~loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") let check_unit ?loc t = let env = empty_env () in -- cgit v1.2.3 From dd1343eb2680c202cf059e3db5788904b7d79782 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Aug 2017 21:52:15 +0200 Subject: More primitive tactics. --- src/tac2stdlib.ml | 16 ++++++++++++++++ theories/Std.v | 3 +++ 2 files changed, 19 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 44fad48955..8fdf9c6d8c 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -196,6 +196,22 @@ let () = define_prim1 "tac_egeneralize" begin fun cl -> Tactics.new_generalize_gen cl end +let () = define_prim3 "tac_assert" begin fun c tac ipat -> + let c = Value.to_constr c in + let of_tac t = Proofview.tclIGNORE (thaw t) in + let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in + let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in + Tactics.forward true tac ipat c +end + +let () = define_prim3 "tac_enough" begin fun c tac ipat -> + let c = Value.to_constr c in + let of_tac t = Proofview.tclIGNORE (thaw t) in + let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in + let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in + Tactics.forward false tac ipat c +end + let () = define_prim2 "tac_pose" begin fun idopt c -> let na = to_name idopt in let c = Value.to_constr c in diff --git a/theories/Std.v b/theories/Std.v index a27790c35d..d2b85f215e 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -83,6 +83,9 @@ Ltac2 @ external ecase : constr_with_bindings -> unit := "ltac2" "tac_ecase". Ltac2 @ external egeneralize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_egeneralize". +Ltac2 @ external assert : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_assert". +Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". + Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". Ltac2 @ external set : ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_set". Ltac2 @ external eset : ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_eset". -- cgit v1.2.3 From a5419f01eb48b1cb3f5dee5482263530ad075ef4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 01:15:55 +0200 Subject: Fixup reification of egeneralize. --- src/tac2stdlib.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 8fdf9c6d8c..5c8337d41a 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -189,7 +189,7 @@ end let () = define_prim1 "tac_egeneralize" begin fun cl -> let cast = function | ValBlk (0, [| c; occs; na |]) -> - ((to_occurrences Value.to_int c, Value.to_constr c), to_name na) + ((to_occurrences Value.to_int occs, Value.to_constr c), to_name na) | _ -> assert false in let cl = Value.to_list cast cl in -- cgit v1.2.3 From b760af386d3c69c6963231489094685ea2a1e673 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 00:43:20 +0200 Subject: Tentatively fixing a few parsing issues. --- src/g_ltac2.ml4 | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 71fb59acf8..13d5dba8c6 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -83,29 +83,33 @@ GEXTEND Gram ] ; tac2expr: - [ "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "5" -> CTacFun (!@loc, it, body) + [ "top" RIGHTA + [ e1 = SELF; ";"; e2 = SELF -> CTacSeq (!@loc, e1, e2) ] + | "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "top" -> CTacFun (!@loc, it, body) | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "5" -> CTacLet (!@loc, isrec, lc, e) + e = tac2expr LEVEL "top" -> CTacLet (!@loc, isrec, lc, e) | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches ;"end" -> CTacCse (!@loc, e, bl) ] - | "2" LEFTA - [ e1 = tac2expr; ";"; e2 = tac2expr -> CTacSeq (!@loc, e1, e2) ] + | "::" RIGHTA + [ e1 = tac2expr; "::"; e2 = tac2expr -> + CTacApp (!@loc, CTacCst (!@loc, AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) + ] + | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + let el = e0 :: el in + CTacApp (!@loc, CTacCst (!@loc, AbsKn (Tuple (List.length el))), el) ] | "1" LEFTA [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "1" -> CTacSet (!@loc, e, RelId qid, r) - | e0 = tac2expr; ","; el = LIST1 tac2expr LEVEL "1" SEP "," -> - let el = e0 :: el in - CTacApp (!@loc, CTacCst (!@loc, AbsKn (Tuple (List.length el))), el) ] + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> CTacSet (!@loc, e, RelId qid, r) ] | "0" [ "("; a = tac2expr LEVEL "5"; ")" -> a | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) | "()" -> CTacCst (!@loc, AbsKn (Tuple 0)) | "("; ")" -> CTacCst (!@loc, AbsKn (Tuple 0)) - | "["; a = LIST0 tac2expr LEVEL "1" SEP ";"; "]" -> CTacLst (Loc.tag ~loc:!@loc a) + | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> CTacLst (Loc.tag ~loc:!@loc a) | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) | a = tactic_atom -> a ] ] -- cgit v1.2.3 From d3c3859ab6dba6495b13e055917ddf3d95851912 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 01:26:17 +0200 Subject: Better test Makefile. --- tests/Makefile | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tests/Makefile b/tests/Makefile index a48ab0860f..9370b063f8 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,7 +1,12 @@ all: $(patsubst %.v,%.v.log,$(wildcard *.v)) %.v.log: %.v - $(COQBIN)/coqtop -I ../src -Q ../theories Ltac2 < $< 2> $@ + $(COQBIN)/coqtop -batch -I ../src -Q ../theories Ltac2 -lv $< > $@ + if [ $$? = 0 ]; then \ + echo " $<... OK"; \ + else \ + echo " $<... FAIL!"; \ + fi; \ clean: rm -f *.log -- cgit v1.2.3 From 087012f8d3e5e31f489e35dce8397b5202c928b6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 01:57:48 +0200 Subject: Adding the open_constr scope --- src/tac2core.ml | 1 + src/tac2quote.ml | 2 ++ src/tac2quote.mli | 2 ++ 3 files changed, 5 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index 266e3b5f11..d2cc865299 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -876,3 +876,4 @@ let () = add_scope "intropatterns" begin function end let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr +let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 488bcb5201..0e0a7b3fce 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -55,6 +55,8 @@ let of_ident ?loc id = inj_wit ?loc Stdarg.wit_ident id let of_constr ?loc c = inj_wit ?loc Stdarg.wit_constr c +let of_open_constr ?loc c = inj_wit ?loc Stdarg.wit_open_constr c + let of_bool ?loc b = let c = if b then Core.c_true else Core.c_false in constructor ?loc c [] diff --git a/src/tac2quote.mli b/src/tac2quote.mli index c9ee270d38..a311430a66 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -30,6 +30,8 @@ val of_ident : ?loc:Loc.t -> Id.t -> raw_tacexpr val of_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr +val of_open_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr + val of_list : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr val of_bindings : ?loc:Loc.t -> bindings -> raw_tacexpr -- cgit v1.2.3 From c96b746b17a37e242fc01103d22fa0b852da84c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 01:59:32 +0200 Subject: Bindings use open constr quotations. --- src/g_ltac2.ml4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 13d5dba8c6..3c41828cd3 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -301,18 +301,18 @@ GEXTEND Gram ; simple_binding: [ [ "("; LEFTQMARK; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), Tac2quote.of_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), Tac2quote.of_open_constr ~loc:!@loc c) | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QExpr (AnonHyp n), Tac2quote.of_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QExpr (AnonHyp n), Tac2quote.of_open_constr ~loc:!@loc c) | "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QExpr (NamedHyp id), Tac2quote.of_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QExpr (NamedHyp id), Tac2quote.of_open_constr ~loc:!@loc c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> QExplicitBindings bl | bl = LIST1 Constr.constr -> - let bl = List.map (fun c -> Tac2quote.of_constr ~loc:!@loc c) bl in + let bl = List.map (fun c -> Tac2quote.of_open_constr ~loc:!@loc c) bl in QImplicitBindings bl ] ] ; -- cgit v1.2.3 From 53374f189cc9b9b67ff94d5362fdffdba6c779a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 01:42:14 +0200 Subject: Adding a few standard notations for Ltac1 tactics. --- _CoqProject | 1 + tests/example2.v | 2 +- theories/Ltac2.v | 1 + theories/Notations.v | 37 +++++++++++++++++++++++++++++++++++++ 4 files changed, 40 insertions(+), 1 deletion(-) create mode 100644 theories/Notations.v diff --git a/_CoqProject b/_CoqProject index b8064c46a4..583639612b 100644 --- a/_CoqProject +++ b/_CoqProject @@ -35,4 +35,5 @@ theories/Message.v theories/Constr.v theories/Pattern.v theories/Std.v +theories/Notations.v theories/Ltac2.v diff --git a/tests/example2.v b/tests/example2.v index ffdb723ffb..398f33561e 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -1,6 +1,6 @@ Require Import Ltac2.Ltac2. -Ltac2 Notation "split" bnd(bindings) := Std.split bnd. +Import Ltac2.Notations. Goal exists n, n = 0. Proof. diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 9aaee850cd..07229797da 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -17,3 +17,4 @@ Require Ltac2.Constr. Require Ltac2.Control. Require Ltac2.Pattern. Require Ltac2.Std. +Require Ltac2.Notations. diff --git a/theories/Notations.v b/theories/Notations.v new file mode 100644 index 0000000000..d0400667db --- /dev/null +++ b/theories/Notations.v @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Std.split bnd). + +Ltac2 Notation "esplit" bnd(bindings) := Std.esplit bnd. + +Ltac2 Notation "left" bnd(thunk(bindings)) := + Control.with_holes bnd (fun bnd => Std.left bnd). + +Ltac2 Notation "eleft" bnd(bindings) := Std.eleft bnd. + +Ltac2 Notation "right" bnd(thunk(bindings)) := + Control.with_holes bnd (fun bnd => Std.right bnd). + +Ltac2 Notation "eright" bnd(bindings) := Std.eright bnd. + +Ltac2 Notation "constructor" := Std.constructor (). +Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := + Control.with_holes bnd (fun bnd => Std.constructor_n n bnd). + +Ltac2 Notation "econstructor" := Std.econstructor (). +Ltac2 Notation "econstructor" n(tactic) bnd(bindings) := + Std.econstructor_n n bnd. -- cgit v1.2.3 From d0766f4dc08b00128a47a00ca74334ba0bfeed24 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 12:15:05 +0200 Subject: Removing deprecated stuff. --- src/tac2print.mli | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/tac2print.mli b/src/tac2print.mli index ddd599641d..2ee5cf42e0 100644 --- a/src/tac2print.mli +++ b/src/tac2print.mli @@ -19,16 +19,16 @@ type typ_level = | T1 | T0 -val pr_typref : type_constant -> std_ppcmds -val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> std_ppcmds -val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> std_ppcmds +val pr_typref : type_constant -> Pp.t +val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> Pp.t +val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t (** {5 Printing expressions} *) -val pr_constructor : ltac_constructor -> std_ppcmds -val pr_projection : ltac_projection -> std_ppcmds -val pr_glbexpr_gen : exp_level -> glb_tacexpr -> std_ppcmds -val pr_glbexpr : glb_tacexpr -> std_ppcmds +val pr_constructor : ltac_constructor -> Pp.t +val pr_projection : ltac_projection -> Pp.t +val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t +val pr_glbexpr : glb_tacexpr -> Pp.t (** {5 Utilities} *) -- cgit v1.2.3 From ebee89f2b2d1815dbb89916363de1b1ad17890e8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 13:25:12 +0200 Subject: Fixing parsing of match branches. --- src/g_ltac2.ml4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 3c41828cd3..20a00afa2e 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -90,7 +90,7 @@ GEXTEND Gram | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; e = tac2expr LEVEL "top" -> CTacLet (!@loc, isrec, lc, e) - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches ;"end" -> + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> CTacCse (!@loc, e, bl) ] | "::" RIGHTA @@ -121,7 +121,7 @@ GEXTEND Gram ] ; branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "5" -> (pat, e) ] ] + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "top" -> (pat, e) ] ] ; rec_flag: [ [ IDENT "rec" -> true -- cgit v1.2.3 From e50d86c836cf492a637db056b446bb4c70b2e40b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 13:29:12 +0200 Subject: Properly classifying Ltac2 notations. --- src/g_ltac2.ml4 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 20a00afa2e..f558f9b9cc 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -397,8 +397,12 @@ PRINTED BY pr_ltac2entry | [ tac2def_syn(e) ] -> [ e ] END -VERNAC COMMAND EXTEND VernacDeclareTactic2Definition CLASSIFIED AS SIDEFF -| [ "Ltac2" ltac2_entry(e) ] -> [ +let classify_ltac2 = function +| StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow +| StrVal _ | StrPrm _ | StrTyp _ -> Vernac_classifier.classify_as_sideeff + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition +| [ "Ltac2" ltac2_entry(e) ] => [ classify_ltac2 e ] -> [ let local = Locality.LocalityFixme.consume () in Tac2entries.register_struct ?local e ] @@ -433,4 +437,3 @@ open Stdarg VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF | [ "Print" "Ltac2" reference(tac) ] -> [ Tac2entries.print_ltac tac ] END - -- cgit v1.2.3 From da8eec98d095482c0e12c0ece9725a300e5f3d57 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 13:49:48 +0200 Subject: More examples --- tests/stuff/ltac2.v | 13 +------------ tests/typing.v | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 12 deletions(-) diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 6b30d42c09..95bff7e569 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -55,10 +55,6 @@ Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). Print Ltac2 qux3. -Ltac2 qux4 f x := x, (f x, x). - -Print Ltac2 qux4. - Ltac2 Type rec nat := [ O | S (nat) ]. Ltac2 message_of_nat n := @@ -137,17 +133,10 @@ Std.ecase (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). refine (fun () => 'eq_refl). Qed. -Ltac2 rec do n tac := match Int.equal n 0 with -| true => () -| false => tac (); do (Int.sub n 1) tac -end. - -Print Ltac2 do. - Goal forall x, 1 + x = x + 1. Proof. refine (fun () => '(fun x => _)). Std.cbv { Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; - Std.rZeta := true; Std.rDelta := false; rConst := []; + Std.rZeta := true; Std.rDelta := false; Std.rConst := []; } { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. diff --git a/tests/typing.v b/tests/typing.v index 8460ab42b7..9f18292716 100644 --- a/tests/typing.v +++ b/tests/typing.v @@ -14,6 +14,10 @@ Fail Ltac2 test2 () := test0 true. Fail Ltac2 test2 () := test0 0 0. +Ltac2 test3 f x := x, (f x, x). + +Print Ltac2 test3. + (** Polymorphism *) Ltac2 rec list_length l := @@ -23,3 +27,46 @@ match l with end. Print Ltac2 list_length. + +(** Pattern-matching *) + +Ltac2 ifb b f g := match b with +| true => f () +| false => g () +end. + +Print Ltac2 ifb. + +Ltac2 if_not_found e f g := match e with +| Not_found => f () +| _ => g () +end. + +Fail Ltac2 ifb' b f g := match b with +| true => f () +end. + +Fail Ltac2 if_not_found' e f g := match e with +| Not_found => f () +end. + +(** Reimplementing 'do'. Return value of the function useless. *) + +Ltac2 rec do n tac := match Int.equal n 0 with +| true => () +| false => tac (); do (Int.sub n 1) tac +end. + +Print Ltac2 do. + +(** Non-function pure values are OK. *) + +Ltac2 tuple0 := ([1; 2], true, (fun () => "yay")). + +Print Ltac2 tuple0. + +(** Impure values are not. *) + +Fail Ltac2 not_a_value := { contents := 0 }. +Fail Ltac2 not_a_value := "nope". +Fail Ltac2 not_a_value := list_length []. -- cgit v1.2.3 From ea782d757d57dc31be9714edc607128c5c127205 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 14:14:14 +0200 Subject: Extending the set of tactic scopes. We now allow mere tokens, keywords and sequencing amongst others. --- doc/ltac2.md | 13 ++++++++- src/tac2core.ml | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2entries.ml | 3 ++ 3 files changed, 100 insertions(+), 1 deletion(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 7a3b2181f8..12687e9aff 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -552,8 +552,19 @@ The following scopes are built-in. - tactic(n = INT): + parses a Ltac2 expression at the provided level *n* and return it as is. - thunk(*scope*): - parses the same as *scope*, and if *e* is the parsed expression, returns + + parses the same as *scope*, and if *e* is the parsed expression, returns `fun () => e`. +- STRING: + + parses the corresponding string as a CAMLP5 IDENT and returns `()`. +- keyword(s = STRING): + + parses the string *s* as a keyword and returns `()`. +- terminal(s = STRING): + + parses the string *s* as a keyword, if it is already a + keyword, otherwise as an IDENT. Returns `()`. +- seq(*scope₁*, ..., *scopeₙ*): + + parses *scope₁*, ..., *scopeₙ* in this order, and produces a n-tuple made + out of the parsed values in the same order. It is forbidden for the various + subscopes to refer to the global entry using self of next. For now there is no way to declare new scopes from Ltac2 side, but this is planned. diff --git a/src/tac2core.ml b/src/tac2core.ml index d2cc865299..b45275210e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -742,6 +742,8 @@ let scope_fail () = CErrors.user_err (str "Invalid parsing token") let dummy_loc = Loc.make_loc (-1, -1) +let q_unit = CTacCst (dummy_loc, AbsKn (Tuple 0)) + let rthunk e = let loc = Tac2intern.loc_of_tacexpr e in let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other Core.t_unit), []))] in @@ -757,6 +759,20 @@ let add_generic_scope s entry arg = in add_scope s parse +let () = add_scope "keyword" begin function +| [SexprStr (loc, s)] -> + let scope = Extend.Atoken (Tok.KEYWORD s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| _ -> scope_fail () +end + +let () = add_scope "terminal" begin function +| [SexprStr (loc, s)] -> + let scope = Extend.Atoken (CLexer.terminal s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| _ -> scope_fail () +end + let () = add_scope "list0" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in @@ -877,3 +893,72 @@ end let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr + +(** seq scope, a bit hairy *) + +open Extend +exception SelfSymbol + +type 'a any_symbol = { any_symbol : 'r. ('r, 'a) symbol } + +let rec generalize_symbol : + type a s. (s, a) Extend.symbol -> a any_symbol = function +| Atoken tok -> + { any_symbol = Atoken tok } +| Alist1 e -> + let e = generalize_symbol e in + { any_symbol = Alist1 e.any_symbol } +| Alist1sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + { any_symbol = Alist1sep (e.any_symbol, sep.any_symbol) } +| Alist0 e -> + let e = generalize_symbol e in + { any_symbol = Alist0 e.any_symbol } +| Alist0sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + { any_symbol = Alist0sep (e.any_symbol, sep.any_symbol) } +| Aopt e -> + let e = generalize_symbol e in + { any_symbol = Aopt e.any_symbol } +| Aself -> raise SelfSymbol +| Anext -> raise SelfSymbol +| Aentry e -> { any_symbol = Aentry e } +| Aentryl (e, l) -> { any_symbol = Aentryl (e, l) } +| Arules r -> { any_symbol = Arules r } + +type _ converter = +| CvNil : (Loc.t -> raw_tacexpr) converter +| CvCns : 'act converter * ('a -> raw_tacexpr) -> ('a -> 'act) converter + +let rec apply : type a. a converter -> raw_tacexpr list -> a = function +| CvNil -> fun accu loc -> + let cst = CTacCst (loc, AbsKn (Tuple (List.length accu))) in + CTacApp (loc, cst, accu) +| CvCns (c, f) -> fun accu x -> apply c (f x :: accu) + +type seqrule = +| Seqrule : ('act, Loc.t -> raw_tacexpr) norec_rule * 'act converter -> seqrule + +let rec make_seq_rule = function +| [] -> + let r = { norec_rule = Stop } in + Seqrule (r, CvNil) +| tok :: rem -> + let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in + let scope = generalize_symbol scope in + let Seqrule (r, c) = make_seq_rule rem in + let r = { norec_rule = Next (r.norec_rule, scope.any_symbol) } in + Seqrule (r, CvCns (c, f)) + +let () = add_scope "seq" begin fun toks -> + let scope = + try + let Seqrule (r, c) = make_seq_rule (List.rev toks) in + Arules [Rules (r, apply c [])] + with SelfSymbol -> + CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + in + Tac2entries.ScopeRule (scope, (fun e -> e)) +end diff --git a/src/tac2entries.ml b/src/tac2entries.ml index d7ee07e9e2..0f32736096 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -507,6 +507,9 @@ let parse_scope = function Id.Map.find id !scope_table toks else CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Nameops.pr_id id) +| SexprStr (_, str) -> + let v_unit = CTacCst (dummy_loc, AbsKn (Tuple 0)) in + ScopeRule (Extend.Atoken (Tok.IDENT str), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in CErrors.user_err ~loc (str "Invalid parsing token") -- cgit v1.2.3 From faf40da077f20a67a45fe98f8ef99f90440ef16d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 16:32:10 +0200 Subject: Adding new notations. --- src/tac2stdlib.ml | 11 +++++++++++ theories/Notations.v | 26 ++++++++++++++++++++++++++ theories/Std.v | 2 ++ 3 files changed, 39 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 5c8337d41a..ac530f5130 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -175,12 +175,23 @@ let () = define_prim1 "tac_eintros" begin fun ipat -> Tactics.intros_patterns true ipat end +let () = define_prim2 "tac_elim" begin fun c copt -> + let c = to_constr_with_bindings c in + let copt = Value.to_option to_constr_with_bindings copt in + Tactics.elim false None c copt +end + let () = define_prim2 "tac_eelim" begin fun c copt -> let c = to_constr_with_bindings c in let copt = Value.to_option to_constr_with_bindings copt in Tactics.elim true None c copt end +let () = define_prim1 "tac_case" begin fun c -> + let c = to_constr_with_bindings c in + Tactics.general_case_analysis false None c +end + let () = define_prim1 "tac_ecase" begin fun c -> let c = to_constr_with_bindings c in Tactics.general_case_analysis true None c diff --git a/theories/Notations.v b/theories/Notations.v index d0400667db..ec7a6b0b12 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -35,3 +35,29 @@ Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := Ltac2 Notation "econstructor" := Std.econstructor (). Ltac2 Notation "econstructor" n(tactic) bnd(bindings) := Std.econstructor_n n bnd. + +Ltac2 eelim c bnd use := + let use := match use with + | None => None + | Some u => + let ((_, c, wth)) := u in Some (c, wth) + end in + Std.eelim (c, bnd) use. + +Ltac2 elim c bnd use := + Control.with_holes + (fun () => c (), bnd (), use ()) + (fun ((c, bnd, use)) => + let use := match use with + | None => None + | Some u => + let ((_, c, wth)) := u in Some (c, wth) + end in + Std.elim (c, bnd) use). + +Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) + use(thunk(opt(seq("using", constr, bindings)))) := elim c bnd use. + +Ltac2 Notation "eelim" c(constr) bnd(bindings) + use(opt(seq("using", constr, bindings))) := + eelim c bnd use. diff --git a/theories/Std.v b/theories/Std.v index d2b85f215e..3d0f463c5e 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -78,7 +78,9 @@ with or_and_intro_pattern := [ Ltac2 @ external intros : intro_pattern list -> unit := "ltac2" "tac_intros". Ltac2 @ external eintros : intro_pattern list -> unit := "ltac2" "tac_eintros". +Ltac2 @ external elim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". Ltac2 @ external eelim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_eelim". +Ltac2 @ external case : constr_with_bindings -> unit := "ltac2" "tac_case". Ltac2 @ external ecase : constr_with_bindings -> unit := "ltac2" "tac_ecase". Ltac2 @ external egeneralize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_egeneralize". -- cgit v1.2.3 From 9088f6db4f56d906d8a18eeaf09c9adbae4a5fd4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 16:46:12 +0200 Subject: Merging the e/- variants of primitive tactics. --- src/tac2stdlib.ml | 97 +++++++++++++++++++--------------------------------- theories/Notations.v | 28 +++++++-------- theories/Std.v | 31 +++++++---------- 3 files changed, 61 insertions(+), 95 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index ac530f5130..f63252ec22 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -163,41 +163,35 @@ let define_prim3 name tac = in Tac2env.define_primitive (pname name) tac -(** Tactics from Tacexpr *) +let define_prim4 name tac = + let tac = function + | [x; y; z; u] -> lift (tac x y z u) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac -let () = define_prim1 "tac_intros" begin fun ipat -> - let ipat = to_intro_patterns ipat in - Tactics.intros_patterns false ipat -end +(** Tactics from Tacexpr *) -let () = define_prim1 "tac_eintros" begin fun ipat -> +let () = define_prim2 "tac_intros" begin fun ev ipat -> + let ev = Value.to_bool ev in let ipat = to_intro_patterns ipat in - Tactics.intros_patterns true ipat + Tactics.intros_patterns ev ipat end -let () = define_prim2 "tac_elim" begin fun c copt -> +let () = define_prim3 "tac_elim" begin fun ev c copt -> + let ev = Value.to_bool ev in let c = to_constr_with_bindings c in let copt = Value.to_option to_constr_with_bindings copt in - Tactics.elim false None c copt + Tactics.elim ev None c copt end -let () = define_prim2 "tac_eelim" begin fun c copt -> +let () = define_prim2 "tac_case" begin fun ev c -> + let ev = Value.to_bool ev in let c = to_constr_with_bindings c in - let copt = Value.to_option to_constr_with_bindings copt in - Tactics.elim true None c copt -end - -let () = define_prim1 "tac_case" begin fun c -> - let c = to_constr_with_bindings c in - Tactics.general_case_analysis false None c + Tactics.general_case_analysis ev None c end -let () = define_prim1 "tac_ecase" begin fun c -> - let c = to_constr_with_bindings c in - Tactics.general_case_analysis true None c -end - -let () = define_prim1 "tac_egeneralize" begin fun cl -> +let () = define_prim1 "tac_generalize" begin fun cl -> let cast = function | ValBlk (0, [| c; occs; na |]) -> ((to_occurrences Value.to_int occs, Value.to_constr c), to_name na) @@ -229,22 +223,14 @@ let () = define_prim2 "tac_pose" begin fun idopt c -> Tactics.letin_tac None na c None Locusops.nowhere end -let () = define_prim3 "tac_set" begin fun idopt c cl -> - let na = to_name idopt in - let cl = to_clause cl in - Proofview.tclEVARMAP >>= fun sigma -> - thaw c >>= fun c -> - let c = Value.to_constr c in - Tactics.letin_pat_tac false None na (sigma, c) cl -end - -let () = define_prim3 "tac_eset" begin fun idopt c cl -> +let () = define_prim4 "tac_set" begin fun ev idopt c cl -> + let ev = Value.to_bool ev in let na = to_name idopt in let cl = to_clause cl in Proofview.tclEVARMAP >>= fun sigma -> thaw c >>= fun c -> let c = Value.to_constr c in - Tactics.letin_pat_tac true None na (sigma, c) cl + Tactics.letin_pat_tac ev None na (sigma, c) cl end let () = define_prim1 "tac_red" begin fun cl -> @@ -301,21 +287,15 @@ let () = define_prim1 "tac_cut" begin fun c -> Tactics.cut c end -let () = define_prim1 "tac_left" begin fun bnd -> - let bnd = to_bindings bnd in - Tactics.left_with_bindings false bnd -end -let () = define_prim1 "tac_eleft" begin fun bnd -> +let () = define_prim2 "tac_left" begin fun ev bnd -> + let ev = Value.to_bool ev in let bnd = to_bindings bnd in - Tactics.left_with_bindings true bnd + Tactics.left_with_bindings ev bnd end -let () = define_prim1 "tac_right" begin fun bnd -> +let () = define_prim2 "tac_right" begin fun ev bnd -> + let ev = Value.to_bool ev in let bnd = to_bindings bnd in - Tactics.right_with_bindings false bnd -end -let () = define_prim1 "tac_eright" begin fun bnd -> - let bnd = to_bindings bnd in - Tactics.right_with_bindings true bnd + Tactics.right_with_bindings ev bnd end let () = define_prim1 "tac_introsuntil" begin fun h -> @@ -334,19 +314,16 @@ let () = define_prim1 "tac_nativecastnocheck" begin fun c -> Tactics.native_cast_no_check (Value.to_constr c) end -let () = define_prim0 "tac_constructor" (Tactics.any_constructor false None) -let () = define_prim0 "tac_econstructor" (Tactics.any_constructor true None) - -let () = define_prim2 "tac_constructorn" begin fun n bnd -> - let n = Value.to_int n in - let bnd = to_bindings bnd in - Tactics.constructor_tac false None n bnd +let () = define_prim1 "tac_constructor" begin fun ev -> + let ev = Value.to_bool ev in + Tactics.any_constructor ev None end -let () = define_prim2 "tac_econstructorn" begin fun n bnd -> +let () = define_prim3 "tac_constructorn" begin fun ev n bnd -> + let ev = Value.to_bool ev in let n = Value.to_int n in let bnd = to_bindings bnd in - Tactics.constructor_tac true None n bnd + Tactics.constructor_tac ev None n bnd end let () = define_prim1 "tac_symmetry" begin fun cl -> @@ -354,14 +331,10 @@ let () = define_prim1 "tac_symmetry" begin fun cl -> Tactics.intros_symmetry cl end -let () = define_prim1 "tac_split" begin fun bnd -> - let bnd = to_bindings bnd in - Tactics.split_with_bindings false [bnd] -end - -let () = define_prim1 "tac_esplit" begin fun bnd -> +let () = define_prim2 "tac_split" begin fun ev bnd -> + let ev = Value.to_bool ev in let bnd = to_bindings bnd in - Tactics.split_with_bindings true [bnd] + Tactics.split_with_bindings ev [bnd] end let () = define_prim1 "tac_rename" begin fun ids -> diff --git a/theories/Notations.v b/theories/Notations.v index ec7a6b0b12..0487e324ca 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -9,32 +9,32 @@ Require Import Ltac2.Init. Require Ltac2.Control Ltac2.Std. -Ltac2 Notation "intros" p(intropatterns) := Std.intros p. +Ltac2 Notation "intros" p(intropatterns) := Std.intros false p. -Ltac2 Notation "eintros" p(intropatterns) := Std.eintros p. +Ltac2 Notation "eintros" p(intropatterns) := Std.intros true p. Ltac2 Notation "split" bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.split bnd). + Control.with_holes bnd (fun bnd => Std.split false bnd). -Ltac2 Notation "esplit" bnd(bindings) := Std.esplit bnd. +Ltac2 Notation "esplit" bnd(bindings) := Std.split true bnd. Ltac2 Notation "left" bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.left bnd). + Control.with_holes bnd (fun bnd => Std.left false bnd). -Ltac2 Notation "eleft" bnd(bindings) := Std.eleft bnd. +Ltac2 Notation "eleft" bnd(bindings) := Std.left true bnd. Ltac2 Notation "right" bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.right bnd). + Control.with_holes bnd (fun bnd => Std.right false bnd). -Ltac2 Notation "eright" bnd(bindings) := Std.eright bnd. +Ltac2 Notation "eright" bnd(bindings) := Std.right true bnd. -Ltac2 Notation "constructor" := Std.constructor (). +Ltac2 Notation "constructor" := Std.constructor false. Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.constructor_n n bnd). + Control.with_holes bnd (fun bnd => Std.constructor_n false n bnd). -Ltac2 Notation "econstructor" := Std.econstructor (). +Ltac2 Notation "econstructor" := Std.constructor true. Ltac2 Notation "econstructor" n(tactic) bnd(bindings) := - Std.econstructor_n n bnd. + Std.constructor_n true n bnd. Ltac2 eelim c bnd use := let use := match use with @@ -42,7 +42,7 @@ Ltac2 eelim c bnd use := | Some u => let ((_, c, wth)) := u in Some (c, wth) end in - Std.eelim (c, bnd) use. + Std.elim true (c, bnd) use. Ltac2 elim c bnd use := Control.with_holes @@ -53,7 +53,7 @@ Ltac2 elim c bnd use := | Some u => let ((_, c, wth)) := u in Some (c, wth) end in - Std.elim (c, bnd) use). + Std.elim false (c, bnd) use). Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) use(thunk(opt(seq("using", constr, bindings)))) := elim c bnd use. diff --git a/theories/Std.v b/theories/Std.v index 3d0f463c5e..20504f1247 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -73,24 +73,22 @@ with or_and_intro_pattern := [ | IntroAndPattern (intro_pattern list) ]. +Ltac2 Type evar_flag := bool. + (** Standard, built-in tactics. See Ltac1 for documentation. *) -Ltac2 @ external intros : intro_pattern list -> unit := "ltac2" "tac_intros". -Ltac2 @ external eintros : intro_pattern list -> unit := "ltac2" "tac_eintros". +Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". -Ltac2 @ external elim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". -Ltac2 @ external eelim : constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_eelim". -Ltac2 @ external case : constr_with_bindings -> unit := "ltac2" "tac_case". -Ltac2 @ external ecase : constr_with_bindings -> unit := "ltac2" "tac_ecase". +Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". +Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". -Ltac2 @ external egeneralize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_egeneralize". +Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". Ltac2 @ external assert : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_assert". Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". -Ltac2 @ external set : ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_set". -Ltac2 @ external eset : ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_eset". +Ltac2 @ external set : evar_flag -> ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_set". Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". @@ -108,18 +106,13 @@ Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". -Ltac2 @ external left : bindings -> unit := "ltac2" "tac_left". -Ltac2 @ external eleft : bindings -> unit := "ltac2" "tac_eleft". -Ltac2 @ external right : bindings -> unit := "ltac2" "tac_right". -Ltac2 @ external eright : bindings -> unit := "ltac2" "tac_eright". +Ltac2 @ external left : evar_flag -> bindings -> unit := "ltac2" "tac_left". +Ltac2 @ external right : evar_flag -> bindings -> unit := "ltac2" "tac_right". -Ltac2 @ external constructor : unit -> unit := "ltac2" "tac_constructor". -Ltac2 @ external econstructor : unit -> unit := "ltac2" "tac_econstructor". -Ltac2 @ external split : bindings -> unit := "ltac2" "tac_split". -Ltac2 @ external esplit : bindings -> unit := "ltac2" "tac_esplit". +Ltac2 @ external constructor : evar_flag -> unit := "ltac2" "tac_constructor". +Ltac2 @ external split : evar_flag -> bindings -> unit := "ltac2" "tac_split". -Ltac2 @ external constructor_n : int -> bindings -> unit := "ltac2" "tac_constructorn". -Ltac2 @ external econstructor_n : int -> bindings -> unit := "ltac2" "tac_econstructorn". +Ltac2 @ external constructor_n : evar_flag -> int -> bindings -> unit := "ltac2" "tac_constructorn". Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". -- cgit v1.2.3 From dbbefa2ed1f858c1a6de77672e3e1733ef4c28bf Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 17:01:17 +0200 Subject: Code factorization in elim notation. --- theories/Notations.v | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/theories/Notations.v b/theories/Notations.v index 0487e324ca..2d7b4c8a8b 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -36,28 +36,20 @@ Ltac2 Notation "econstructor" := Std.constructor true. Ltac2 Notation "econstructor" n(tactic) bnd(bindings) := Std.constructor_n true n bnd. -Ltac2 eelim c bnd use := +Ltac2 elim0 ev c bnd use := let use := match use with | None => None | Some u => let ((_, c, wth)) := u in Some (c, wth) end in - Std.elim true (c, bnd) use. + Std.elim ev (c, bnd) use. -Ltac2 elim c bnd use := +Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) + use(thunk(opt(seq("using", constr, bindings)))) := Control.with_holes (fun () => c (), bnd (), use ()) - (fun ((c, bnd, use)) => - let use := match use with - | None => None - | Some u => - let ((_, c, wth)) := u in Some (c, wth) - end in - Std.elim false (c, bnd) use). - -Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) - use(thunk(opt(seq("using", constr, bindings)))) := elim c bnd use. + (fun ((c, bnd, use)) => elim0 false c bnd use). Ltac2 Notation "eelim" c(constr) bnd(bindings) use(opt(seq("using", constr, bindings))) := - eelim c bnd use. + elim0 true c bnd use. -- cgit v1.2.3 From d755c546a5c260232fd30971bd604b078d0afc18 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 17:31:13 +0200 Subject: Properly implementing the notation to easily access hypotheses. --- doc/ltac2.md | 8 ++++++-- src/g_ltac2.ml4 | 10 ++++++++-- src/tac2quote.ml | 24 +++++++++++++++++++++++- src/tac2quote.mli | 6 ++++++ tests/example2.v | 7 +++++++ 5 files changed, 50 insertions(+), 5 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 12687e9aff..bf6d9eb583 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -470,8 +470,12 @@ as follows. constr:(fun x : nat => ltac2:(exact (hyp @x))) ``` -The `ltac2:(exact (hyp @x))` pattern is so common that we provide dedicated -Ltac2 and Coq term notations for it. +This pattern is so common that we provide dedicated Ltac2 and Coq term notations +for it. + +- `&x` as an Ltac2 expression expands to `hyp @x`. +- `&x` as an Coq constr expression expands to + `ltac2:(refine (fun () => hyp @x))`. #### Dynamic semantics diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index f558f9b9cc..bb98ea3e5d 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -136,6 +136,7 @@ GEXTEND Gram | id = Prim.qualid -> if Tac2env.is_constructor (snd id) then CTacCst (!@loc, RelId id) else CTacRef (RelId id) | "@"; id = Prim.ident -> Tac2quote.of_ident ~loc:!@loc id + | "&"; id = Prim.ident -> Tac2quote.of_hyp ~loc:!@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_constr ~loc:!@loc c | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c @@ -381,8 +382,13 @@ END GEXTEND Gram Pcoq.Constr.operconstr: LEVEL "0" [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) ] ] + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) + | "&"; id = Prim.ident -> + let tac = Tac2quote.of_exact_hyp ~loc:!@loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) + ] ] ; END diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 0e0a7b3fce..e30acc48ab 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -17,7 +17,13 @@ open Tac2core (** Syntactic quoting of expressions. *) -let std_core n = KerName.make2 Tac2env.std_prefix (Label.of_id (Id.of_string n)) +let control_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Control"; "Ltac2"])) + +let kername prefix n = KerName.make2 prefix (Label.of_id (Id.of_string n)) +let std_core n = kername Tac2env.std_prefix n +let coq_core n = kername Tac2env.coq_prefix n +let control_core n = kername control_prefix n let dummy_loc = Loc.make_loc (-1, -1) @@ -114,3 +120,19 @@ and of_or_and_intro_pattern ?loc = function and of_intro_patterns ?loc l = of_list ?loc (List.map (of_intro_pattern ?loc) l) + +let of_hyp ?loc id = + let loc = Option.default dummy_loc loc in + let hyp = CTacRef (AbsKn (control_core "hyp")) in + CTacApp (loc, hyp, [of_ident ~loc id]) + +let thunk e = + let t_unit = coq_core "unit" in + let loc = Tac2intern.loc_of_tacexpr e in + let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other t_unit), []))] in + CTacFun (loc, var, e) + +let of_exact_hyp ?loc id = + let loc = Option.default dummy_loc loc in + let refine = CTacRef (AbsKn (control_core "refine")) in + CTacApp (loc, refine, [thunk (of_hyp ~loc id)]) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index a311430a66..4cbe854f75 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -39,3 +39,9 @@ val of_bindings : ?loc:Loc.t -> bindings -> raw_tacexpr val of_intro_pattern : ?loc:Loc.t -> intro_pattern -> raw_tacexpr val of_intro_patterns : ?loc:Loc.t -> intro_pattern list -> raw_tacexpr + +val of_hyp : ?loc:Loc.t -> Id.t -> raw_tacexpr +(** id ↦ 'Control.hyp @id' *) + +val of_exact_hyp : ?loc:Loc.t -> Id.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) diff --git a/tests/example2.v b/tests/example2.v index 398f33561e..ca9e3dcff5 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -19,3 +19,10 @@ Proof. let myvar := Std.NamedHyp @x in split with (?myvar := 0). split. Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +elim &H with 0. +split. +Qed. -- cgit v1.2.3 From 7aab63c16dc5876f314208595b4b5d9d982ec1b1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 17:53:52 +0200 Subject: Fix compilation of horrible Ltac2 example. --- tests/stuff/ltac2.v | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v index 95bff7e569..370bc70d15 100644 --- a/tests/stuff/ltac2.v +++ b/tests/stuff/ltac2.v @@ -129,7 +129,7 @@ Abort. Goal (forall n : nat, n = 0 -> False) -> True. Proof. refine (fun () => '(fun H => _)). -Std.ecase (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). +Std.case true (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). refine (fun () => 'eq_refl). Qed. @@ -138,5 +138,6 @@ Proof. refine (fun () => '(fun x => _)). Std.cbv { Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; - Std.rZeta := true; Std.rDelta := false; Std.rConst := []; + Std.rZeta := true; Std.rDelta := true; Std.rConst := []; } { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. +Abort. -- cgit v1.2.3 From 899476fa3dd2ae22f433a70fb860df0510a7ac88 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 18:02:01 +0200 Subject: Expanding documentation. --- doc/ltac2.md | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 65 insertions(+), 13 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index bf6d9eb583..20b043ea0b 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -44,7 +44,34 @@ We describe more in details each point in the remainder of this document. # ML component -The call-by-value functional language fragment is easy to implement. +## Overview + +Ltac2 is a member of the ML family of languages, in the sense that it is an +effectful call-by-value functional language, with static typing à la +Hindley-Milner. It is commonly accepted that ML constitutes a sweet spot in PL +design, as it is relatively expressive while not being either too lax +(contrarily to dynamic typing) nor too strict (contrarily to say, dependent +types). + +The main goal of Ltac2 is to serve as a meta-language for Coq. As such, it +naturally fits in the ML lineage, just as the historical ML was designed as +the tactic language for the LCF prover. It can also be seen as a general-purpose +language, by simply forgetting about the Coq-specific features. + +Sticking to a standard ML type system can be considered somewhat weak for a +meta-language designed to manipulate Coq terms. In particular, there is no +way to statically guarantee that a Coq term resulting from an Ltac2 +computation will be well-typed. This is actually a design choice, motivated +by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +dynamic checks, allowing many primitive functions to fail whenever they are +provided with an ill-typed term. + +The language is naturally effectful as it manipulates the global state of the +proof engine. This allows to think of proof-modifying primitives as effects +in a straightforward way. Semantically, proof manipulation lives in a monad, +which allows to ensure that Ltac2 satisfies the same equations as a generic ML +with unspecified effects would do, e.g. function reduction is substitution +by a value. ## Type Syntax @@ -134,7 +161,8 @@ VERNAC ::= ## Term Syntax The syntax of the functional fragment is very close to the one of Ltac1, except -that it adds a true pattern-matching feature. +that it adds a true pattern-matching feature, as well as a few standard +constructions from ML. ``` VAR := LIDENT @@ -202,11 +230,21 @@ If the `RECFLAG` is set, the tactic is expanded into a recursive binding. ## Reduction We use the usual ML call-by-value reduction, with an otherwise unspecified -evaluation order. +evaluation order. This is a design choice making it compatible with OCaml, +if ever we implement native compilation. The expected equations are as follows. +``` +(fun x => t) V ≡ t{x := V} (βv) -Note that this is already a departure from Ltac1 which uses heuristic to -decide when evaluating an expression, e.g. the following do not evaluate the -same way. +let x := V in t ≡ t{x := V} (let) + +match C V₀ ... Vₙ with ... | C x₀ ... xₙ => t | ... end ≡ t {xᵢ := Vᵢ} (ι) + +(t any term, V values, C constructor) +``` + +Note that call-by-value reduction is already a departure from Ltac1 which uses +heuristics to decide when evaluating an expression. For instance, the following +expressions do not evaluate the same way in Ltac1. ``` foo (idtac; let x := 0 in bar) @@ -229,7 +267,7 @@ current hackish subtyping semantics, and one will have to resort to conversion functions. See notations though to make things more palatable. In this setting, all usual argument-free tactics have type `unit -> unit`, but -one can return as well a value of type `τ` thanks to terms of type `unit -> τ`, +one can return as well a value of type `t` thanks to terms of type `unit -> t`, or take additional arguments. ## Effects @@ -254,6 +292,8 @@ Intuitively a thunk of type `unit -> 'a` can do the following: - It can access a backtracking proof state, made out amongst other things of the current evar assignation and the list of goals under focus. +We describe more thoroughly the various effects existing in Ltac2 hereafter. + ### Standard IO The Ltac2 language features non-backtracking IO, notably mutable data and @@ -427,13 +467,16 @@ evaluation. - Evaluation is part of the dynamic semantics, i.e. it is done when a term gets effectively computed by Ltac2. +Remark that typing of Coq terms is a *dynamic* process occuring at Ltac2 +evaluation time, and not at Ltac2 typing time. + #### Static semantics During internalization, Coq variables are resolved and antiquotations are type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq implementation terminology. Note that although it went through the -type-checking of *Ltac2*, the resulting term has not been fully computed and -is potentially ill-typed as a Coq term. +type-checking of **Ltac2**, the resulting term has not been fully computed and +is potentially ill-typed as a runtime **Coq** term. ``` Ltac2 Definition myconstr () := constr:(nat -> 0). @@ -451,7 +494,7 @@ let x := '0 in constr:(1 + ltac2:(exact x)) Beware that the typing environment of typing of antiquotations is **not** expanded by the Coq binders from the term. Namely, it means that the following -expression will **not** type-check. +Ltac2 expression will **not** type-check. ``` constr:(fun x : nat => ltac2:(exact x)) // Error: Unbound variable 'x' @@ -462,6 +505,8 @@ not make sense in general. ``` constr:(fun x : nat => ltac2:(clear @x; exact x)) ``` +Indeed, a hypothesis can suddenly disappear from the runtime context if some +other tactic pulls the rug from under you. Rather, the tactic writer has to resort to the **dynamic** goal environment, and must write instead explicitly that she is accessing a hypothesis, typically @@ -482,9 +527,9 @@ for it. During evaluation, a quoted term is fully evaluated to a kernel term, and is in particular type-checked in the current environment. -Evaluation of a quoted term is described below. -- The quoted term is evaluated by the pretyper. -- Antiquotations are evaluated in a context where there is exactly one goal +Evaluation of a quoted term goes as follows. +- The quoted term is first evaluated by the pretyper. +- Antiquotations are then evaluated in a context where there is exactly one goal under focus, with the hypotheses coming from the current environment extended with the bound variables of the term, and the resulting term is fed into the quoted term. @@ -608,3 +653,10 @@ let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids Beware that the order of evaluation of multiple let-bindings is not specified, so that you may have to resort to thunking to ensure that side-effects are performed at the right time. + +# TODO + +- Implement deep pattern-matching. +- Implement compatibility layer with Ltac1 +- Craft an expressive set of primitive functions +- Implement native compilation to OCaml -- cgit v1.2.3 From 6e150eb19a55b16bbd4ea03964ee48f2d69084ed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 18:44:03 +0200 Subject: Typo in documentation. --- doc/ltac2.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 20b043ea0b..c2d930c9b6 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -642,7 +642,7 @@ Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. ``` Then the following expression ``` -let y := @X in foo (nat -> nat) x ?y +let y := @X in foo (nat -> nat) x $y ``` will expand at parsing time to ``` -- cgit v1.2.3 From 3007909ca1f65132bd0850d2be57e781e55707bd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 18:51:19 +0200 Subject: Tentatively implementing apply. --- _CoqProject | 2 ++ src/g_ltac2.ml4 | 5 ++++- src/ltac2_plugin.mlpack | 1 + src/tac2core.ml | 8 ++++++++ src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2stdlib.ml | 12 ++++++++++++ src/tac2tactics.ml | 25 +++++++++++++++++++++++++ src/tac2tactics.mli | 18 ++++++++++++++++++ tests/example2.v | 15 +++++++++++++++ theories/Notations.v | 35 ++++++++++++++++++++++++++++++----- theories/Std.v | 4 ++++ 12 files changed, 121 insertions(+), 6 deletions(-) create mode 100644 src/tac2tactics.ml create mode 100644 src/tac2tactics.mli diff --git a/_CoqProject b/_CoqProject index 583639612b..f202e1aed2 100644 --- a/_CoqProject +++ b/_CoqProject @@ -20,6 +20,8 @@ src/tac2core.mli src/tac2qexpr.mli src/tac2quote.ml src/tac2quote.mli +src/tac2tactics.ml +src/tac2tactics.mli src/tac2stdlib.ml src/tac2stdlib.mli src/g_ltac2.ml4 diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index bb98ea3e5d..ca3631799b 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -291,7 +291,7 @@ open Tac2entries.Pltac let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram - GLOBAL: q_ident q_bindings q_intropatterns; + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns; ident_or_anti: [ [ id = Prim.ident -> QExpr id | LEFTQMARK; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) @@ -375,6 +375,9 @@ GEXTEND Gram q_intropatterns: [ [ ipat = intropatterns -> Tac2quote.of_intro_patterns ~loc:!@loc ipat ] ] ; + q_intropattern: + [ [ ipat = simple_intropattern -> Tac2quote.of_intro_pattern ~loc:!@loc ipat ] ] + ; END (** Extension of constr syntax *) diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 8d2d7dc0f4..4c4082ad65 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -6,5 +6,6 @@ Tac2entries Tac2ffi Tac2core Tac2quote +Tac2tactics Tac2stdlib G_ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml index b45275210e..329c115be3 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -883,6 +883,14 @@ let () = add_scope "bindings" begin function | _ -> scope_fail () end +let () = add_scope "intropattern" begin function +| [] -> + let scope = Extend.Aentry Tac2entries.Pltac.q_intropattern in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + let () = add_scope "intropatterns" begin function | [] -> let scope = Extend.Aentry Tac2entries.Pltac.q_intropatterns in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 0f32736096..52a5899d25 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -26,6 +26,7 @@ let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" +let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" end diff --git a/src/tac2entries.mli b/src/tac2entries.mli index e5031fdba2..2e51a4fb2e 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -59,5 +59,6 @@ val tac2expr : raw_tacexpr Pcoq.Gram.entry val q_ident : raw_tacexpr Pcoq.Gram.entry val q_bindings : raw_tacexpr Pcoq.Gram.entry +val q_intropattern : raw_tacexpr Pcoq.Gram.entry val q_intropatterns : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index f63252ec22..b678b65b82 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -12,6 +12,7 @@ open Misctypes open Genredexpr open Tac2expr open Tac2core +open Tac2tactics open Proofview.Notations module Value = Tac2ffi @@ -178,6 +179,17 @@ let () = define_prim2 "tac_intros" begin fun ev ipat -> Tactics.intros_patterns ev ipat end +let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> + let adv = Value.to_bool adv in + let ev = Value.to_bool ev in + let map_cb c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + let cb = Value.to_list map_cb cb in + let map p = Value.to_option (fun p -> Loc.tag (to_intro_pattern p)) p in + let map_ipat p = to_pair Value.to_ident map p in + let ipat = Value.to_option map_ipat ipat in + Tac2tactics.apply adv ev cb ipat +end + let () = define_prim3 "tac_elim" begin fun ev c copt -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml new file mode 100644 index 0000000000..2590d7daed --- /dev/null +++ b/src/tac2tactics.ml @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tactics.apply_with_delayed_bindings_gen adv ev cb + | Some (id, cl) -> Tactics.apply_delayed_in adv ev id cb cl diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli new file mode 100644 index 0000000000..86278f177e --- /dev/null +++ b/src/tac2tactics.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* evars_flag -> + EConstr.constr with_bindings tactic list -> + (Id.t * intro_pattern option) option -> unit tactic diff --git a/tests/example2.v b/tests/example2.v index ca9e3dcff5..fd5a9044e9 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -26,3 +26,18 @@ intros H. elim &H with 0. split. Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +Fail apply &H. +apply &H with (m := 0). +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +eapply &H. +split. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 2d7b4c8a8b..1bc48d587a 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -37,11 +37,11 @@ Ltac2 Notation "econstructor" n(tactic) bnd(bindings) := Std.constructor_n true n bnd. Ltac2 elim0 ev c bnd use := - let use := match use with - | None => None - | Some u => - let ((_, c, wth)) := u in Some (c, wth) - end in + let use := match use with + | None => None + | Some u => + let ((_, c, wth)) := u in Some (c, wth) + end in Std.elim ev (c, bnd) use. Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) @@ -53,3 +53,28 @@ Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) Ltac2 Notation "eelim" c(constr) bnd(bindings) use(opt(seq("using", constr, bindings))) := elim0 true c bnd use. + +Ltac2 apply0 adv ev cb cl := + let cl := match cl with + | None => None + | Some p => + let ((_, id, ipat)) := p in + let p := match ipat with + | None => None + | Some p => + let ((_, ipat)) := p in + Some ipat + end in + Some (id, p) + end in + Std.apply adv ev cb cl. + +Ltac2 Notation "eapply" + cb(list1(thunk(seq(constr, bindings)), ",")) + cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := + apply0 true true cb cl. + +Ltac2 Notation "apply" + cb(list1(thunk(seq(constr, bindings)), ",")) + cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := + apply0 true false cb cl. diff --git a/theories/Std.v b/theories/Std.v index 20504f1247..3d1e8f462d 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -74,11 +74,15 @@ with or_and_intro_pattern := [ ]. Ltac2 Type evar_flag := bool. +Ltac2 Type advanced_flag := bool. (** Standard, built-in tactics. See Ltac1 for documentation. *) Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". +Ltac2 @ external apply : advanced_flag -> evar_flag -> + (unit -> constr_with_bindings) list -> (ident * (intro_pattern option)) option -> unit := "ltac2" "tac_apply". + Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". -- cgit v1.2.3 From 9db02b3bfe35c15c9df8615f0e47a2a6407e858b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Aug 2017 20:37:12 +0200 Subject: Inserting enter functions in Ltac1 bindings. --- tests/example2.v | 20 ++++++++++++++ theories/Notations.v | 74 ++++++++++++++++++++++++++++++++-------------------- 2 files changed, 66 insertions(+), 28 deletions(-) diff --git a/tests/example2.v b/tests/example2.v index fd5a9044e9..79f230ab57 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -20,6 +20,13 @@ let myvar := Std.NamedHyp @x in split with (?myvar := 0). split. Qed. +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +eelim &H. +split. +Qed. + Goal (forall n : nat, n = 0 -> False) -> True. Proof. intros H. @@ -41,3 +48,16 @@ intros P H. eapply &H. split. Qed. + +Goal exists n, n = 0. +Proof. +Fail constructor 1. +constructor 1 with (x := 0). +split. +Qed. + +Goal exists n, n = 0. +Proof. +econstructor 1. +split. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 1bc48d587a..e7792c1555 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -9,49 +9,67 @@ Require Import Ltac2.Init. Require Ltac2.Control Ltac2.Std. -Ltac2 Notation "intros" p(intropatterns) := Std.intros false p. +(** Enter and check evar resolution *) +Ltac2 enter_h ev f arg := +match ev with +| true => Control.enter (fun () => f ev (arg ())) +| false => + Control.enter (fun () => + Control.with_holes arg (fun x => f ev x)) +end. -Ltac2 Notation "eintros" p(intropatterns) := Std.intros true p. +Ltac2 intros0 ev p := + Control.enter (fun () => Std.intros false p). -Ltac2 Notation "split" bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.split false bnd). +Ltac2 Notation "intros" p(intropatterns) := intros0 false p. -Ltac2 Notation "esplit" bnd(bindings) := Std.split true bnd. +Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. -Ltac2 Notation "left" bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.left false bnd). +Ltac2 split0 ev bnd := + enter_h ev Std.split bnd. -Ltac2 Notation "eleft" bnd(bindings) := Std.left true bnd. +Ltac2 Notation "split" bnd(thunk(bindings)) := split0 false bnd. -Ltac2 Notation "right" bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.right false bnd). +Ltac2 Notation "esplit" bnd(thunk(bindings)) := split0 true bnd. -Ltac2 Notation "eright" bnd(bindings) := Std.right true bnd. +Ltac2 left0 ev bnd := enter_h ev Std.left bnd. -Ltac2 Notation "constructor" := Std.constructor false. -Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := - Control.with_holes bnd (fun bnd => Std.constructor_n false n bnd). +Ltac2 Notation "left" bnd(thunk(bindings)) := left0 false bnd. -Ltac2 Notation "econstructor" := Std.constructor true. -Ltac2 Notation "econstructor" n(tactic) bnd(bindings) := - Std.constructor_n true n bnd. +Ltac2 Notation "eleft" bnd(thunk(bindings)) := left0 true bnd. + +Ltac2 right0 ev bnd := enter_h ev Std.right bnd. + +Ltac2 Notation "right" bnd(thunk(bindings)) := right0 false bnd. + +Ltac2 Notation "eright" bnd(thunk(bindings)) := right0 true bnd. + +Ltac2 constructor0 ev n bnd := + enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. + +Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). +Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := constructor0 false n bnd. + +Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). +Ltac2 Notation "econstructor" n(tactic) bnd(thunk(bindings)) := constructor0 true n bnd. Ltac2 elim0 ev c bnd use := - let use := match use with - | None => None - | Some u => - let ((_, c, wth)) := u in Some (c, wth) - end in - Std.elim ev (c, bnd) use. + let f ev ((c, bnd, use)) := + let use := match use with + | None => None + | Some u => + let ((_, c, wth)) := u in Some (c, wth) + end in + Std.elim ev (c, bnd) use + in + enter_h ev f (fun () => c (), bnd (), use ()). Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) use(thunk(opt(seq("using", constr, bindings)))) := - Control.with_holes - (fun () => c (), bnd (), use ()) - (fun ((c, bnd, use)) => elim0 false c bnd use). + elim0 false c bnd use. -Ltac2 Notation "eelim" c(constr) bnd(bindings) - use(opt(seq("using", constr, bindings))) := +Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(bindings)) + use(thunk(opt(seq("using", constr, bindings)))) := elim0 true c bnd use. Ltac2 apply0 adv ev cb cl := -- cgit v1.2.3 From b84b03bb6230fca69cd9191ba0424402a5cd2330 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Aug 2017 20:23:08 +0200 Subject: Introducing notations for destruct and induction arguments. --- src/g_ltac2.ml4 | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++-- src/tac2core.ml | 8 ++++ src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 23 ++++++++++++ src/tac2quote.ml | 79 ++++++++++++++++++++++++++++++++++++--- src/tac2quote.mli | 2 + tests/example2.v | 2 +- theories/Std.v | 13 +++++++ 9 files changed, 223 insertions(+), 11 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index ca3631799b..8c7db71a47 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -30,7 +30,7 @@ let test_lpar_idnum_coloneq = (match stream_nth 2 strm with | KEYWORD ":=" -> () | _ -> err ()) - | LEFTQMARK -> + | KEYWORD "$" -> (match stream_nth 2 strm with | IDENT _ -> (match stream_nth 3 strm with @@ -40,6 +40,20 @@ let test_lpar_idnum_coloneq = | _ -> err ()) | _ -> err ()) +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ -> + (match stream_nth 2 strm with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + let tac2expr = Tac2entries.Pltac.tac2expr let tac2type = Gram.entry_create "tactic:tac2type" let tac2def_val = Gram.entry_create "tactic:tac2def_val" @@ -291,17 +305,17 @@ open Tac2entries.Pltac let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram - GLOBAL: q_ident q_bindings q_intropattern q_intropatterns; + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause; ident_or_anti: [ [ id = Prim.ident -> QExpr id - | LEFTQMARK; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; q_ident: [ [ id = ident_or_anti -> Tac2quote.of_anti ~loc:!@loc Tac2quote.of_ident id ] ] ; simple_binding: - [ [ "("; LEFTQMARK; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> + [ [ "("; "$"; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), Tac2quote.of_open_constr ~loc:!@loc c) | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> Loc.tag ~loc:!@loc (QExpr (AnonHyp n), Tac2quote.of_open_constr ~loc:!@loc c) @@ -378,6 +392,89 @@ GEXTEND Gram q_intropattern: [ [ ipat = simple_intropattern -> Tac2quote.of_intro_pattern ~loc:!@loc ipat ] ] ; + nat_or_anti: + [ [ n = Prim.natural -> QExpr n + | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some pat + | -> None + ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> bl | -> QNoBindings ] ] + ; + constr_with_bindings: + [ [ c = Constr.constr; l = with_bindings -> (c, l) ] ] + ; + destruction_arg: + [ [ n = Prim.natural -> QElimOnAnonHyp n + | (c, bnd) = constr_with_bindings -> QElimOnConstr (c, bnd) + ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern -> Some ipat + | -> None + ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_anti -> QOnlyOccurrences nl + | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> + QAllOccurrencesBut (n::nl) + ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> occs | -> QAllOccurrences ] ] + ; + hypident: + [ [ id = ident_or_anti -> + id,Locus.InHyp + | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> + id,Locus.InHypTypeOnly + | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> + id,Locus.InHypValueOnly + ] ] + ; + hypident_occ: + [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + { q_onhyps = None; q_concl_occs = occs } + | "*"; "|-"; occs = concl_occ -> + { q_onhyps = None; q_concl_occs = occs } + | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> + { q_onhyps = Some hl; q_concl_occs = occs } + | hl = LIST0 hypident_occ SEP "," -> + { q_onhyps = Some hl; q_concl_occs = QNoOccurrences } + ] ] + ; + opt_clause: + [ [ "in"; cl = in_clause -> Some cl + | "at"; occs = occs_nums -> Some { q_onhyps = Some []; q_concl_occs = occs } + | -> None + ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> occs + | -> QNoOccurrences + ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = opt_clause -> + { + indcl_arg = c; + indcl_eqn = eq; + indcl_as = pat; + indcl_in = cl; + } + ] ] + ; + q_induction_clause: + [ [ cl = induction_clause -> Tac2quote.of_induction_clause ~loc:!@loc cl ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 329c115be3..45fa52ff9b 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -899,6 +899,14 @@ let () = add_scope "intropatterns" begin function | _ -> scope_fail () end +let () = add_scope "induction_clause" begin function +| [] -> + let scope = Extend.Aentry Tac2entries.Pltac.q_induction_clause in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| _ -> scope_fail () +end + let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 52a5899d25..ce86e8aa33 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -28,6 +28,7 @@ let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" +let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 2e51a4fb2e..1567551246 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -61,4 +61,5 @@ val q_ident : raw_tacexpr Pcoq.Gram.entry val q_bindings : raw_tacexpr Pcoq.Gram.entry val q_intropattern : raw_tacexpr Pcoq.Gram.entry val q_intropatterns : raw_tacexpr Pcoq.Gram.entry +val q_induction_clause : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index b68efe73ac..5075f2d7d4 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -40,3 +40,26 @@ and intro_pattern_action = and or_and_intro_pattern = | QIntroOrPattern of intro_pattern list list | QIntroAndPattern of intro_pattern list + +type occurrences = +| QAllOccurrences +| QAllOccurrencesBut of int or_anti list +| QNoOccurrences +| QOnlyOccurrences of int or_anti list + +type hyp_location = (occurrences * Id.t or_anti) * Locus.hyp_location_flag + +type clause = + { q_onhyps : hyp_location list option; q_concl_occs : occurrences; } + +type destruction_arg = +| QElimOnConstr of Constrexpr.constr_expr * bindings +| QElimOnIdent of Id.t +| QElimOnAnonHyp of int + +type induction_clause = { + indcl_arg : destruction_arg; + indcl_eqn : intro_pattern_naming option; + indcl_as : or_and_intro_pattern option; + indcl_in : clause option; +} diff --git a/src/tac2quote.ml b/src/tac2quote.ml index e30acc48ab..9858f611fe 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -36,13 +36,31 @@ let constructor ?loc kn args = let std_constructor ?loc name args = constructor ?loc (std_core name) args +let std_proj ?loc name = + AbsKn (std_core name) + +let thunk e = + let t_unit = coq_core "unit" in + let loc = Tac2intern.loc_of_tacexpr e in + let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other t_unit), []))] in + CTacFun (loc, var, e) + let of_pair ?loc (e1, e2) = let loc = Option.default dummy_loc loc in CTacApp (loc, CTacCst (loc, AbsKn (Tuple 2)), [e1; e2]) +let of_tuple ?loc el = + let loc = Option.default dummy_loc loc in + let len = List.length el in + CTacApp (loc, CTacCst (loc, AbsKn (Tuple len)), el) + let of_int ?loc n = CTacAtm (Loc.tag ?loc (AtmInt n)) +let of_option ?loc opt = match opt with +| None -> constructor ?loc (coq_core "None") [] +| Some e -> constructor ?loc (coq_core "Some") [e] + let inj_wit ?loc wit x = let loc = Option.default dummy_loc loc in CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) @@ -121,17 +139,66 @@ and of_or_and_intro_pattern ?loc = function and of_intro_patterns ?loc l = of_list ?loc (List.map (of_intro_pattern ?loc) l) +let of_hyp_location_flag ?loc = function +| Locus.InHyp -> std_constructor ?loc "InHyp" [] +| Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] +| Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] + +let of_occurrences ?loc occ = match occ with +| QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] +| QAllOccurrencesBut occs -> + let map occ = of_anti ?loc of_int occ in + let occs = of_list ?loc (List.map map occs) in + std_constructor ?loc "AllOccurrencesBut" [occs] +| QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] +| QOnlyOccurrences occs -> + let map occ = of_anti ?loc of_int occ in + let occs = of_list ?loc (List.map map occs) in + std_constructor ?loc "OnlyOccurrences" [occs] + +let of_hyp_location ?loc ((occs, id), flag) = + of_tuple ?loc [ + of_anti ?loc of_ident id; + of_occurrences ?loc occs; + of_hyp_location_flag ?loc flag; + ] + +let of_clause ?loc cl = + let loc = Option.default dummy_loc loc in + let hyps = of_option ~loc (Option.map (fun l -> of_list ~loc (List.map of_hyp_location l)) cl.q_onhyps) in + let concl = of_occurrences ~loc cl.q_concl_occs in + CTacRec (loc, [ + std_proj "on_hyps", hyps; + std_proj "on_concl", concl; + ]) + +let of_destruction_arg ?loc = function +| QElimOnConstr (c, bnd) -> + let c = of_constr ?loc c in + let bnd = of_bindings ?loc bnd in + let arg = thunk (of_pair ?loc (c, bnd)) in + std_constructor ?loc "ElimOnConstr" [arg] +| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident ?loc id] +| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int ?loc n] + +let of_induction_clause ?loc cl = + let arg = of_destruction_arg ?loc cl.indcl_arg in + let eqn = of_option ?loc (Option.map of_intro_pattern_naming cl.indcl_eqn) in + let as_ = of_option ?loc (Option.map of_or_and_intro_pattern cl.indcl_as) in + let in_ = of_option ?loc (Option.map of_clause cl.indcl_in) in + let loc = Option.default dummy_loc loc in + CTacRec (loc, [ + std_proj "indcl_arg", arg; + std_proj "indcl_eqn", eqn; + std_proj "indcl_as", as_; + std_proj "indcl_in", in_; + ]) + let of_hyp ?loc id = let loc = Option.default dummy_loc loc in let hyp = CTacRef (AbsKn (control_core "hyp")) in CTacApp (loc, hyp, [of_ident ~loc id]) -let thunk e = - let t_unit = coq_core "unit" in - let loc = Tac2intern.loc_of_tacexpr e in - let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other t_unit), []))] in - CTacFun (loc, var, e) - let of_exact_hyp ?loc id = let loc = Option.default dummy_loc loc in let refine = CTacRef (AbsKn (control_core "refine")) in diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 4cbe854f75..40ea58e334 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -40,6 +40,8 @@ val of_intro_pattern : ?loc:Loc.t -> intro_pattern -> raw_tacexpr val of_intro_patterns : ?loc:Loc.t -> intro_pattern list -> raw_tacexpr +val of_induction_clause : ?loc:Loc.t -> induction_clause -> raw_tacexpr + val of_hyp : ?loc:Loc.t -> Id.t -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) diff --git a/tests/example2.v b/tests/example2.v index 79f230ab57..d89dcfd450 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -16,7 +16,7 @@ Qed. Goal exists n, n = 0. Proof. -let myvar := Std.NamedHyp @x in split with (?myvar := 0). +let myvar := Std.NamedHyp @x in split with ($myvar := 0). split. Qed. diff --git a/theories/Std.v b/theories/Std.v index 3d1e8f462d..c2027e41c7 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -73,6 +73,19 @@ with or_and_intro_pattern := [ | IntroAndPattern (intro_pattern list) ]. +Ltac2 Type destruction_arg := [ +| ElimOnConstr (unit -> constr_with_bindings) +| ElimOnIdent (ident) +| ElimOnAnonHyp (int) +]. + +Ltac2 Type induction_clause := { + indcl_arg : destruction_arg; + indcl_eqn : intro_pattern_naming option; + indcl_as : or_and_intro_pattern option; + indcl_in : clause option; +}. + Ltac2 Type evar_flag := bool. Ltac2 Type advanced_flag := bool. -- cgit v1.2.3 From fce4a1a9cbb57a636155181898ae4ecece5af59d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Aug 2017 13:04:10 +0200 Subject: Adding the induction and destruct tactics. --- src/tac2stdlib.ml | 41 ++++++++++++++++++++++++++++++++++++----- src/tac2tactics.ml | 21 +++++++++++++++++++++ src/tac2tactics.mli | 9 +++++++++ tests/example2.v | 34 ++++++++++++++++++++++++++++++++++ theories/Notations.v | 42 ++++++++++++++++++++++++++++++++++++++++++ theories/Std.v | 6 ++++++ 6 files changed, 148 insertions(+), 5 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index b678b65b82..7e421c8577 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -17,6 +17,10 @@ open Proofview.Notations module Value = Tac2ffi +let return x = Proofview.tclUNIT x +let v_unit = Value.of_unit () +let thaw f = Tac2interp.interp_app f [v_unit] + let to_pair f g = function | ValBlk (0, [| x; y |]) -> (f x, g y) | _ -> assert false @@ -119,13 +123,28 @@ and to_intro_patterns il = let map ipat = Loc.tag (to_intro_pattern ipat) in Value.to_list map il +let to_destruction_arg = function +| ValBlk (0, [| c |]) -> + let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + ElimOnConstr c +| ValBlk (1, [| id |]) -> ElimOnIdent (Loc.tag (Value.to_ident id)) +| ValBlk (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) +| _ -> assert false + +let to_induction_clause = function +| ValBlk (0, [| arg; eqn; as_; in_ |]) -> + let arg = to_destruction_arg arg in + let eqn = Value.to_option (fun p -> Loc.tag (to_intro_pattern_naming p)) eqn in + let as_ = Value.to_option (fun p -> Loc.tag (to_or_and_intro_pattern p)) as_ in + let in_ = Value.to_option to_clause in_ in + ((None, arg), eqn, as_, in_) +| _ -> + assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } -let return x = Proofview.tclUNIT x -let v_unit = Value.of_unit () - let lift tac = tac <*> return v_unit let wrap f = @@ -134,8 +153,6 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit -let thaw f = Tac2interp.interp_app f [v_unit] - let define_prim0 name tac = let tac = function | [_] -> lift tac @@ -245,6 +262,20 @@ let () = define_prim4 "tac_set" begin fun ev idopt c cl -> Tactics.letin_pat_tac ev None na (sigma, c) cl end +let () = define_prim3 "tac_destruct" begin fun ev ic using -> + let ev = Value.to_bool ev in + let ic = Value.to_list to_induction_clause ic in + let using = Value.to_option to_constr_with_bindings using in + Tac2tactics.induction_destruct false ev ic using +end + +let () = define_prim3 "tac_induction" begin fun ev ic using -> + let ev = Value.to_bool ev in + let ic = Value.to_list to_induction_clause ic in + let using = Value.to_option to_constr_with_bindings using in + Tac2tactics.induction_destruct true ev ic using +end + let () = define_prim1 "tac_red" begin fun cl -> let cl = to_clause cl in Tactics.reduce (Red false) cl diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 2590d7daed..439250db78 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -6,7 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Misctypes +open Tactypes open Tactics +open Proofview open Tacmach.New open Tacticals.New open Proofview.Notations @@ -23,3 +26,21 @@ let apply adv ev cb cl = match cl with | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb | Some (id, cl) -> Tactics.apply_delayed_in adv ev id cb cl + +type induction_clause = + EConstr.constr with_bindings tactic destruction_arg * + intro_pattern_naming option * + or_and_intro_pattern option * + Locus.clause option + +let map_destruction_arg = function +| ElimOnConstr c -> ElimOnConstr (delayed_of_tactic c) +| ElimOnIdent id -> ElimOnIdent id +| ElimOnAnonHyp n -> ElimOnAnonHyp n + +let map_induction_clause ((clear, arg), eqn, as_, occ) = + ((clear, map_destruction_arg arg), (eqn, as_), occ) + +let induction_destruct isrec ev ic using = + let ic = List.map map_induction_clause ic in + Tactics.induction_destruct isrec ev (ic, using) diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 86278f177e..f29793411a 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -16,3 +16,12 @@ open Proofview val apply : advanced_flag -> evars_flag -> EConstr.constr with_bindings tactic list -> (Id.t * intro_pattern option) option -> unit tactic + +type induction_clause = + EConstr.constr with_bindings tactic destruction_arg * + intro_pattern_naming option * + or_and_intro_pattern option * + Locus.clause option + +val induction_destruct : rec_flag -> evars_flag -> + induction_clause list -> EConstr.constr with_bindings option -> unit Proofview.tactic diff --git a/tests/example2.v b/tests/example2.v index d89dcfd450..812f9172c9 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -61,3 +61,37 @@ Proof. econstructor 1. split. Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +induction &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +induction &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +destruct &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +destruct &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall b1 b2, andb b1 b2 = andb b2 b1. +Proof. +intros b1 b2. +destruct &b1 as [|], &b2 as [|]; split. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index e7792c1555..20f01c3b48 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -96,3 +96,45 @@ Ltac2 Notation "apply" cb(list1(thunk(seq(constr, bindings)), ",")) cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := apply0 true false cb cl. + +Ltac2 induction0 ev ic use := + let f ev use := + let use := match use with + | None => None + | Some u => + let ((_, c, wth)) := u in Some (c, wth) + end in + Std.induction ev ic use + in + enter_h ev f use. + +Ltac2 Notation "induction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, bindings)))) := + induction0 false ic use. + +Ltac2 Notation "einduction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, bindings)))) := + induction0 true ic use. + +Ltac2 destruct0 ev ic use := + let f ev use := + let use := match use with + | None => None + | Some u => + let ((_, c, wth)) := u in Some (c, wth) + end in + Std.destruct ev ic use + in + enter_h ev f use. + +Ltac2 Notation "destruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, bindings)))) := + destruct0 false ic use. + +Ltac2 Notation "edestruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, bindings)))) := + destruct0 true ic use. diff --git a/theories/Std.v b/theories/Std.v index c2027e41c7..19bdc4c82a 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -107,6 +107,12 @@ Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_patter Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". Ltac2 @ external set : evar_flag -> ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_set". +Ltac2 @ external destruct : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external induction : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". -- cgit v1.2.3 From 2e01ea9e1ab0f9e8d90dd4e4ac598bc1691b9272 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Aug 2017 15:48:07 +0200 Subject: More precise type for quoted structures. --- src/g_ltac2.ml4 | 7 +++---- src/tac2qexpr.mli | 4 ++-- src/tac2quote.ml | 6 ++++-- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 8c7db71a47..bfef4fab8d 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -316,18 +316,17 @@ GEXTEND Gram ; simple_binding: [ [ "("; "$"; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), Tac2quote.of_open_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), c) | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QExpr (AnonHyp n), Tac2quote.of_open_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QExpr (AnonHyp n), c) | "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QExpr (NamedHyp id), Tac2quote.of_open_constr ~loc:!@loc c) + Loc.tag ~loc:!@loc (QExpr (NamedHyp id), c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> QExplicitBindings bl | bl = LIST1 Constr.constr -> - let bl = List.map (fun c -> Tac2quote.of_open_constr ~loc:!@loc c) bl in QImplicitBindings bl ] ] ; diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 5075f2d7d4..8a61590a1d 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -19,8 +19,8 @@ type 'a or_anti = | QAnti of Id.t located type bindings = -| QImplicitBindings of raw_tacexpr list -| QExplicitBindings of (Misctypes.quantified_hypothesis or_anti * raw_tacexpr) Loc.located list +| QImplicitBindings of Constrexpr.constr_expr list +| QExplicitBindings of (Misctypes.quantified_hypothesis or_anti * Constrexpr.constr_expr) Loc.located list | QNoBindings type intro_pattern = diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 9858f611fe..a053bd799f 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -98,9 +98,11 @@ let of_bindings ?loc = function | QNoBindings -> std_constructor ?loc "NoBindings" [] | QImplicitBindings tl -> + let tl = List.map (fun c -> of_open_constr ?loc c) tl in std_constructor ?loc "ImplicitBindings" [of_list ?loc tl] | QExplicitBindings tl -> - let tl = List.map (fun (loc, (qhyp, e)) -> of_pair ?loc (of_anti ?loc of_qhyp qhyp, e)) tl in + let map (loc, (qhyp, e)) = of_pair ?loc (of_anti ?loc of_qhyp qhyp, of_open_constr ?loc e) in + let tl = List.map map tl in std_constructor ?loc "ExplicitBindings" [of_list ?loc tl] let rec of_intro_pattern ?loc = function @@ -174,7 +176,7 @@ let of_clause ?loc cl = let of_destruction_arg ?loc = function | QElimOnConstr (c, bnd) -> - let c = of_constr ?loc c in + let c = of_open_constr ?loc c in let bnd = of_bindings ?loc bnd in let arg = thunk (of_pair ?loc (c, bnd)) in std_constructor ?loc "ElimOnConstr" [arg] -- cgit v1.2.3 From 8bf0f3383fcde637ed9363f080d875a9ef0a138f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Aug 2017 15:52:37 +0200 Subject: Adding locations to quotation types. --- src/g_ltac2.ml4 | 125 +++++++++++++++++++++++++++++++++--------------------- src/tac2qexpr.mli | 49 +++++++++++++-------- src/tac2quote.ml | 66 ++++++++++++++-------------- src/tac2quote.mli | 25 +++++------ 4 files changed, 156 insertions(+), 109 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index bfef4fab8d..b10f8d66bd 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -149,12 +149,12 @@ GEXTEND Gram | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) | id = Prim.qualid -> if Tac2env.is_constructor (snd id) then CTacCst (!@loc, RelId id) else CTacRef (RelId id) - | "@"; id = Prim.ident -> Tac2quote.of_ident ~loc:!@loc id - | "&"; id = Prim.ident -> Tac2quote.of_hyp ~loc:!@loc id + | "@"; id = Prim.ident -> Tac2quote.of_ident (Loc.tag ~loc:!@loc id) + | "&"; id = lident -> Tac2quote.of_hyp ~loc:!@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_constr ~loc:!@loc c - | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> inj_open_constr !@loc c - | IDENT "ident"; ":"; "("; c = Prim.ident; ")" -> Tac2quote.of_ident ~loc:!@loc c + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_constr c + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_open_constr c + | IDENT "ident"; ":"; "("; c = lident; ")" -> Tac2quote.of_ident c | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> inj_pattern !@loc c ] ] ; @@ -296,6 +296,9 @@ GEXTEND Gram StrSyn (toks, n, e) ] ] ; + lident: + [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] + ; END (** Quotation scopes used by notations *) @@ -306,71 +309,92 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause; + anti: + [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] + ; ident_or_anti: - [ [ id = Prim.ident -> QExpr id + [ [ id = lident -> QExpr id | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; + lident: + [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] + ; + lnatural: + [ [ n = Prim.natural -> Loc.tag ~loc:!@loc n ] ] + ; q_ident: [ [ id = ident_or_anti -> Tac2quote.of_anti ~loc:!@loc Tac2quote.of_ident id ] ] ; + qhyp: + [ [ x = anti -> x + | n = lnatural -> QExpr (Loc.tag ~loc:!@loc @@ QAnonHyp n) + | id = lident -> QExpr (Loc.tag ~loc:!@loc @@ QNamedHyp id) + ] ] + ; simple_binding: - [ [ "("; "$"; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QAnti (Loc.tag ~loc:!@loc id), c) - | "("; n = Prim.natural; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QExpr (AnonHyp n), c) - | "("; id = Prim.ident; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QExpr (NamedHyp id), c) + [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (h, c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - QExplicitBindings bl + Loc.tag ~loc:!@loc @@ QExplicitBindings bl | bl = LIST1 Constr.constr -> - QImplicitBindings bl + Loc.tag ~loc:!@loc @@ QImplicitBindings bl ] ] ; q_bindings: - [ [ "with"; bl = bindings -> Tac2quote.of_bindings ~loc:!@loc bl - | -> Tac2quote.of_bindings ~loc:!@loc QNoBindings - ] ] + [ [ bl = with_bindings -> Tac2quote.of_bindings bl ] ] ; intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> l ]] + [ [ l = LIST0 nonsimple_intropattern -> Loc.tag ~loc:!@loc l ]] ; (* ne_intropatterns: *) (* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) (* ; *) or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> QIntroOrPattern tc - | "()" -> QIntroAndPattern [] - | "("; si = simple_intropattern; ")" -> QIntroAndPattern [si] + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> Loc.tag ~loc:!@loc @@ QIntroOrPattern tc + | "()" -> Loc.tag ~loc:!@loc @@ QIntroAndPattern (Loc.tag ~loc:!@loc []) + | "("; si = simple_intropattern; ")" -> Loc.tag ~loc:!@loc @@ QIntroAndPattern (Loc.tag ~loc:!@loc [si]) | "("; si = simple_intropattern; ","; tc = LIST1 simple_intropattern SEP "," ; ")" -> - QIntroAndPattern (si::tc) + Loc.tag ~loc:!@loc @@ QIntroAndPattern (Loc.tag ~loc:!@loc (si::tc)) | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function - | ([]|[_]|[_;_]) as l -> l - | t::q -> [t; (QIntroAction (QIntroOrAndPattern (QIntroAndPattern (pairify q))))] - in QIntroAndPattern (pairify (si::tc)) ] ] + | ([]|[_]|[_;_]) as l -> Loc.tag ~loc:!@loc l + | t::q -> + let q = + Loc.tag ~loc:!@loc @@ + QIntroAction (Loc.tag ~loc:!@loc @@ + QIntroOrAndPattern (Loc.tag ~loc:!@loc @@ + QIntroAndPattern (pairify q))) + in + Loc.tag ~loc:!@loc [t; q] + in Loc.tag ~loc:!@loc @@ QIntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: - [ [ "->" -> QIntroRewrite true - | "<-" -> QIntroRewrite false - | "[="; tc = intropatterns; "]" -> QIntroInjection tc ] ] + [ [ "->" -> Loc.tag ~loc:!@loc @@ QIntroRewrite true + | "<-" -> Loc.tag ~loc:!@loc @@ QIntroRewrite false + | "[="; tc = intropatterns; "]" -> Loc.tag ~loc:!@loc @@ QIntroInjection tc ] ] ; naming_intropattern: - [ [ LEFTQMARK; id = Prim.ident -> QIntroFresh (QExpr id) - | "?$"; id = Prim.ident -> QIntroFresh (QAnti (Loc.tag ~loc:!@loc id)) - | "?" -> QIntroAnonymous - | id = ident_or_anti -> QIntroIdentifier id ] ] + [ [ LEFTQMARK; id = lident -> + Loc.tag ~loc:!@loc @@ QIntroFresh (QExpr id) + | "?$"; id = lident -> + Loc.tag ~loc:!@loc @@ QIntroFresh (QAnti id) + | "?" -> + Loc.tag ~loc:!@loc @@ QIntroAnonymous + | id = ident_or_anti -> + Loc.tag ~loc:!@loc @@ QIntroIdentifier id + ] ] ; nonsimple_intropattern: [ [ l = simple_intropattern -> l - | "*" -> QIntroForthcoming true - | "**" -> QIntroForthcoming false ]] + | "*" -> Loc.tag ~loc:!@loc @@ QIntroForthcoming true + | "**" -> Loc.tag ~loc:!@loc @@ QIntroForthcoming false ]] ; simple_intropattern: [ [ pat = simple_intropattern_closed -> @@ -380,19 +404,24 @@ GEXTEND Gram ] ] ; simple_intropattern_closed: - [ [ pat = or_and_intropattern -> QIntroAction (QIntroOrAndPattern pat) - | pat = equality_intropattern -> QIntroAction pat - | "_" -> QIntroAction QIntroWildcard - | pat = naming_intropattern -> QIntroNaming pat ] ] + [ [ pat = or_and_intropattern -> + Loc.tag ~loc:!@loc @@ QIntroAction (Loc.tag ~loc:!@loc @@ QIntroOrAndPattern pat) + | pat = equality_intropattern -> + Loc.tag ~loc:!@loc @@ QIntroAction pat + | "_" -> + Loc.tag ~loc:!@loc @@ QIntroAction (Loc.tag ~loc:!@loc @@ QIntroWildcard) + | pat = naming_intropattern -> + Loc.tag ~loc:!@loc @@ QIntroNaming pat + ] ] ; q_intropatterns: - [ [ ipat = intropatterns -> Tac2quote.of_intro_patterns ~loc:!@loc ipat ] ] + [ [ ipat = intropatterns -> Tac2quote.of_intro_patterns ipat ] ] ; q_intropattern: - [ [ ipat = simple_intropattern -> Tac2quote.of_intro_pattern ~loc:!@loc ipat ] ] + [ [ ipat = simple_intropattern -> Tac2quote.of_intro_pattern ipat ] ] ; nat_or_anti: - [ [ n = Prim.natural -> QExpr n + [ [ n = lnatural -> QExpr n | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -402,14 +431,14 @@ GEXTEND Gram ] ] ; with_bindings: - [ [ "with"; bl = bindings -> bl | -> QNoBindings ] ] + [ [ "with"; bl = bindings -> bl | -> Loc.tag ~loc:!@loc @@ QNoBindings ] ] ; constr_with_bindings: - [ [ c = Constr.constr; l = with_bindings -> (c, l) ] ] + [ [ c = Constr.constr; l = with_bindings -> Loc.tag ~loc:!@loc @@ (c, l) ] ] ; destruction_arg: - [ [ n = Prim.natural -> QElimOnAnonHyp n - | (c, bnd) = constr_with_bindings -> QElimOnConstr (c, bnd) + [ [ n = lnatural -> QElimOnAnonHyp n + | c = constr_with_bindings -> QElimOnConstr c ] ] ; as_or_and_ipat: @@ -463,7 +492,7 @@ GEXTEND Gram induction_clause: [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; cl = opt_clause -> - { + Loc.tag ~loc:!@loc @@ { indcl_arg = c; indcl_eqn = eq; indcl_as = pat; @@ -472,7 +501,7 @@ GEXTEND Gram ] ] ; q_induction_clause: - [ [ cl = induction_clause -> Tac2quote.of_induction_clause ~loc:!@loc cl ] ] + [ [ cl = induction_clause -> Tac2quote.of_induction_clause cl ] ] ; END @@ -483,7 +512,7 @@ GEXTEND Gram [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) - | "&"; id = Prim.ident -> + | "&"; id = [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] -> let tac = Tac2quote.of_exact_hyp ~loc:!@loc id in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 8a61590a1d..0eb9e9f4b5 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -18,48 +18,61 @@ type 'a or_anti = | QExpr of 'a | QAnti of Id.t located -type bindings = +type quantified_hypothesis = +| QAnonHyp of int located +| QNamedHyp of Id.t located + +type bindings_r = | QImplicitBindings of Constrexpr.constr_expr list -| QExplicitBindings of (Misctypes.quantified_hypothesis or_anti * Constrexpr.constr_expr) Loc.located list +| QExplicitBindings of (quantified_hypothesis located or_anti * Constrexpr.constr_expr) located list | QNoBindings -type intro_pattern = +type bindings = bindings_r located + +type intro_pattern_r = | QIntroForthcoming of bool | QIntroNaming of intro_pattern_naming | QIntroAction of intro_pattern_action -and intro_pattern_naming = -| QIntroIdentifier of Id.t or_anti -| QIntroFresh of Id.t or_anti +and intro_pattern_naming_r = +| QIntroIdentifier of Id.t located or_anti +| QIntroFresh of Id.t located or_anti | QIntroAnonymous -and intro_pattern_action = +and intro_pattern_action_r = | QIntroWildcard | QIntroOrAndPattern of or_and_intro_pattern -| QIntroInjection of intro_pattern list +| QIntroInjection of intro_pattern list located (* | QIntroApplyOn of Empty.t (** Not implemented yet *) *) | QIntroRewrite of bool -and or_and_intro_pattern = -| QIntroOrPattern of intro_pattern list list -| QIntroAndPattern of intro_pattern list +and or_and_intro_pattern_r = +| QIntroOrPattern of intro_pattern list located list +| QIntroAndPattern of intro_pattern list located + +and intro_pattern = intro_pattern_r located +and intro_pattern_naming = intro_pattern_naming_r located +and intro_pattern_action = intro_pattern_action_r located +and or_and_intro_pattern = or_and_intro_pattern_r located type occurrences = | QAllOccurrences -| QAllOccurrencesBut of int or_anti list +| QAllOccurrencesBut of int located or_anti list | QNoOccurrences -| QOnlyOccurrences of int or_anti list +| QOnlyOccurrences of int located or_anti list -type hyp_location = (occurrences * Id.t or_anti) * Locus.hyp_location_flag +type hyp_location = (occurrences * Id.t located or_anti) * Locus.hyp_location_flag type clause = { q_onhyps : hyp_location list option; q_concl_occs : occurrences; } type destruction_arg = -| QElimOnConstr of Constrexpr.constr_expr * bindings -| QElimOnIdent of Id.t -| QElimOnAnonHyp of int +| QElimOnConstr of (Constrexpr.constr_expr * bindings) located +| QElimOnIdent of Id.t located +| QElimOnAnonHyp of int located -type induction_clause = { +type induction_clause_r = { indcl_arg : destruction_arg; indcl_eqn : intro_pattern_naming option; indcl_as : or_and_intro_pattern option; indcl_in : clause option; } + +type induction_clause = induction_clause_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index a053bd799f..1cba488768 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -54,7 +54,7 @@ let of_tuple ?loc el = let len = List.length el in CTacApp (loc, CTacCst (loc, AbsKn (Tuple len)), el) -let of_int ?loc n = +let of_int (loc, n) = CTacAtm (Loc.tag ?loc (AtmInt n)) let of_option ?loc opt = match opt with @@ -65,21 +65,25 @@ let inj_wit ?loc wit x = let loc = Option.default dummy_loc loc in CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) -let of_variable ?loc id = +let of_variable (loc, id) = let qid = Libnames.qualid_of_ident id in if Tac2env.is_constructor qid then CErrors.user_err ?loc (str "Invalid identifier") else CTacRef (RelId (Loc.tag ?loc qid)) let of_anti ?loc f = function -| QExpr x -> f ?loc x -| QAnti (loc, id) -> of_variable ?loc id +| QExpr x -> f x +| QAnti id -> of_variable id -let of_ident ?loc id = inj_wit ?loc Stdarg.wit_ident id +let of_ident (loc, id) = inj_wit ?loc Stdarg.wit_ident id -let of_constr ?loc c = inj_wit ?loc Stdarg.wit_constr c +let of_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc Stdarg.wit_constr c -let of_open_constr ?loc c = inj_wit ?loc Stdarg.wit_open_constr c +let of_open_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc Stdarg.wit_open_constr c let of_bool ?loc b = let c = if b then Core.c_true else Core.c_false in @@ -90,22 +94,22 @@ let rec of_list ?loc = function | e :: l -> constructor ?loc Core.c_cons [e; of_list ?loc l] -let of_qhyp ?loc = function -| AnonHyp n -> constructor Core.c_anon_hyp [of_int ?loc n] -| NamedHyp id -> constructor Core.c_named_hyp [of_ident ?loc id] +let of_qhyp (loc, h) = match h with +| QAnonHyp n -> constructor ?loc Core.c_anon_hyp [of_int n] +| QNamedHyp id -> constructor ?loc Core.c_named_hyp [of_ident id] -let of_bindings ?loc = function +let of_bindings (loc, b) = match b with | QNoBindings -> std_constructor ?loc "NoBindings" [] | QImplicitBindings tl -> - let tl = List.map (fun c -> of_open_constr ?loc c) tl in + let tl = List.map of_open_constr tl in std_constructor ?loc "ImplicitBindings" [of_list ?loc tl] | QExplicitBindings tl -> - let map (loc, (qhyp, e)) = of_pair ?loc (of_anti ?loc of_qhyp qhyp, of_open_constr ?loc e) in + let map (loc, (qhyp, e)) = of_pair ?loc (of_anti ?loc of_qhyp qhyp, of_open_constr e) in let tl = List.map map tl in std_constructor ?loc "ExplicitBindings" [of_list ?loc tl] -let rec of_intro_pattern ?loc = function +let rec of_intro_pattern (loc, pat) = match pat with | QIntroForthcoming b -> std_constructor ?loc "IntroForthcoming" [of_bool b] | QIntroNaming iname -> @@ -113,33 +117,33 @@ let rec of_intro_pattern ?loc = function | QIntroAction iact -> std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] -and of_intro_pattern_naming ?loc = function +and of_intro_pattern_naming (loc, pat) = match pat with | QIntroIdentifier id -> - std_constructor ?loc "IntroIdentifier" [of_anti ?loc of_ident id] + std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] | QIntroFresh id -> std_constructor ?loc "IntroFresh" [of_anti ?loc of_ident id] | QIntroAnonymous -> std_constructor ?loc "IntroAnonymous" [] -and of_intro_pattern_action ?loc = function +and of_intro_pattern_action (loc, pat) = match pat with | QIntroWildcard -> std_constructor ?loc "IntroWildcard" [] | QIntroOrAndPattern pat -> - std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern ?loc pat] + std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern pat] | QIntroInjection il -> - std_constructor ?loc "IntroInjection" [of_intro_patterns ?loc il] + std_constructor ?loc "IntroInjection" [of_intro_patterns il] | QIntroRewrite b -> std_constructor ?loc "IntroRewrite" [of_bool ?loc b] -and of_or_and_intro_pattern ?loc = function +and of_or_and_intro_pattern (loc, pat) = match pat with | QIntroOrPattern ill -> - let ill = List.map (of_intro_patterns ?loc) ill in + let ill = List.map of_intro_patterns ill in std_constructor ?loc "IntroOrPattern" [of_list ?loc ill] | QIntroAndPattern il -> - std_constructor ?loc "IntroAndPattern" [of_intro_patterns ?loc il] + std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] -and of_intro_patterns ?loc l = - of_list ?loc (List.map (of_intro_pattern ?loc) l) +and of_intro_patterns (loc, l) = + of_list ?loc (List.map of_intro_pattern l) let of_hyp_location_flag ?loc = function | Locus.InHyp -> std_constructor ?loc "InHyp" [] @@ -175,15 +179,15 @@ let of_clause ?loc cl = ]) let of_destruction_arg ?loc = function -| QElimOnConstr (c, bnd) -> - let c = of_open_constr ?loc c in - let bnd = of_bindings ?loc bnd in +| QElimOnConstr (loc, (c, bnd)) -> + let c = of_open_constr c in + let bnd = of_bindings bnd in let arg = thunk (of_pair ?loc (c, bnd)) in std_constructor ?loc "ElimOnConstr" [arg] -| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident ?loc id] -| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int ?loc n] +| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] +| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] -let of_induction_clause ?loc cl = +let of_induction_clause (loc, cl) = let arg = of_destruction_arg ?loc cl.indcl_arg in let eqn = of_option ?loc (Option.map of_intro_pattern_naming cl.indcl_eqn) in let as_ = of_option ?loc (Option.map of_or_and_intro_pattern cl.indcl_as) in @@ -199,7 +203,7 @@ let of_induction_clause ?loc cl = let of_hyp ?loc id = let loc = Option.default dummy_loc loc in let hyp = CTacRef (AbsKn (control_core "hyp")) in - CTacApp (loc, hyp, [of_ident ~loc id]) + CTacApp (loc, hyp, [of_ident id]) let of_exact_hyp ?loc id = let loc = Option.default dummy_loc loc in diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 40ea58e334..404e9378e0 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Loc open Names open Misctypes open Tac2qexpr @@ -18,32 +19,32 @@ open Tac2expr val constructor : ?loc:Loc.t -> ltac_constructor -> raw_tacexpr list -> raw_tacexpr -val of_anti : ?loc:Loc.t -> (?loc:Loc.t -> 'a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr +val of_anti : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr -val of_int : ?loc:Loc.t -> int -> raw_tacexpr +val of_int : int located -> raw_tacexpr val of_pair : ?loc:Loc.t -> raw_tacexpr * raw_tacexpr -> raw_tacexpr -val of_variable : ?loc:Loc.t -> Id.t -> raw_tacexpr +val of_variable : Id.t located -> raw_tacexpr -val of_ident : ?loc:Loc.t -> Id.t -> raw_tacexpr +val of_ident : Id.t located -> raw_tacexpr -val of_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr +val of_constr : Constrexpr.constr_expr -> raw_tacexpr -val of_open_constr : ?loc:Loc.t -> Constrexpr.constr_expr -> raw_tacexpr +val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr val of_list : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr -val of_bindings : ?loc:Loc.t -> bindings -> raw_tacexpr +val of_bindings : bindings -> raw_tacexpr -val of_intro_pattern : ?loc:Loc.t -> intro_pattern -> raw_tacexpr +val of_intro_pattern : intro_pattern -> raw_tacexpr -val of_intro_patterns : ?loc:Loc.t -> intro_pattern list -> raw_tacexpr +val of_intro_patterns : intro_pattern list located -> raw_tacexpr -val of_induction_clause : ?loc:Loc.t -> induction_clause -> raw_tacexpr +val of_induction_clause : induction_clause -> raw_tacexpr -val of_hyp : ?loc:Loc.t -> Id.t -> raw_tacexpr +val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) -val of_exact_hyp : ?loc:Loc.t -> Id.t -> raw_tacexpr +val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) -- cgit v1.2.3 From de88ba86e9d2a77883365503759eaec96928e9c4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Aug 2017 17:21:42 +0200 Subject: Introducing quotations for the rewrite tactic. --- src/g_ltac2.ml4 | 36 +++++++++++++++++++++++++++++++++++- src/tac2core.ml | 31 +++++++++---------------------- src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 20 +++++++++++++++++++- src/tac2quote.ml | 35 +++++++++++++++++++++++++++++++---- src/tac2quote.mli | 2 ++ theories/Std.v | 15 +++++++++++++++ 8 files changed, 113 insertions(+), 28 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index b10f8d66bd..48a593df28 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -308,7 +308,8 @@ open Tac2entries.Pltac let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram - GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause; + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause + q_rewriting; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -503,6 +504,39 @@ GEXTEND Gram q_induction_clause: [ [ cl = induction_clause -> Tac2quote.of_induction_clause cl ] ] ; + orient: + [ [ "->" -> Loc.tag ~loc:!@loc (Some true) + | "<-" -> Loc.tag ~loc:!@loc (Some false) + | -> Loc.tag ~loc:!@loc None + ]] + ; + rewriter: + [ [ "!"; c = constr_with_bindings -> + (Loc.tag ~loc:!@loc @@ QRepeatPlus,c) + | ["?"| LEFTQMARK]; c = constr_with_bindings -> + (Loc.tag ~loc:!@loc @@ QRepeatStar,c) + | n = lnatural; "!"; c = constr_with_bindings -> + (Loc.tag ~loc:!@loc @@ QPrecisely n,c) + | n = lnatural; ["?" | LEFTQMARK]; c = constr_with_bindings -> + (Loc.tag ~loc:!@loc @@ QUpTo n,c) + | n = lnatural; c = constr_with_bindings -> + (Loc.tag ~loc:!@loc @@ QPrecisely n,c) + | c = constr_with_bindings -> + (Loc.tag ~loc:!@loc @@ QPrecisely (Loc.tag 1), c) + ] ] + ; + oriented_rewriter: + [ [ b = orient; (m, c) = rewriter -> + Loc.tag ~loc:!@loc @@ { + rew_orient = b; + rew_repeat = m; + rew_equatn = c; + } + ] ] + ; + q_rewriting: + [ [ r = oriented_rewriter -> Tac2quote.of_rewriting r ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 45fa52ff9b..72b4dbfe97 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -883,29 +883,16 @@ let () = add_scope "bindings" begin function | _ -> scope_fail () end -let () = add_scope "intropattern" begin function -| [] -> - let scope = Extend.Aentry Tac2entries.Pltac.q_intropattern in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "intropatterns" begin function -| [] -> - let scope = Extend.Aentry Tac2entries.Pltac.q_intropatterns in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end +let add_expr_scope name entry = + add_scope name begin function + | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, (fun e -> e)) + | _ -> scope_fail () + end -let () = add_scope "induction_clause" begin function -| [] -> - let scope = Extend.Aentry Tac2entries.Pltac.q_induction_clause in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end +let () = add_expr_scope "intropattern" Tac2entries.Pltac.q_intropattern +let () = add_expr_scope "intropatterns" Tac2entries.Pltac.q_intropatterns +let () = add_expr_scope "induction_clause" Tac2entries.Pltac.q_induction_clause +let () = add_expr_scope "rewriting" Tac2entries.Pltac.q_rewriting let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index ce86e8aa33..3aa1ee23b7 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -29,6 +29,7 @@ let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" +let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 1567551246..f5c5a479c4 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -62,4 +62,5 @@ val q_bindings : raw_tacexpr Pcoq.Gram.entry val q_intropattern : raw_tacexpr Pcoq.Gram.entry val q_intropatterns : raw_tacexpr Pcoq.Gram.entry val q_induction_clause : raw_tacexpr Pcoq.Gram.entry +val q_rewriting : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 0eb9e9f4b5..f6b8c2c19b 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -63,8 +63,10 @@ type hyp_location = (occurrences * Id.t located or_anti) * Locus.hyp_location_fl type clause = { q_onhyps : hyp_location list option; q_concl_occs : occurrences; } +type constr_with_bindings = (Constrexpr.constr_expr * bindings) located + type destruction_arg = -| QElimOnConstr of (Constrexpr.constr_expr * bindings) located +| QElimOnConstr of constr_with_bindings | QElimOnIdent of Id.t located | QElimOnAnonHyp of int located @@ -76,3 +78,19 @@ type induction_clause_r = { } type induction_clause = induction_clause_r located + +type multi_r = +| QPrecisely of int located +| QUpTo of int located +| QRepeatStar +| QRepeatPlus + +type multi = multi_r located + +type rewriting_r = { + rew_orient : bool option located; + rew_repeat : multi; + rew_equatn : constr_with_bindings; +} + +type rewriting = rewriting_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 1cba488768..7d9c01f3f0 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -109,6 +109,11 @@ let of_bindings (loc, b) = match b with let tl = List.map map tl in std_constructor ?loc "ExplicitBindings" [of_list ?loc tl] +let of_constr_with_bindings (loc, (c, bnd)) = + let c = of_open_constr c in + let bnd = of_bindings bnd in + of_pair ?loc (c, bnd) + let rec of_intro_pattern (loc, pat) = match pat with | QIntroForthcoming b -> std_constructor ?loc "IntroForthcoming" [of_bool b] @@ -179,10 +184,8 @@ let of_clause ?loc cl = ]) let of_destruction_arg ?loc = function -| QElimOnConstr (loc, (c, bnd)) -> - let c = of_open_constr c in - let bnd = of_bindings bnd in - let arg = thunk (of_pair ?loc (c, bnd)) in +| QElimOnConstr c -> + let arg = thunk (of_constr_with_bindings c) in std_constructor ?loc "ElimOnConstr" [arg] | QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] | QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] @@ -200,6 +203,30 @@ let of_induction_clause (loc, cl) = std_proj "indcl_in", in_; ]) +let of_repeat (loc, r) = match r with +| QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] +| QUpTo n -> std_constructor ?loc "UpTo" [of_int n] +| QRepeatStar -> std_constructor ?loc "RepeatStar" [] +| QRepeatPlus -> std_constructor ?loc "RepeatPlus" [] + +let of_orient loc b = + if b then std_constructor ?loc "LTR" [] + else std_constructor ?loc "RTL" [] + +let of_rewriting (loc, rew) = + let orient = + let (loc, orient) = rew.rew_orient in + of_option ?loc (Option.map (fun b -> of_orient loc b) orient) + in + let repeat = of_repeat rew.rew_repeat in + let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in + let loc = Option.default dummy_loc loc in + CTacRec (loc, [ + std_proj "rew_orient", orient; + std_proj "rew_repeat", repeat; + std_proj "rew_equatn", equatn; + ]) + let of_hyp ?loc id = let loc = Option.default dummy_loc loc in let hyp = CTacRef (AbsKn (control_core "hyp")) in diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 404e9378e0..cb2e406571 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -43,6 +43,8 @@ val of_intro_patterns : intro_pattern list located -> raw_tacexpr val of_induction_clause : induction_clause -> raw_tacexpr +val of_rewriting : rewriting -> raw_tacexpr + val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) diff --git a/theories/Std.v b/theories/Std.v index 19bdc4c82a..09cb3ca0c2 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -86,6 +86,21 @@ Ltac2 Type induction_clause := { indcl_in : clause option; }. +Ltac2 Type repeat := [ +| Precisely (int) +| UpTo (int) +| RepeatStar +| RepeatPlus +]. + +Ltac2 Type orientation := [ LTR | RTL ]. + +Ltac2 Type rewriting := { + rew_orient : orientation option; + rew_repeat : repeat; + rew_equatn : (unit -> constr_with_bindings); +}. + Ltac2 Type evar_flag := bool. Ltac2 Type advanced_flag := bool. -- cgit v1.2.3 From 1f2de88e09c7bb1c0aa111db0d7d50b83f8a62d4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Aug 2017 18:02:57 +0200 Subject: Exporting the rewrite tactic. --- src/g_ltac2.ml4 | 14 ++++++++------ src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2quote.mli | 2 ++ src/tac2stdlib.ml | 24 ++++++++++++++++++++++++ src/tac2tactics.ml | 13 +++++++++++++ src/tac2tactics.mli | 13 +++++++++++-- tests/example2.v | 21 +++++++++++++++++++++ theories/Notations.v | 25 +++++++++++++++++++++++++ theories/Std.v | 2 ++ 11 files changed, 109 insertions(+), 8 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 48a593df28..8b373647f3 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -309,7 +309,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_rewriting; + q_rewriting q_clause; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -479,12 +479,14 @@ GEXTEND Gram { q_onhyps = Some hl; q_concl_occs = QNoOccurrences } ] ] ; - opt_clause: - [ [ "in"; cl = in_clause -> Some cl - | "at"; occs = occs_nums -> Some { q_onhyps = Some []; q_concl_occs = occs } - | -> None + clause: + [ [ "in"; cl = in_clause -> cl + | "at"; occs = occs_nums -> { q_onhyps = Some []; q_concl_occs = occs } ] ] ; + q_clause: + [ [ cl = clause -> Tac2quote.of_clause cl ] ] + ; concl_occ: [ [ "*"; occs = occs -> occs | -> QNoOccurrences @@ -492,7 +494,7 @@ GEXTEND Gram ; induction_clause: [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = opt_clause -> + cl = OPT clause -> Loc.tag ~loc:!@loc @@ { indcl_arg = c; indcl_eqn = eq; diff --git a/src/tac2core.ml b/src/tac2core.ml index 72b4dbfe97..7539e1b697 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -893,6 +893,7 @@ let () = add_expr_scope "intropattern" Tac2entries.Pltac.q_intropattern let () = add_expr_scope "intropatterns" Tac2entries.Pltac.q_intropatterns let () = add_expr_scope "induction_clause" Tac2entries.Pltac.q_induction_clause let () = add_expr_scope "rewriting" Tac2entries.Pltac.q_rewriting +let () = add_expr_scope "clause" Tac2entries.Pltac.q_clause let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 3aa1ee23b7..40d8ff078e 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -30,6 +30,7 @@ let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" +let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index f5c5a479c4..1fe13cda17 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -63,4 +63,5 @@ val q_intropattern : raw_tacexpr Pcoq.Gram.entry val q_intropatterns : raw_tacexpr Pcoq.Gram.entry val q_induction_clause : raw_tacexpr Pcoq.Gram.entry val q_rewriting : raw_tacexpr Pcoq.Gram.entry +val q_clause : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2quote.mli b/src/tac2quote.mli index cb2e406571..ddb39326d1 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -41,6 +41,8 @@ val of_intro_pattern : intro_pattern -> raw_tacexpr val of_intro_patterns : intro_pattern list located -> raw_tacexpr +val of_clause : ?loc:Loc.t -> clause -> raw_tacexpr + val of_induction_clause : induction_clause -> raw_tacexpr val of_rewriting : rewriting -> raw_tacexpr diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 7e421c8577..e8e63f520c 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -141,6 +141,21 @@ let to_induction_clause = function | _ -> assert false +let to_multi = function +| ValBlk (0, [| n |]) -> Precisely (Value.to_int n) +| ValBlk (1, [| n |]) -> UpTo (Value.to_int n) +| ValInt 0 -> RepeatStar +| ValInt 1 -> RepeatPlus +| _ -> assert false + +let to_rewriting = function +| ValBlk (0, [| orient; repeat; c |]) -> + let orient = Value.to_option Value.to_bool orient in + let repeat = to_multi repeat in + let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + (orient, repeat, c) +| _ -> assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -304,6 +319,15 @@ let () = define_prim2 "tac_lazy" begin fun flags cl -> Tactics.reduce (Lazy flags) cl end +let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> + let ev = Value.to_bool ev in + let rw = Value.to_list to_rewriting rw in + let cl = to_clause cl in + let to_tac t = Proofview.tclIGNORE (thaw t) in + let by = Value.to_option to_tac by in + Tac2tactics.rewrite ev rw cl by +end + (** Tactics from coretactics *) let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 439250db78..e7e15544af 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -44,3 +44,16 @@ let map_induction_clause ((clear, arg), eqn, as_, occ) = let induction_destruct isrec ev ic using = let ic = List.map map_induction_clause ic in Tactics.induction_destruct isrec ev (ic, using) + +type rewriting = + bool option * + multi * + EConstr.constr with_bindings tactic + +let rewrite ev rw cl by = + let map_rw (orient, repeat, c) = + (Option.default true orient, repeat, None, delayed_of_tactic c) + in + let rw = List.map map_rw rw in + let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE tac, Equality.Naive) by in + Equality.general_multi_rewrite ev rw cl by diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index f29793411a..93cc6ecd68 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -7,6 +7,7 @@ (************************************************************************) open Names +open Locus open Misctypes open Tactypes open Proofview @@ -21,7 +22,15 @@ type induction_clause = EConstr.constr with_bindings tactic destruction_arg * intro_pattern_naming option * or_and_intro_pattern option * - Locus.clause option + clause option val induction_destruct : rec_flag -> evars_flag -> - induction_clause list -> EConstr.constr with_bindings option -> unit Proofview.tactic + induction_clause list -> EConstr.constr with_bindings option -> unit tactic + +type rewriting = + bool option * + multi * + EConstr.constr with_bindings tactic + +val rewrite : + evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic diff --git a/tests/example2.v b/tests/example2.v index 812f9172c9..526cbc39f5 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -95,3 +95,24 @@ Proof. intros b1 b2. destruct &b1 as [|], &b2 as [|]; split. Qed. + +Goal forall n m, n = 0 -> n + m = m. +Proof. +intros n m Hn. +rewrite &Hn; split. +Qed. + +Goal forall n m p, n = m -> p = m -> 0 = n -> p = 0. +Proof. +intros n m p He He' Hn. +rewrite &He, <- &He' in Hn. +rewrite &Hn. +split. +Qed. + +Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. +Proof. +intros n m He He' He''. +rewrite <- &He by Std.assumption (). +Control.refine (fun () => &He''). +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 20f01c3b48..4ce9fc0dbd 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -138,3 +138,28 @@ Ltac2 Notation "edestruct" ic(list1(induction_clause, ",")) use(thunk(opt(seq("using", constr, bindings)))) := destruct0 true ic use. + +Ltac2 rewrite0 ev rw cl tac := + let tac := match tac with + | None => None + | Some p => + let ((_, tac)) := p in + Some tac + end in + let cl := match cl with + | None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } + | Some cl => cl + end in + Std.rewrite ev rw cl tac. + +Ltac2 Notation "rewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 false rw cl tac. + +Ltac2 Notation "erewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 true rw cl tac. diff --git a/theories/Std.v b/theories/Std.v index 09cb3ca0c2..695ea26444 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -134,6 +134,8 @@ Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". +Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". + Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". -- cgit v1.2.3 From dbaf8dd6b150619ac04b33ae4d581432cb5cefe0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Aug 2017 14:46:18 +0200 Subject: More notations for basic tactics. --- tests/example2.v | 7 +++++++ theories/Notations.v | 17 +++++++++++++---- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/tests/example2.v b/tests/example2.v index 526cbc39f5..76f069a5ae 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -116,3 +116,10 @@ intros n m He He' He''. rewrite <- &He by Std.assumption (). Control.refine (fun () => &He''). Qed. + +Goal forall n (r := if true then n else 0), r = n. +Proof. +intros n r. +hnf in r. +split. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 4ce9fc0dbd..4bba9a7495 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -139,6 +139,18 @@ Ltac2 Notation "edestruct" use(thunk(opt(seq("using", constr, bindings)))) := destruct0 true ic use. +Ltac2 default_on_concl cl := +match cl with +| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 Notation "red" cl(opt(clause)) := + Std.red (default_on_concl cl). + +Ltac2 Notation "hnf" cl(opt(clause)) := + Std.hnf (default_on_concl cl). + Ltac2 rewrite0 ev rw cl tac := let tac := match tac with | None => None @@ -146,10 +158,7 @@ Ltac2 rewrite0 ev rw cl tac := let ((_, tac)) := p in Some tac end in - let cl := match cl with - | None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } - | Some cl => cl - end in + let cl := default_on_concl cl in Std.rewrite ev rw cl tac. Ltac2 Notation "rewrite" -- cgit v1.2.3 From 6e6f348958cc333040991ca3dc2525a7c91dc9c0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Aug 2017 15:42:29 +0200 Subject: Exporting more reduction functions. --- src/tac2stdlib.ml | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2tactics.ml | 25 +++++++++++++++++++++++++ src/tac2tactics.mli | 8 ++++++++ theories/Std.v | 6 ++++++ 4 files changed, 87 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index e8e63f520c..3cfd0b5626 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -90,6 +90,13 @@ let to_red_flag = function } | _ -> assert false +let to_pattern_with_occs pat = + to_pair Value.to_pattern (fun occ -> to_occurrences to_int_or_var occ) pat + +let to_constr_with_occs c = + let (c, occ) = to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) c in + (occ, c) + let rec to_intro_pattern = function | ValBlk (0, [| b |]) -> IntroForthcoming (Value.to_bool b) | ValBlk (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) @@ -301,6 +308,13 @@ let () = define_prim1 "tac_hnf" begin fun cl -> Tactics.reduce Hnf cl end +let () = define_prim3 "tac_simpl" begin fun flags where cl -> + let flags = to_red_flag flags in + let where = Value.to_option to_pattern_with_occs where in + let cl = to_clause cl in + Tac2tactics.simpl flags where cl +end + let () = define_prim2 "tac_cbv" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in @@ -319,6 +333,40 @@ let () = define_prim2 "tac_lazy" begin fun flags cl -> Tactics.reduce (Lazy flags) cl end +let () = define_prim2 "tac_unfold" begin fun refs cl -> + let map v = + let (ref, occ) = to_pair to_evaluable_ref (fun occ -> to_occurrences to_int_or_var occ) v in + (occ, ref) + in + let refs = Value.to_list map refs in + let cl = to_clause cl in + Tactics.reduce (Unfold refs) cl +end + +let () = define_prim2 "tac_fold" begin fun args cl -> + let args = Value.to_list Value.to_constr args in + let cl = to_clause cl in + Tactics.reduce (Fold args) cl +end + +let () = define_prim2 "tac_pattern" begin fun where cl -> + let where = Value.to_list to_constr_with_occs where in + let cl = to_clause cl in + Tactics.reduce (Pattern where) cl +end + +let () = define_prim2 "tac_vm" begin fun where cl -> + let where = Value.to_option to_pattern_with_occs where in + let cl = to_clause cl in + Tac2tactics.vm where cl +end + +let () = define_prim2 "tac_native" begin fun where cl -> + let where = Value.to_option to_pattern_with_occs where in + let cl = to_clause cl in + Tac2tactics.native where cl +end + let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> let ev = Value.to_bool ev in let rw = Value.to_list to_rewriting rw in diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index e7e15544af..50c1df922e 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -6,8 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util +open Names +open Globnames open Misctypes open Tactypes +open Genredexpr open Tactics open Proofview open Tacmach.New @@ -57,3 +61,24 @@ let rewrite ev rw cl by = let rw = List.map map_rw rw in let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE tac, Equality.Naive) by in Equality.general_multi_rewrite ev rw cl by + +(** Ltac interface treats differently global references than other term + arguments in reduction expressions. In Ltac1, this is done at parsing time. + Instead, we parse indifferently any pattern and dispatch when the tactic is + called. *) +let map_pattern_with_occs (pat, occ) = match pat with +| Pattern.PRef (ConstRef cst) -> (occ, Inl (EvalConstRef cst)) +| Pattern.PRef (VarRef id) -> (occ, Inl (EvalVarRef id)) +| _ -> (occ, Inr pat) + +let simpl flags where cl = + let where = Option.map map_pattern_with_occs where in + Tactics.reduce (Simpl (flags, where)) cl + +let vm where cl = + let where = Option.map map_pattern_with_occs where in + Tactics.reduce (CbvVm where) cl + +let native where cl = + let where = Option.map map_pattern_with_occs where in + Tactics.reduce (CbvNative where) cl diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 93cc6ecd68..affbbbbdd7 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -8,6 +8,7 @@ open Names open Locus +open Genredexpr open Misctypes open Tactypes open Proofview @@ -34,3 +35,10 @@ type rewriting = val rewrite : evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic + +val simpl : evaluable_global_reference glob_red_flag -> + (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic + +val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic + +val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic diff --git a/theories/Std.v b/theories/Std.v index 695ea26444..43ccb06192 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -130,9 +130,15 @@ Ltac2 @ external induction : evar_flag -> induction_clause list -> Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". +Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_simpl". Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". +Ltac2 @ external unfold : (evaluable_reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". +Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". +Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". +Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". +Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". -- cgit v1.2.3 From 77150cc524f5cbdc9bf340be03f31e7f7542c98d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Aug 2017 17:14:21 +0200 Subject: Introducing grammar-free tactic notations. --- doc/ltac2.md | 32 +++++++++++++++++++++++++++++ src/tac2entries.ml | 60 +++++++++++++++++++++++++++++++++++++++++++++--------- src/tac2env.ml | 47 +++++++++++++++++++++++++++++++++--------- src/tac2env.mli | 13 ++++++++---- src/tac2expr.mli | 7 ++++++- src/tac2intern.ml | 30 ++++++++++++++++++++++++--- src/tac2print.ml | 2 +- src/tac2quote.ml | 4 ++-- 8 files changed, 164 insertions(+), 31 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index c2d930c9b6..b3596b2977 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -654,6 +654,38 @@ Beware that the order of evaluation of multiple let-bindings is not specified, so that you may have to resort to thunking to ensure that side-effects are performed at the right time. +## Abbreviations + +There exists a special kind of notations, called abbreviations, that is designed +so that it does not add any parsing rules. It is similar in spirit to Coq +abbreviations, insofar as its main purpose is to give an absolute name to a +piece of pure syntax, which can be transparently referred by this name as if it +were a proper definition. Abbreviations are introduced by the following +syntax. + +``` +VERNAC ::= +| "Ltac2" "Notation" IDENT ":=" TERM +``` + +The abbreviation can then be manipulated just as a normal Ltac2 definition, +except that it is expanded at internalization time into the given expression. +Furthermore, in order to make this kind of construction useful in practice in +an effectful language such as Ltac2, any syntactic argument to an abbreviation +is thunked on-the-fly during its expansion. + +For instance, suppose that we define the following. +``` +Ltac2 Notation foo := fun x => x (). +``` +Then we have the following expansion at internalization time. +``` +foo 0 ↦ (fun x => x ()) (fun _ => 0) +``` + +Note that abbreviations are not typechecked at all, and may result in typing +errors after expansion. + # TODO - Implement deep pattern-matching. diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 40d8ff078e..1dd8410d2a 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -42,14 +42,14 @@ type tacdef = { } let perform_tacdef visibility ((sp, kn), def) = - let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp kn in + let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp (TacConstant kn) in Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) let load_tacdef i obj = perform_tacdef (Until i) obj let open_tacdef i obj = perform_tacdef (Exactly i) obj let cache_tacdef ((sp, kn), def) = - let () = Tac2env.push_ltac (Until 1) sp kn in + let () = Tac2env.push_ltac (Until 1) sp (TacConstant kn) in Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) let subst_tacdef (subst, def) = @@ -599,7 +599,43 @@ let inTac2Notation : synext -> obj = subst_function = subst_synext; classify_function = classify_synext} -let register_notation ?(local = false) tkn lev body = +type abbreviation = { + abbr_body : raw_tacexpr; +} + +let perform_abbreviation visibility ((sp, kn), abbr) = + let () = Tac2env.push_ltac visibility sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let load_abbreviation i obj = perform_abbreviation (Until i) obj +let open_abbreviation i obj = perform_abbreviation (Exactly i) obj + +let cache_abbreviation ((sp, kn), abbr) = + let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let subst_abbreviation (subst, abbr) = + let body' = subst_rawexpr subst abbr.abbr_body in + if body' == abbr.abbr_body then abbr + else { abbr_body = body' } + +let classify_abbreviation o = Substitute o + +let inTac2Abbreviation : abbreviation -> obj = + declare_object {(default_object "TAC2-ABBREVIATION") with + cache_function = cache_abbreviation; + load_function = load_abbreviation; + open_function = open_abbreviation; + subst_function = subst_abbreviation; + classify_function = classify_abbreviation} + +let register_notation ?(local = false) tkn lev body = match tkn, lev with +| [SexprRec (_, (_, Some id), [])], None -> + (** Tactic abbreviation *) + let body = Tac2intern.globalize Id.Set.empty body in + let abbr = { abbr_body = body } in + ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) +| _ -> (** Check that the tokens make sense *) let entries = List.map ParseToken.parse_token tkn in let fold accu tok = match tok with @@ -642,14 +678,18 @@ let print_ltac ref = try Tac2env.locate_ltac qid with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) in - let (e, _, (_, t)) = Tac2env.interp_global kn in - let name = int_name () in - Feedback.msg_notice ( - hov 0 ( - hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ - hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + match kn with + | TacConstant kn -> + let (e, _, (_, t)) = Tac2env.interp_global kn in + let name = int_name () in + Feedback.msg_notice ( + hov 0 ( + hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ + hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + ) ) - ) + | TacAlias kn -> + Feedback.msg_notice (str "Alias to ...") (** Calling tactics *) diff --git a/src/tac2env.ml b/src/tac2env.ml index a75500eae7..ac2bd5fc23 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -32,6 +32,7 @@ type ltac_state = { ltac_constructors : constructor_data KNmap.t; ltac_projections : projection_data KNmap.t; ltac_types : glb_quant_typedef KNmap.t; + ltac_aliases : raw_tacexpr KNmap.t; } let empty_state = { @@ -39,6 +40,7 @@ let empty_state = { ltac_constructors = KNmap.empty; ltac_projections = KNmap.empty; ltac_types = KNmap.empty; + ltac_aliases = KNmap.empty; } let ltac_state = Summary.ref empty_state ~name:"ltac2-state" @@ -87,6 +89,12 @@ let define_type kn e = let interp_type kn = KNmap.find kn ltac_state.contents.ltac_types +let define_alias kn tac = + let state = !ltac_state in + ltac_state := { state with ltac_aliases = KNmap.add kn tac state.ltac_aliases } + +let interp_alias kn = KNmap.find kn ltac_state.contents.ltac_aliases + module ML = struct type t = ml_tactic_name @@ -115,11 +123,30 @@ struct id, (DirPath.repr dir) end +type tacref = Tac2expr.tacref = +| TacConstant of ltac_constant +| TacAlias of ltac_alias + +module TacRef = +struct +type t = tacref +let compare r1 r2 = match r1, r2 with +| TacConstant c1, TacConstant c2 -> KerName.compare c1 c2 +| TacAlias c1, TacAlias c2 -> KerName.compare c1 c2 +| TacConstant _, TacAlias _ -> -1 +| TacAlias _, TacConstant _ -> 1 + +let equal r1 r2 = compare r1 r2 == 0 + +end + module KnTab = Nametab.Make(FullPath)(KerName) +module RfTab = Nametab.Make(FullPath)(TacRef) +module RfMap = Map.Make(TacRef) type nametab = { - tab_ltac : KnTab.t; - tab_ltac_rev : full_path KNmap.t; + tab_ltac : RfTab.t; + tab_ltac_rev : full_path RfMap.t; tab_cstr : KnTab.t; tab_cstr_rev : full_path KNmap.t; tab_type : KnTab.t; @@ -129,8 +156,8 @@ type nametab = { } let empty_nametab = { - tab_ltac = KnTab.empty; - tab_ltac_rev = KNmap.empty; + tab_ltac = RfTab.empty; + tab_ltac_rev = RfMap.empty; tab_cstr = KnTab.empty; tab_cstr_rev = KNmap.empty; tab_type = KnTab.empty; @@ -143,22 +170,22 @@ let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" let push_ltac vis sp kn = let tab = !nametab in - let tab_ltac = KnTab.push vis sp kn tab.tab_ltac in - let tab_ltac_rev = KNmap.add kn sp tab.tab_ltac_rev in + let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in + let tab_ltac_rev = RfMap.add kn sp tab.tab_ltac_rev in nametab := { tab with tab_ltac; tab_ltac_rev } let locate_ltac qid = let tab = !nametab in - KnTab.locate qid tab.tab_ltac + RfTab.locate qid tab.tab_ltac let locate_extended_all_ltac qid = let tab = !nametab in - KnTab.find_prefixes qid tab.tab_ltac + RfTab.find_prefixes qid tab.tab_ltac let shortest_qualid_of_ltac kn = let tab = !nametab in - let sp = KNmap.find kn tab.tab_ltac_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + let sp = RfMap.find kn tab.tab_ltac_rev in + RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac let push_constructor vis sp kn = let tab = !nametab in diff --git a/src/tac2env.mli b/src/tac2env.mli index fea03c4285..e4cc8387c5 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -61,12 +61,17 @@ type projection_data = { val define_projection : ltac_projection -> projection_data -> unit val interp_projection : ltac_projection -> projection_data +(** {5 Toplevel definition of aliases} *) + +val define_alias : ltac_constant -> raw_tacexpr -> unit +val interp_alias : ltac_constant -> raw_tacexpr + (** {5 Name management} *) -val push_ltac : visibility -> full_path -> ltac_constant -> unit -val locate_ltac : qualid -> ltac_constant -val locate_extended_all_ltac : qualid -> ltac_constant list -val shortest_qualid_of_ltac : ltac_constant -> qualid +val push_ltac : visibility -> full_path -> tacref -> unit +val locate_ltac : qualid -> tacref +val locate_extended_all_ltac : qualid -> tacref list +val shortest_qualid_of_ltac : tacref -> qualid val push_constructor : visibility -> full_path -> ltac_constructor -> unit val locate_constructor : qualid -> ltac_constructor diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 10d8c1d421..7efb85cbb0 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -18,10 +18,15 @@ type lid = Id.t type uid = Id.t type ltac_constant = KerName.t +type ltac_alias = KerName.t type ltac_constructor = KerName.t type ltac_projection = KerName.t type type_constant = KerName.t +type tacref = +| TacConstant of ltac_constant +| TacAlias of ltac_alias + type 'a or_relid = | RelId of qualid located | AbsKn of 'a @@ -88,7 +93,7 @@ type raw_patexpr = type raw_tacexpr = | CTacAtm of atom located -| CTacRef of ltac_constant or_relid +| CTacRef of tacref or_relid | CTacCst of Loc.t * ltac_constructor or_tuple or_relid | CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 32ed211ad0..2b1dde7553 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -654,6 +654,10 @@ let expand_pattern avoid bnd = let nas = List.rev_map (fun (na, _, _) -> na) bnd in (nas, expand) +let is_alias env qid = match get_variable env qid with +| ArgArg (TacAlias _) -> true +| ArgVar _ | (ArgArg (TacConstant _)) -> false + let rec intern_rec env = function | CTacAtm (_, atm) -> intern_atm env atm | CTacRef qid -> @@ -661,9 +665,12 @@ let rec intern_rec env = function | ArgVar (_, id) -> let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) - | ArgArg kn -> + | ArgArg (TacConstant kn) -> let (_, _, sch) = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) + | ArgArg (TacAlias kn) -> + let e = Tac2env.interp_alias kn in + intern_rec env e end | CTacCst (loc, qid) -> let kn = get_constructor env qid in @@ -682,6 +689,20 @@ let rec intern_rec env = function | CTacApp (loc, CTacCst (_, qid), args) -> let kn = get_constructor env qid in intern_constructor env loc kn args +| CTacApp (loc, CTacRef qid, args) when is_alias env qid -> + let kn = match get_variable env qid with + | ArgArg (TacAlias kn) -> kn + | ArgVar _ | (ArgArg (TacConstant _)) -> assert false + in + let e = Tac2env.interp_alias kn in + let map arg = + (** Thunk alias arguments *) + let loc = loc_of_tacexpr arg in + let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Tuple 0), []))] in + CTacFun (loc, var, arg) + in + let args = List.map map args in + intern_rec env (CTacApp (loc, e, args)) | CTacApp (loc, f, args) -> let loc = loc_of_tacexpr f in let (f, ft) = intern_rec env f in @@ -1372,9 +1393,12 @@ let rec subst_rawtype subst t = match t with let subst_tacref subst ref = match ref with | RelId _ -> ref -| AbsKn kn -> +| AbsKn (TacConstant kn) -> let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn kn' + if kn' == kn then ref else AbsKn (TacConstant kn') +| AbsKn (TacAlias kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacAlias kn') let subst_projection subst prj = match prj with | RelId _ -> prj diff --git a/src/tac2print.ml b/src/tac2print.ml index 28f9516f65..b679e030fd 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -143,7 +143,7 @@ let pr_glbexpr_gen lvl c = | GTacAtm atm -> pr_atom atm | GTacVar id -> Id.print id | GTacRef gr -> - let qid = shortest_qualid_of_ltac gr in + let qid = shortest_qualid_of_ltac (TacConstant gr) in Libnames.pr_qualid qid | GTacFun (nas, c) -> let nas = pr_sequence pr_name nas in diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 7d9c01f3f0..3e25e1cadb 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -229,10 +229,10 @@ let of_rewriting (loc, rew) = let of_hyp ?loc id = let loc = Option.default dummy_loc loc in - let hyp = CTacRef (AbsKn (control_core "hyp")) in + let hyp = CTacRef (AbsKn (TacConstant (control_core "hyp"))) in CTacApp (loc, hyp, [of_ident id]) let of_exact_hyp ?loc id = let loc = Option.default dummy_loc loc in - let refine = CTacRef (AbsKn (control_core "refine")) in + let refine = CTacRef (AbsKn (TacConstant (control_core "refine"))) in CTacApp (loc, refine, [thunk (of_hyp ~loc id)]) -- cgit v1.2.3 From e1ea058fb664be58371237e5a6dbe0ec570448d5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Aug 2017 15:15:36 +0200 Subject: Defining a few base tacticals. --- src/tac2core.ml | 25 +++++++++++++++++++++++ theories/Control.v | 13 ++++++++++++ theories/Notations.v | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 93 insertions(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 7539e1b697..08f61f2c6c 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -574,6 +574,27 @@ let prm_with_holes : ml_tactic = function Tacticals.New.tclWITHHOLES false (interp_app f [ans]) sigma | _ -> assert false +let prm_progress : ml_tactic = function +| [f] -> Proofview.tclPROGRESS (thaw f) +| _ -> assert false + +let prm_abstract : ml_tactic = function +| [id; f] -> + let id = Value.to_option Value.to_ident id in + Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> + return v_unit +| _ -> assert false + +let prm_time : ml_tactic = function +| [s; f] -> + let s = Value.to_option Value.to_string s in + Proofview.tclTIME s (thaw f) +| _ -> assert false + +let prm_check_interrupt : ml_tactic = function +| [_] -> Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit +| _ -> assert false + (** Registering *) let () = Tac2env.define_primitive (pname "print") prm_print @@ -632,6 +653,10 @@ let () = Tac2env.define_primitive (pname "hyp") prm_hyp let () = Tac2env.define_primitive (pname "hyps") prm_hyps let () = Tac2env.define_primitive (pname "refine") prm_refine let () = Tac2env.define_primitive (pname "with_holes") prm_with_holes +let () = Tac2env.define_primitive (pname "progress") prm_progress +let () = Tac2env.define_primitive (pname "abstract") prm_abstract +let () = Tac2env.define_primitive (pname "time") prm_time +let () = Tac2env.define_primitive (pname "check_interrupt") prm_check_interrupt (** ML types *) diff --git a/theories/Control.v b/theories/Control.v index a8b92aced2..071c2ea8ce 100644 --- a/theories/Control.v +++ b/theories/Control.v @@ -34,6 +34,8 @@ Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". already defined in the current state, don't do anything. Panics if the evar is not in the current state. *) +Ltac2 @ external progress : (unit -> 'a) -> 'a := "ltac2" "progress". + (** Goal inspection *) Ltac2 @ external goal : unit -> constr := "ltac2" "goal". @@ -61,3 +63,14 @@ Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_ (** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if all evars generated by the call to [x] have not been solved when [f] returns. *) + +(** Misc *) + +Ltac2 @ external time : string option -> (unit -> 'a) -> 'a := "ltac2" "time". +(** Displays the time taken by a tactic to evaluate. *) + +Ltac2 @ external abstract : ident option -> (unit -> unit) -> unit := "ltac2" "abstract". +(** Abstract a subgoal. *) + +Ltac2 @ external check_interrupt : unit -> unit := "ltac2" "check_interrupt". +(** For internal use. *) diff --git a/theories/Notations.v b/theories/Notations.v index 4bba9a7495..f11cfbde6e 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -7,7 +7,61 @@ (************************************************************************) Require Import Ltac2.Init. -Require Ltac2.Control Ltac2.Std. +Require Ltac2.Control Ltac2.Int Ltac2.Std. + +(** Tacticals *) + +Ltac2 orelse t f := +match Control.case t with +| Err e => f e +| Val ans => + let ((x, k)) := ans in + Control.plus (fun _ => x) k +end. + +Ltac2 ifcatch t s f := +match Control.case t with +| Err e => f e +| Val ans => + let ((x, k)) := ans in + Control.plus (fun _ => s x) (fun e => s (k e)) +end. + +Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). + +Ltac2 Notation try := try0. + +Ltac2 rec repeat0 (t : unit -> unit) := + Control.enter (fun () => + ifcatch (fun _ => Control.progress t) + (fun _ => Control.check_interrupt (); repeat0 t) (fun _ => ())). + +Ltac2 Notation repeat := repeat0. + +Ltac2 do0 n t := + let rec aux n t := match Int.equal n 0 with + | true => () + | false => t (); aux (Int.sub n 1) t + end in + aux (n ()) t. + +Ltac2 Notation do := do0. + +Ltac2 Notation once := Control.once. + +Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). + +Ltac2 Notation progress := progress0. + +Ltac2 time0 tac := Control.time None tac. + +Ltac2 Notation time := time0. + +Ltac2 abstract0 tac := Control.abstract None tac. + +Ltac2 Notation abstract := abstract0. + +(** Base tactics *) (** Enter and check evar resolution *) Ltac2 enter_h ev f arg := -- cgit v1.2.3 From c0f72bb07442075ee1dc66b4902b5c4681d220cf Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Aug 2017 16:22:45 +0200 Subject: Fix parsing of parenthesized expressions. --- src/g_ltac2.ml4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 8b373647f3..1cab918ea4 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -119,8 +119,8 @@ GEXTEND Gram | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> CTacSet (!@loc, e, RelId qid, r) ] | "0" - [ "("; a = tac2expr LEVEL "5"; ")" -> a - | "("; a = tac2expr; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) + [ "("; a = SELF; ")" -> a + | "("; a = SELF; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) | "()" -> CTacCst (!@loc, AbsKn (Tuple 0)) | "("; ")" -> CTacCst (!@loc, AbsKn (Tuple 0)) | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> CTacLst (Loc.tag ~loc:!@loc a) -- cgit v1.2.3 From 49f0f89e3a7905679d758017ccaeba64c0ca79b1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Aug 2017 16:26:35 +0200 Subject: Fix location of not-unit warning. --- src/tac2intern.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 2b1dde7553..bf7e93cb9e 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -750,9 +750,10 @@ let rec intern_rec env = function let () = unify ~loc env t tc in (e, tc) | CTacSeq (loc, e1, e2) -> + let loc1 = loc_of_tacexpr e1 in let (e1, t1) = intern_rec env e1 in let (e2, t2) = intern_rec env e2 in - let () = check_elt_unit loc env t1 in + let () = check_elt_unit loc1 env t1 in (GTacLet (false, [Anonymous, e1], e2), t2) | CTacCse (loc, e, pl) -> intern_case env loc e pl -- cgit v1.2.3 From bdd7bbb7875e596f802296a7a6ce0e77fd72fa51 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Aug 2017 16:28:42 +0200 Subject: Defining abbreviations for tactics that can parse as atoms. --- theories/Notations.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/theories/Notations.v b/theories/Notations.v index f11cfbde6e..d7f7170a5e 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -63,6 +63,10 @@ Ltac2 Notation abstract := abstract0. (** Base tactics *) +(** Note that we redeclare notations that can be parsed as mere identifiers + as abbreviations, so that it allows to parse them as function arguments + without having to write them within parentheses. *) + (** Enter and check evar resolution *) Ltac2 enter_h ev f arg := match ev with @@ -76,35 +80,45 @@ Ltac2 intros0 ev p := Control.enter (fun () => Std.intros false p). Ltac2 Notation "intros" p(intropatterns) := intros0 false p. +Ltac2 Notation intros := intros. Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. +Ltac2 Notation eintros := eintros. Ltac2 split0 ev bnd := enter_h ev Std.split bnd. Ltac2 Notation "split" bnd(thunk(bindings)) := split0 false bnd. +Ltac2 Notation split := split. Ltac2 Notation "esplit" bnd(thunk(bindings)) := split0 true bnd. +Ltac2 Notation esplit := esplit. Ltac2 left0 ev bnd := enter_h ev Std.left bnd. Ltac2 Notation "left" bnd(thunk(bindings)) := left0 false bnd. +Ltac2 Notation left := left. Ltac2 Notation "eleft" bnd(thunk(bindings)) := left0 true bnd. +Ltac2 Notation eleft := eleft. Ltac2 right0 ev bnd := enter_h ev Std.right bnd. Ltac2 Notation "right" bnd(thunk(bindings)) := right0 false bnd. +Ltac2 Notation right := right. Ltac2 Notation "eright" bnd(thunk(bindings)) := right0 true bnd. +Ltac2 Notation eright := eright. Ltac2 constructor0 ev n bnd := enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). +Ltac2 Notation constructor := constructor. Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := constructor0 false n bnd. Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). +Ltac2 Notation econstructor := econstructor. Ltac2 Notation "econstructor" n(tactic) bnd(thunk(bindings)) := constructor0 true n bnd. Ltac2 elim0 ev c bnd use := @@ -201,9 +215,11 @@ end. Ltac2 Notation "red" cl(opt(clause)) := Std.red (default_on_concl cl). +Ltac2 Notation red := red. Ltac2 Notation "hnf" cl(opt(clause)) := Std.hnf (default_on_concl cl). +Ltac2 Notation hnf := hnf. Ltac2 rewrite0 ev rw cl tac := let tac := match tac with -- cgit v1.2.3 From 5062231251d58cf51cedb18677392b6e6d168694 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Aug 2017 16:39:25 +0200 Subject: Defining several aliases for built-in tactics. --- tests/example2.v | 4 ++-- theories/Notations.v | 12 ++++++++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/tests/example2.v b/tests/example2.v index 76f069a5ae..bfb1b07e7a 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -5,7 +5,7 @@ Import Ltac2.Notations. Goal exists n, n = 0. Proof. split with (x := 0). -Std.reflexivity (). +reflexivity. Qed. Goal exists n, n = 0. @@ -113,7 +113,7 @@ Qed. Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. Proof. intros n m He He' He''. -rewrite <- &He by Std.assumption (). +rewrite <- &He by assumption. Control.refine (fun () => &He''). Qed. diff --git a/theories/Notations.v b/theories/Notations.v index d7f7170a5e..0fa3456196 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -242,3 +242,15 @@ Ltac2 Notation "erewrite" cl(opt(clause)) tac(opt(seq("by", thunk(tactic)))) := rewrite0 true rw cl tac. + +(** Other base tactics *) + +Ltac2 Notation reflexivity := Std.reflexivity (). + +Ltac2 Notation assumption := Std.assumption (). + +Ltac2 Notation etransitivity := Std.etransitivity (). + +Ltac2 Notation admit := Std.admit (). + +Ltac2 Notation clear := Std.keep []. -- cgit v1.2.3 From 3d1092cf7df3229ecc2a4da60a33cf7c6b9be1a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Aug 2017 12:32:37 +0200 Subject: Code simplification in quotations. --- src/g_ltac2.ml4 | 7 ++++--- src/tac2qexpr.mli | 4 +++- src/tac2quote.ml | 56 +++++++++++++++++++++++++------------------------------ src/tac2quote.mli | 8 ++++---- 4 files changed, 36 insertions(+), 39 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 1cab918ea4..9bc7107cc7 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -325,7 +325,7 @@ GEXTEND Gram [ [ n = Prim.natural -> Loc.tag ~loc:!@loc n ] ] ; q_ident: - [ [ id = ident_or_anti -> Tac2quote.of_anti ~loc:!@loc Tac2quote.of_ident id ] ] + [ [ id = ident_or_anti -> Tac2quote.of_anti Tac2quote.of_ident id ] ] ; qhyp: [ [ x = anti -> x @@ -480,8 +480,9 @@ GEXTEND Gram ] ] ; clause: - [ [ "in"; cl = in_clause -> cl - | "at"; occs = occs_nums -> { q_onhyps = Some []; q_concl_occs = occs } + [ [ "in"; cl = in_clause -> Loc.tag ~loc:!@loc @@ cl + | "at"; occs = occs_nums -> + Loc.tag ~loc:!@loc @@ { q_onhyps = Some []; q_concl_occs = occs } ] ] ; q_clause: diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index f6b8c2c19b..d5520c54ee 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -60,9 +60,11 @@ type occurrences = type hyp_location = (occurrences * Id.t located or_anti) * Locus.hyp_location_flag -type clause = +type clause_r = { q_onhyps : hyp_location list option; q_concl_occs : occurrences; } +type clause = clause_r located + type constr_with_bindings = (Constrexpr.constr_expr * bindings) located type destruction_arg = diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 3e25e1cadb..57c8a4bbed 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -45,9 +45,9 @@ let thunk e = let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other t_unit), []))] in CTacFun (loc, var, e) -let of_pair ?loc (e1, e2) = +let of_pair f g (loc, (e1, e2)) = let loc = Option.default dummy_loc loc in - CTacApp (loc, CTacCst (loc, AbsKn (Tuple 2)), [e1; e2]) + CTacApp (loc, CTacCst (loc, AbsKn (Tuple 2)), [f e1; g e2]) let of_tuple ?loc el = let loc = Option.default dummy_loc loc in @@ -57,9 +57,9 @@ let of_tuple ?loc el = let of_int (loc, n) = CTacAtm (Loc.tag ?loc (AtmInt n)) -let of_option ?loc opt = match opt with +let of_option ?loc f opt = match opt with | None -> constructor ?loc (coq_core "None") [] -| Some e -> constructor ?loc (coq_core "Some") [e] +| Some e -> constructor ?loc (coq_core "Some") [f e] let inj_wit ?loc wit x = let loc = Option.default dummy_loc loc in @@ -71,7 +71,7 @@ let of_variable (loc, id) = CErrors.user_err ?loc (str "Invalid identifier") else CTacRef (RelId (Loc.tag ?loc qid)) -let of_anti ?loc f = function +let of_anti f = function | QExpr x -> f x | QAnti id -> of_variable id @@ -89,10 +89,10 @@ let of_bool ?loc b = let c = if b then Core.c_true else Core.c_false in constructor ?loc c [] -let rec of_list ?loc = function +let rec of_list ?loc f = function | [] -> constructor Core.c_nil [] | e :: l -> - constructor ?loc Core.c_cons [e; of_list ?loc l] + constructor ?loc Core.c_cons [f e; of_list ?loc f l] let of_qhyp (loc, h) = match h with | QAnonHyp n -> constructor ?loc Core.c_anon_hyp [of_int n] @@ -102,17 +102,12 @@ let of_bindings (loc, b) = match b with | QNoBindings -> std_constructor ?loc "NoBindings" [] | QImplicitBindings tl -> - let tl = List.map of_open_constr tl in - std_constructor ?loc "ImplicitBindings" [of_list ?loc tl] + std_constructor ?loc "ImplicitBindings" [of_list ?loc of_open_constr tl] | QExplicitBindings tl -> - let map (loc, (qhyp, e)) = of_pair ?loc (of_anti ?loc of_qhyp qhyp, of_open_constr e) in - let tl = List.map map tl in - std_constructor ?loc "ExplicitBindings" [of_list ?loc tl] + let map e = of_pair (fun q -> of_anti of_qhyp q) of_open_constr e in + std_constructor ?loc "ExplicitBindings" [of_list ?loc map tl] -let of_constr_with_bindings (loc, (c, bnd)) = - let c = of_open_constr c in - let bnd = of_bindings bnd in - of_pair ?loc (c, bnd) +let of_constr_with_bindings c = of_pair of_open_constr of_bindings c let rec of_intro_pattern (loc, pat) = match pat with | QIntroForthcoming b -> @@ -126,7 +121,7 @@ and of_intro_pattern_naming (loc, pat) = match pat with | QIntroIdentifier id -> std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] | QIntroFresh id -> - std_constructor ?loc "IntroFresh" [of_anti ?loc of_ident id] + std_constructor ?loc "IntroFresh" [of_anti of_ident id] | QIntroAnonymous -> std_constructor ?loc "IntroAnonymous" [] @@ -142,13 +137,12 @@ and of_intro_pattern_action (loc, pat) = match pat with and of_or_and_intro_pattern (loc, pat) = match pat with | QIntroOrPattern ill -> - let ill = List.map of_intro_patterns ill in - std_constructor ?loc "IntroOrPattern" [of_list ?loc ill] + std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] | QIntroAndPattern il -> std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] and of_intro_patterns (loc, l) = - of_list ?loc (List.map of_intro_pattern l) + of_list ?loc of_intro_pattern l let of_hyp_location_flag ?loc = function | Locus.InHyp -> std_constructor ?loc "InHyp" [] @@ -158,25 +152,25 @@ let of_hyp_location_flag ?loc = function let of_occurrences ?loc occ = match occ with | QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] | QAllOccurrencesBut occs -> - let map occ = of_anti ?loc of_int occ in - let occs = of_list ?loc (List.map map occs) in + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in std_constructor ?loc "AllOccurrencesBut" [occs] | QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] | QOnlyOccurrences occs -> - let map occ = of_anti ?loc of_int occ in - let occs = of_list ?loc (List.map map occs) in + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in std_constructor ?loc "OnlyOccurrences" [occs] let of_hyp_location ?loc ((occs, id), flag) = of_tuple ?loc [ - of_anti ?loc of_ident id; + of_anti of_ident id; of_occurrences ?loc occs; of_hyp_location_flag ?loc flag; ] -let of_clause ?loc cl = +let of_clause (loc, cl) = let loc = Option.default dummy_loc loc in - let hyps = of_option ~loc (Option.map (fun l -> of_list ~loc (List.map of_hyp_location l)) cl.q_onhyps) in + let hyps = of_option ~loc (fun l -> of_list ~loc of_hyp_location l) cl.q_onhyps in let concl = of_occurrences ~loc cl.q_concl_occs in CTacRec (loc, [ std_proj "on_hyps", hyps; @@ -192,9 +186,9 @@ let of_destruction_arg ?loc = function let of_induction_clause (loc, cl) = let arg = of_destruction_arg ?loc cl.indcl_arg in - let eqn = of_option ?loc (Option.map of_intro_pattern_naming cl.indcl_eqn) in - let as_ = of_option ?loc (Option.map of_or_and_intro_pattern cl.indcl_as) in - let in_ = of_option ?loc (Option.map of_clause cl.indcl_in) in + let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in + let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in + let in_ = of_option ?loc of_clause cl.indcl_in in let loc = Option.default dummy_loc loc in CTacRec (loc, [ std_proj "indcl_arg", arg; @@ -216,7 +210,7 @@ let of_orient loc b = let of_rewriting (loc, rew) = let orient = let (loc, orient) = rew.rew_orient in - of_option ?loc (Option.map (fun b -> of_orient loc b) orient) + of_option ?loc (fun b -> of_orient loc b) orient in let repeat = of_repeat rew.rew_repeat in let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in diff --git a/src/tac2quote.mli b/src/tac2quote.mli index ddb39326d1..dba3c82715 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -19,11 +19,11 @@ open Tac2expr val constructor : ?loc:Loc.t -> ltac_constructor -> raw_tacexpr list -> raw_tacexpr -val of_anti : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr +val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr val of_int : int located -> raw_tacexpr -val of_pair : ?loc:Loc.t -> raw_tacexpr * raw_tacexpr -> raw_tacexpr +val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) located -> raw_tacexpr val of_variable : Id.t located -> raw_tacexpr @@ -33,7 +33,7 @@ val of_constr : Constrexpr.constr_expr -> raw_tacexpr val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr -val of_list : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr +val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr val of_bindings : bindings -> raw_tacexpr @@ -41,7 +41,7 @@ val of_intro_pattern : intro_pattern -> raw_tacexpr val of_intro_patterns : intro_pattern list located -> raw_tacexpr -val of_clause : ?loc:Loc.t -> clause -> raw_tacexpr +val of_clause : clause -> raw_tacexpr val of_induction_clause : induction_clause -> raw_tacexpr -- cgit v1.2.3 From 3fbba861d5355cad92cac52965c8e76a35825c7a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Aug 2017 14:21:11 +0200 Subject: Another batch of primitive operations. --- src/g_ltac2.ml4 | 8 ++++---- src/tac2core.ml | 2 +- tests/tacticals.v | 22 ++++++++++++++++++++++ theories/Init.v | 3 +++ theories/Notations.v | 28 ++++++++++++++++++++++++++++ 5 files changed, 58 insertions(+), 5 deletions(-) create mode 100644 tests/tacticals.v diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 9bc7107cc7..695fc7d430 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -97,13 +97,13 @@ GEXTEND Gram ] ; tac2expr: - [ "top" RIGHTA + [ "6" RIGHTA [ e1 = SELF; ";"; e2 = SELF -> CTacSeq (!@loc, e1, e2) ] | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "top" -> CTacFun (!@loc, it, body) + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> CTacFun (!@loc, it, body) | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "top" -> CTacLet (!@loc, isrec, lc, e) + e = tac2expr LEVEL "6" -> CTacLet (!@loc, isrec, lc, e) | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> CTacCse (!@loc, e, bl) ] @@ -135,7 +135,7 @@ GEXTEND Gram ] ; branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "top" -> (pat, e) ] ] + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> (pat, e) ] ] ; rec_flag: [ [ IDENT "rec" -> true diff --git a/src/tac2core.ml b/src/tac2core.ml index 08f61f2c6c..1c03cc410d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -877,7 +877,7 @@ let () = add_scope "tactic" begin function let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt (loc, n)] -> - let () = if n < 0 || n > 5 then scope_fail () in + let () = if n < 0 || n > 6 then scope_fail () in let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) diff --git a/tests/tacticals.v b/tests/tacticals.v new file mode 100644 index 0000000000..73f9c03b87 --- /dev/null +++ b/tests/tacticals.v @@ -0,0 +1,22 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Goal True. +Proof. +Fail fail. +Fail solve [ () ]. +try fail. +repeat fail. +repeat (). +solve [ constructor ]. +Qed. + +Goal True. +Proof. +first [ + Message.print (Message.of_string "Yay"); fail +| constructor +| Message.print (Message.of_string "I won't be printed") +]. +Qed. diff --git a/theories/Init.v b/theories/Init.v index 803e48e352..1591747eb4 100644 --- a/theories/Init.v +++ b/theories/Init.v @@ -60,3 +60,6 @@ Ltac2 Type exn ::= [ Not_found ]. Ltac2 Type exn ::= [ Match_failure ]. (** Used to signal a pattern didn't match a term. *) + +Ltac2 Type exn ::= [ Tactic_failure ]. +(** Generic error for tactic failure. *) diff --git a/theories/Notations.v b/theories/Notations.v index 0fa3456196..97f3042d2b 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -27,6 +27,10 @@ match Control.case t with Control.plus (fun _ => s x) (fun e => s (k e)) end. +Ltac2 fail0 (_ : unit) := Control.zero Tactic_failure. + +Ltac2 Notation fail := fail0 (). + Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). Ltac2 Notation try := try0. @@ -53,6 +57,28 @@ Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). Ltac2 Notation progress := progress0. +Ltac2 rec first0 tacs := +match tacs with +| [] => Control.zero Tactic_failure +| tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) +end. + +Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs. + +Ltac2 complete tac := + let ans := tac () in + Control.enter (fun () => Control.zero Tactic_failure); + ans. + +Ltac2 rec solve0 tacs := +match tacs with +| [] => Control.zero Tactic_failure +| tac :: tacs => + Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => first0 tacs)) +end. + +Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. + Ltac2 time0 tac := Control.time None tac. Ltac2 Notation time := time0. @@ -254,3 +280,5 @@ Ltac2 Notation etransitivity := Std.etransitivity (). Ltac2 Notation admit := Std.admit (). Ltac2 Notation clear := Std.keep []. + +Ltac2 Notation refine := Control.refine. -- cgit v1.2.3 From 77e3f7be0533fad2c31eb302a51c74b829f99e8c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Aug 2017 15:54:27 +0200 Subject: Introducing a syntax for goal dispatch. --- src/g_ltac2.ml4 | 20 +++++++++++++++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 4 ++++ src/tac2quote.ml | 9 +++++++++ src/tac2quote.mli | 2 ++ tests/tacticals.v | 12 ++++++++++++ theories/Notations.v | 10 ++++++++++ 9 files changed, 59 insertions(+), 1 deletion(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 695fc7d430..e9d2eb1ca3 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -107,6 +107,7 @@ GEXTEND Gram | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> CTacCse (!@loc, e, bl) ] + | "4" LEFTA [ ] | "::" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> CTacApp (!@loc, CTacCst (!@loc, AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) @@ -309,7 +310,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_rewriting q_clause; + q_rewriting q_clause q_dispatch; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -540,6 +541,23 @@ GEXTEND Gram q_rewriting: [ [ r = oriented_rewriter -> Tac2quote.of_rewriting r ] ] ; + tactic_then_last: + [ [ "|"; lta = LIST0 OPT tac2expr LEVEL "6" SEP "|" -> lta + | -> [] + ] ] + ; + tactic_then_gen: + [ [ ta = tac2expr; "|"; (first,last) = tactic_then_gen -> (Some ta :: first, last) + | ta = tac2expr; ".."; l = tactic_then_last -> ([], Some (Some ta, l)) + | ".."; l = tactic_then_last -> ([], Some (None, l)) + | ta = tac2expr -> ([Some ta], None) + | "|"; (first,last) = tactic_then_gen -> (None :: first, last) + | -> ([None], None) + ] ] + ; + q_dispatch: + [ [ d = tactic_then_gen -> Tac2quote.of_dispatch (Loc.tag ~loc:!@loc d) ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1c03cc410d..b8e50ad1df 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -919,6 +919,7 @@ let () = add_expr_scope "intropatterns" Tac2entries.Pltac.q_intropatterns let () = add_expr_scope "induction_clause" Tac2entries.Pltac.q_induction_clause let () = add_expr_scope "rewriting" Tac2entries.Pltac.q_rewriting let () = add_expr_scope "clause" Tac2entries.Pltac.q_clause +let () = add_expr_scope "dispatch" Tac2entries.Pltac.q_dispatch let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 1dd8410d2a..729779aef2 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -31,6 +31,7 @@ let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" +let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 1fe13cda17..0dd1d5a113 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -64,4 +64,5 @@ val q_intropatterns : raw_tacexpr Pcoq.Gram.entry val q_induction_clause : raw_tacexpr Pcoq.Gram.entry val q_rewriting : raw_tacexpr Pcoq.Gram.entry val q_clause : raw_tacexpr Pcoq.Gram.entry +val q_dispatch : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index d5520c54ee..e2bf10f4e2 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -96,3 +96,7 @@ type rewriting_r = { } type rewriting = rewriting_r located + +type dispatch_r = raw_tacexpr option list * (raw_tacexpr option * raw_tacexpr option list) option + +type dispatch = dispatch_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 57c8a4bbed..73fd7c29c3 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -230,3 +230,12 @@ let of_exact_hyp ?loc id = let loc = Option.default dummy_loc loc in let refine = CTacRef (AbsKn (TacConstant (control_core "refine"))) in CTacApp (loc, refine, [thunk (of_hyp ~loc id)]) + +let of_dispatch tacs = + let loc = Option.default dummy_loc (fst tacs) in + let default = function + | Some e -> thunk e + | None -> thunk (CTacCst (loc, AbsKn (Tuple 0))) + in + let map e = of_pair default (fun l -> of_list ~loc default l) (Loc.tag ~loc e) in + of_pair (fun l -> of_list ~loc default l) (fun r -> of_option ~loc map r) tacs diff --git a/src/tac2quote.mli b/src/tac2quote.mli index dba3c82715..c02493c554 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -52,3 +52,5 @@ val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_dispatch : dispatch -> raw_tacexpr diff --git a/tests/tacticals.v b/tests/tacticals.v index 73f9c03b87..1a2fbcbb37 100644 --- a/tests/tacticals.v +++ b/tests/tacticals.v @@ -20,3 +20,15 @@ first [ | Message.print (Message.of_string "I won't be printed") ]. Qed. + +Goal True /\ True. +Proof. +Fail split > [ split | |]. +split > [split | split]. +Qed. + +Goal True /\ (True -> True) /\ True. +Proof. +split > [ | split] > [split | .. | split]. +intros H; refine &H. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 97f3042d2b..910b6d5463 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -42,6 +42,16 @@ Ltac2 rec repeat0 (t : unit -> unit) := Ltac2 Notation repeat := repeat0. +Ltac2 dispatch0 t ((head, tail)) := + match tail with + | None => Control.enter (fun _ => t (); Control.dispatch head) + | Some tacs => + let ((def, rem)) := tacs in + Control.enter (fun _ => t (); Control.extend head def rem) + end. + +Ltac2 Notation t(thunk(self)) ">" "[" l(dispatch) "]" : 4 := dispatch0 t l. + Ltac2 do0 n t := let rec aux n t := match Int.equal n 0 with | true => () -- cgit v1.2.3 From 7adc34710bf17c4ec3601831275205c1eb613b84 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 12:47:53 +0200 Subject: Trying to enhance the printing of tactic expressions. --- src/tac2print.ml | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/tac2print.ml b/src/tac2print.ml index b679e030fd..e3095c7a89 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -151,14 +151,14 @@ let pr_glbexpr_gen lvl c = | E0 | E1 | E2 | E3 | E4 -> paren | E5 -> fun x -> x in - paren (str "fun" ++ spc () ++ nas ++ spc () ++ str "=>" ++ spc () ++ - hov 0 (pr_glbexpr E5 c)) + paren (hov 0 (hov 2 (str "fun" ++ spc () ++ nas) ++ spc () ++ str "=>" ++ spc () ++ + pr_glbexpr E5 c)) | GTacApp (c, cl) -> let paren = match lvl with | E0 -> paren | E1 | E2 | E3 | E4 | E5 -> fun x -> x in - paren (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) + paren (hov 2 (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) | GTacLet (mut, bnd, e) -> let paren = match lvl with | E0 | E1 | E2 | E3 | E4 -> paren @@ -169,7 +169,7 @@ let pr_glbexpr_gen lvl c = pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () in let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in - paren (str "let" ++ spc () ++ mut ++ bnd ++ str "in" ++ spc () ++ pr_glbexpr E5 e) + paren (hv 0 (hov 2 (str "let" ++ spc () ++ mut ++ bnd ++ str "in") ++ spc () ++ pr_glbexpr E5 e)) | GTacCst (Tuple 0, _, _) -> str "()" | GTacCst (Tuple _, _, cl) -> let paren = match lvl with @@ -192,7 +192,7 @@ let pr_glbexpr_gen lvl c = | [] -> mt () | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl in - paren (pr_constructor kn ++ cl) + paren (hov 2 (pr_constructor kn ++ cl)) | _, GTydRec def -> let args = List.combine def cl in let pr_arg ((id, _, _), arg) = @@ -200,7 +200,7 @@ let pr_glbexpr_gen lvl c = pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg in let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in - str "{" ++ spc () ++ args ++ spc () ++ str "}" + hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") | _, (GTydDef _ | GTydOpn) -> assert false end | GTacCse (e, info, cst_br, ncst_br) -> @@ -219,7 +219,7 @@ let pr_glbexpr_gen lvl c = | [] -> mt () | _ -> spc () ++ pr_sequence pr_name vars in - hov 0 (str "|" ++ spc () ++ cstr ++ vars ++ spc () ++ str "=>" ++ spc () ++ + hov 4 (str "|" ++ spc () ++ hov 0 (cstr ++ vars ++ spc () ++ str "=>") ++ spc () ++ hov 2 (pr_glbexpr E5 p)) ++ spc () in prlist pr_branch br @@ -227,9 +227,9 @@ let pr_glbexpr_gen lvl c = let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in let p = pr_glbexpr E5 p in let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in - str "|" ++ spc () ++ paren vars ++ spc () ++ str "=>" ++ spc () ++ p + hov 4 (str "|" ++ spc () ++ hov 0 (paren vars ++ spc () ++ str "=>") ++ spc () ++ p) in - hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ spc () ++ str "end") | GTacWth wth -> let e = pr_glbexpr E5 wth.opn_match in let pr_pattern c self vars p = @@ -237,7 +237,7 @@ let pr_glbexpr_gen lvl c = | Anonymous -> mt () | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id in - hov 0 (str "|" ++ spc () ++ c ++ vars ++ self ++ spc () ++ str "=>" ++ spc () ++ + hov 4 (str "|" ++ spc () ++ hov 0 (c ++ vars ++ self ++ spc () ++ str "=>") ++ spc () ++ hov 2 (pr_glbexpr E5 p)) ++ spc () in let pr_branch (cstr, (self, vars, p)) = @@ -252,7 +252,7 @@ let pr_glbexpr_gen lvl c = let (def_as, def_p) = wth.opn_default in let def = pr_pattern (str "_") def_as (mt ()) def_p in let br = br ++ def in - hov 0 (hov 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ Pp.v 0 br ++ str "end") + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ str "end") | GTacPrj (kn, e, n) -> let def = match Tac2env.interp_type kn with | _, GTydRec def -> def @@ -262,7 +262,7 @@ let pr_glbexpr_gen lvl c = let proj = change_kn_label kn proj in let proj = pr_projection proj in let e = pr_glbexpr E0 e in - e ++ str "." ++ paren proj + hov 0 (e ++ str "." ++ paren proj) | GTacSet (kn, e, n, r) -> let def = match Tac2env.interp_type kn with | _, GTydRec def -> def @@ -273,28 +273,28 @@ let pr_glbexpr_gen lvl c = let proj = pr_projection proj in let e = pr_glbexpr E0 e in let r = pr_glbexpr E1 r in - e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r + hov 0 (e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r) | GTacOpn (kn, cl) -> let paren = match lvl with | E0 -> paren | E1 | E2 | E3 | E4 | E5 -> fun x -> x in let c = pr_constructor kn in - paren (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl)) + paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) | GTacExt arg -> let GenArg (Glbwit tag, arg) = arg in let name = match tag with | ExtraArg tag -> ArgT.repr tag | _ -> assert false in - str name ++ str ":" ++ paren (Genprint.glb_print tag arg) + hov 0 (str name ++ str ":" ++ paren (Genprint.glb_print tag arg)) | GTacPrm (prm, args) -> let args = match args with | [] -> mt () | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args in - str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ - qstring prm.mltac_tactic ++ args + hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ + qstring prm.mltac_tactic ++ args) in hov 0 (pr_glbexpr lvl c) -- cgit v1.2.3 From 900841d0bb4700fb2a3662457e7c4efea34a97e4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 13:47:36 +0200 Subject: Exporting scopes for occurrences. --- src/g_ltac2.ml4 | 15 +++++++++------ src/tac2core.ml | 2 ++ src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 4 +++- src/tac2quote.ml | 6 +++--- src/tac2quote.mli | 2 ++ 7 files changed, 21 insertions(+), 10 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index e9d2eb1ca3..e3d48f75ca 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -310,7 +310,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_rewriting q_clause q_dispatch; + q_rewriting q_clause q_dispatch q_occurrences; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -449,13 +449,13 @@ GEXTEND Gram ] ] ; occs_nums: - [ [ nl = LIST1 nat_or_anti -> QOnlyOccurrences nl + [ [ nl = LIST1 nat_or_anti -> Loc.tag ~loc:!@loc @@ QOnlyOccurrences nl | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> - QAllOccurrencesBut (n::nl) + Loc.tag ~loc:!@loc @@ QAllOccurrencesBut (n::nl) ] ] ; occs: - [ [ "at"; occs = occs_nums -> occs | -> QAllOccurrences ] ] + [ [ "at"; occs = occs_nums -> occs | -> Loc.tag ~loc:!@loc QAllOccurrences ] ] ; hypident: [ [ id = ident_or_anti -> @@ -477,7 +477,7 @@ GEXTEND Gram | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> { q_onhyps = Some hl; q_concl_occs = occs } | hl = LIST0 hypident_occ SEP "," -> - { q_onhyps = Some hl; q_concl_occs = QNoOccurrences } + { q_onhyps = Some hl; q_concl_occs = Loc.tag ~loc:!@loc QNoOccurrences } ] ] ; clause: @@ -491,7 +491,7 @@ GEXTEND Gram ; concl_occ: [ [ "*"; occs = occs -> occs - | -> QNoOccurrences + | -> Loc.tag ~loc:!@loc QNoOccurrences ] ] ; induction_clause: @@ -558,6 +558,9 @@ GEXTEND Gram q_dispatch: [ [ d = tactic_then_gen -> Tac2quote.of_dispatch (Loc.tag ~loc:!@loc d) ] ] ; + q_occurrences: + [ [ occs = occs -> Tac2quote.of_occurrences occs ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index b8e50ad1df..3ce2ed53a8 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -919,10 +919,12 @@ let () = add_expr_scope "intropatterns" Tac2entries.Pltac.q_intropatterns let () = add_expr_scope "induction_clause" Tac2entries.Pltac.q_induction_clause let () = add_expr_scope "rewriting" Tac2entries.Pltac.q_rewriting let () = add_expr_scope "clause" Tac2entries.Pltac.q_clause +let () = add_expr_scope "occurrences" Tac2entries.Pltac.q_occurrences let () = add_expr_scope "dispatch" Tac2entries.Pltac.q_dispatch let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr +let () = add_generic_scope "pattern" Pcoq.Constr.constr wit_pattern (** seq scope, a bit hairy *) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 729779aef2..2490f6534b 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -32,6 +32,7 @@ let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" +let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 0dd1d5a113..cf6cdfa74b 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -65,4 +65,5 @@ val q_induction_clause : raw_tacexpr Pcoq.Gram.entry val q_rewriting : raw_tacexpr Pcoq.Gram.entry val q_clause : raw_tacexpr Pcoq.Gram.entry val q_dispatch : raw_tacexpr Pcoq.Gram.entry +val q_occurrences : raw_tacexpr Pcoq.Gram.entry end diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index e2bf10f4e2..a631ffd188 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -52,12 +52,14 @@ and intro_pattern_naming = intro_pattern_naming_r located and intro_pattern_action = intro_pattern_action_r located and or_and_intro_pattern = or_and_intro_pattern_r located -type occurrences = +type occurrences_r = | QAllOccurrences | QAllOccurrencesBut of int located or_anti list | QNoOccurrences | QOnlyOccurrences of int located or_anti list +type occurrences = occurrences_r located + type hyp_location = (occurrences * Id.t located or_anti) * Locus.hyp_location_flag type clause_r = diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 73fd7c29c3..b3d174dc2d 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -149,7 +149,7 @@ let of_hyp_location_flag ?loc = function | Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] | Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] -let of_occurrences ?loc occ = match occ with +let of_occurrences (loc, occ) = match occ with | QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] | QAllOccurrencesBut occs -> let map occ = of_anti of_int occ in @@ -164,14 +164,14 @@ let of_occurrences ?loc occ = match occ with let of_hyp_location ?loc ((occs, id), flag) = of_tuple ?loc [ of_anti of_ident id; - of_occurrences ?loc occs; + of_occurrences occs; of_hyp_location_flag ?loc flag; ] let of_clause (loc, cl) = let loc = Option.default dummy_loc loc in let hyps = of_option ~loc (fun l -> of_list ~loc of_hyp_location l) cl.q_onhyps in - let concl = of_occurrences ~loc cl.q_concl_occs in + let concl = of_occurrences cl.q_concl_occs in CTacRec (loc, [ std_proj "on_hyps", hyps; std_proj "on_concl", concl; diff --git a/src/tac2quote.mli b/src/tac2quote.mli index c02493c554..4e563990be 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -47,6 +47,8 @@ val of_induction_clause : induction_clause -> raw_tacexpr val of_rewriting : rewriting -> raw_tacexpr +val of_occurrences : occurrences -> raw_tacexpr + val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) -- cgit v1.2.3 From 62ea702ac88c2762a6587b7b7c95f8f917cedd1c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 14:40:08 +0200 Subject: Notations for a few reduction functions. --- tests/example2.v | 34 ++++++++++++++++++++++++++++++++++ theories/Notations.v | 18 ++++++++++++++++++ 2 files changed, 52 insertions(+) diff --git a/tests/example2.v b/tests/example2.v index bfb1b07e7a..1856663953 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -123,3 +123,37 @@ intros n r. hnf in r. split. Qed. + +Goal 1 = 0 -> 0 = 0. +Proof. +intros H. +pattern 0 at 1. +let occ := 2 in pattern 1 at 1, 0 at $occ in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +vm_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +native_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2 - 0 -> True. +Proof. +intros H. +vm_compute plus in H. +reflexivity. +Qed. + +Goal 1 = 0 -> True /\ True. +Proof. +intros H. +split; fold (1 + 0) (1 + 0) in H. +reflexivity. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 910b6d5463..8c2c09a2b5 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -257,6 +257,24 @@ Ltac2 Notation "hnf" cl(opt(clause)) := Std.hnf (default_on_concl cl). Ltac2 Notation hnf := hnf. +Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.vm pl (default_on_concl cl). +Ltac2 Notation vm_compute := vm_compute. + +Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.native pl (default_on_concl cl). +Ltac2 Notation native_compute := native_compute. + +Ltac2 fold0 pl cl := + let cl := default_on_concl cl in + Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). + +Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := + fold0 pl cl. + +Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := + Std.pattern pl (default_on_concl cl). + Ltac2 rewrite0 ev rw cl tac := let tac := match tac with | None => None -- cgit v1.2.3 From f392ad50331d3e59d3e2f3ec66c0a42112506d7f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 16:48:00 +0200 Subject: Laxer dependencies between file and link reordering. --- _CoqProject | 4 ++-- src/ltac2_plugin.mlpack | 2 +- src/tac2core.ml | 4 ---- src/tac2core.mli | 4 ---- src/tac2quote.ml | 15 ++++++--------- 5 files changed, 9 insertions(+), 20 deletions(-) diff --git a/_CoqProject b/_CoqProject index f202e1aed2..4116d17554 100644 --- a/_CoqProject +++ b/_CoqProject @@ -15,11 +15,11 @@ src/tac2entries.ml src/tac2entries.mli src/tac2ffi.ml src/tac2ffi.mli -src/tac2core.ml -src/tac2core.mli src/tac2qexpr.mli src/tac2quote.ml src/tac2quote.mli +src/tac2core.ml +src/tac2core.mli src/tac2tactics.ml src/tac2tactics.mli src/tac2stdlib.ml diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 4c4082ad65..f9fa2fafd8 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -4,8 +4,8 @@ Tac2intern Tac2interp Tac2entries Tac2ffi -Tac2core Tac2quote +Tac2core Tac2tactics Tac2stdlib G_ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml index 3ce2ed53a8..bf41713215 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -45,10 +45,6 @@ let c_some = coq_core "Some" let c_true = coq_core "true" let c_false = coq_core "false" -let t_qhyp = std_core "hypothesis" -let c_named_hyp = std_core "NamedHyp" -let c_anon_hyp = std_core "AnonHyp" - end open Core diff --git a/src/tac2core.mli b/src/tac2core.mli index 6fd48e85f7..d9ed8ea2e5 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -27,8 +27,4 @@ val t_array : type_constant val c_true : ltac_constructor val c_false : ltac_constructor -val t_qhyp : type_constant -val c_anon_hyp : ltac_constructor -val c_named_hyp : ltac_constructor - end diff --git a/src/tac2quote.ml b/src/tac2quote.ml index b3d174dc2d..8adeb15d20 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -9,18 +9,15 @@ open Pp open Names open Util -open Misctypes -open Tac2intern open Tac2expr open Tac2qexpr -open Tac2core (** Syntactic quoting of expressions. *) let control_prefix = MPfile (DirPath.make (List.map Id.of_string ["Control"; "Ltac2"])) -let kername prefix n = KerName.make2 prefix (Label.of_id (Id.of_string n)) +let kername prefix n = KerName.make2 prefix (Label.of_id (Id.of_string_soft n)) let std_core n = kername Tac2env.std_prefix n let coq_core n = kername Tac2env.coq_prefix n let control_core n = kername control_prefix n @@ -86,17 +83,17 @@ let of_open_constr c = inj_wit ?loc Stdarg.wit_open_constr c let of_bool ?loc b = - let c = if b then Core.c_true else Core.c_false in + let c = if b then coq_core "true" else coq_core "false" in constructor ?loc c [] let rec of_list ?loc f = function -| [] -> constructor Core.c_nil [] +| [] -> constructor (coq_core "[]") [] | e :: l -> - constructor ?loc Core.c_cons [f e; of_list ?loc f l] + constructor ?loc (coq_core "::") [f e; of_list ?loc f l] let of_qhyp (loc, h) = match h with -| QAnonHyp n -> constructor ?loc Core.c_anon_hyp [of_int n] -| QNamedHyp id -> constructor ?loc Core.c_named_hyp [of_ident id] +| QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] +| QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] let of_bindings (loc, b) = match b with | QNoBindings -> -- cgit v1.2.3 From 33f7df93bb686077b9ca164078763c2208cbe3d5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 17:03:37 +0200 Subject: Removing dead code. --- src/tac2core.ml | 1 - src/tac2core.mli | 2 -- src/tac2intern.ml | 1 - src/tac2intern.mli | 1 - src/tac2interp.mli | 1 - src/tac2print.mli | 2 -- src/tac2qexpr.mli | 1 - src/tac2quote.mli | 1 - src/tac2stdlib.ml | 8 -------- src/tac2tactics.ml | 4 ---- 10 files changed, 22 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index bf41713215..0415b6f15f 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -21,7 +21,6 @@ open Proofview.Notations module Value = Tac2ffi let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) -let std_core n = KerName.make2 Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) module Core = struct diff --git a/src/tac2core.mli b/src/tac2core.mli index d9ed8ea2e5..566b7efbb7 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names -open Tac2env open Tac2expr (** {5 Hardwired data} *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index bf7e93cb9e..b62a574a6c 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -24,7 +24,6 @@ let coq_type n = KerName.make2 Tac2env.coq_prefix (Label.make n) let t_int = coq_type "int" let t_string = coq_type "string" let t_array = coq_type "array" -let t_unit = coq_type "unit" let t_list = coq_type "list" let c_nil = GTacCst (Other t_list, 0, []) diff --git a/src/tac2intern.mli b/src/tac2intern.mli index ddec8eb7e4..898df649ba 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Genarg open Names open Mod_subst open Tac2expr diff --git a/src/tac2interp.mli b/src/tac2interp.mli index bf6b2d4dde..42e9e3adeb 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Genarg open Names open Tac2expr diff --git a/src/tac2print.mli b/src/tac2print.mli index 2ee5cf42e0..0a04af2ff0 100644 --- a/src/tac2print.mli +++ b/src/tac2print.mli @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp -open Names open Tac2expr (** {5 Printing types} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index a631ffd188..2e7fc7b44a 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Loc open Names open Tac2expr diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 4e563990be..456d1fa97d 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -8,7 +8,6 @@ open Loc open Names -open Misctypes open Tac2qexpr open Tac2expr diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 3cfd0b5626..e3b0d6bf6b 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -11,8 +11,6 @@ open Locus open Misctypes open Genredexpr open Tac2expr -open Tac2core -open Tac2tactics open Proofview.Notations module Value = Tac2ffi @@ -169,12 +167,6 @@ let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } let lift tac = tac <*> return v_unit -let wrap f = - return () >>= fun () -> return (f ()) - -let wrap_unit f = - return () >>= fun () -> f (); return v_unit - let define_prim0 name tac = let tac = function | [_] -> lift tac diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 50c1df922e..7fdda1f17d 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -12,11 +12,7 @@ open Globnames open Misctypes open Tactypes open Genredexpr -open Tactics open Proofview -open Tacmach.New -open Tacticals.New -open Proofview.Notations (** FIXME: export a better interface in Tactics *) let delayed_of_tactic tac env sigma = -- cgit v1.2.3 From 0b2c0e58b45b2e78f8ad65ddbc7254e1fd9d07eb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 17:07:14 +0200 Subject: More precise type for quotation entries. --- src/g_ltac2.ml4 | 18 +++++++++--------- src/tac2core.ml | 41 ++++++++++++++--------------------------- src/tac2entries.mli | 24 +++++++++++++----------- 3 files changed, 36 insertions(+), 47 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index e3d48f75ca..e5847119e1 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -326,7 +326,7 @@ GEXTEND Gram [ [ n = Prim.natural -> Loc.tag ~loc:!@loc n ] ] ; q_ident: - [ [ id = ident_or_anti -> Tac2quote.of_anti Tac2quote.of_ident id ] ] + [ [ id = ident_or_anti -> id ] ] ; qhyp: [ [ x = anti -> x @@ -347,7 +347,7 @@ GEXTEND Gram ] ] ; q_bindings: - [ [ bl = with_bindings -> Tac2quote.of_bindings bl ] ] + [ [ bl = with_bindings -> bl ] ] ; intropatterns: [ [ l = LIST0 nonsimple_intropattern -> Loc.tag ~loc:!@loc l ]] @@ -417,10 +417,10 @@ GEXTEND Gram ] ] ; q_intropatterns: - [ [ ipat = intropatterns -> Tac2quote.of_intro_patterns ipat ] ] + [ [ ipat = intropatterns -> ipat ] ] ; q_intropattern: - [ [ ipat = simple_intropattern -> Tac2quote.of_intro_pattern ipat ] ] + [ [ ipat = simple_intropattern -> ipat ] ] ; nat_or_anti: [ [ n = lnatural -> QExpr n @@ -487,7 +487,7 @@ GEXTEND Gram ] ] ; q_clause: - [ [ cl = clause -> Tac2quote.of_clause cl ] ] + [ [ cl = clause -> cl ] ] ; concl_occ: [ [ "*"; occs = occs -> occs @@ -506,7 +506,7 @@ GEXTEND Gram ] ] ; q_induction_clause: - [ [ cl = induction_clause -> Tac2quote.of_induction_clause cl ] ] + [ [ cl = induction_clause -> cl ] ] ; orient: [ [ "->" -> Loc.tag ~loc:!@loc (Some true) @@ -539,7 +539,7 @@ GEXTEND Gram ] ] ; q_rewriting: - [ [ r = oriented_rewriter -> Tac2quote.of_rewriting r ] ] + [ [ r = oriented_rewriter -> r ] ] ; tactic_then_last: [ [ "|"; lta = LIST0 OPT tac2expr LEVEL "6" SEP "|" -> lta @@ -556,10 +556,10 @@ GEXTEND Gram ] ] ; q_dispatch: - [ [ d = tactic_then_gen -> Tac2quote.of_dispatch (Loc.tag ~loc:!@loc d) ] ] + [ [ d = tactic_then_gen -> Loc.tag ~loc:!@loc d ] ] ; q_occurrences: - [ [ occs = occs -> Tac2quote.of_occurrences occs ] ] + [ [ occs = occs -> occs ] ] ; END diff --git a/src/tac2core.ml b/src/tac2core.ml index 0415b6f15f..bec1761120 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -14,6 +14,7 @@ open Geninterp open Tac2env open Tac2expr open Tac2interp +open Tac2entries.Pltac open Proofview.Notations (** Standard values *) @@ -868,20 +869,12 @@ end let () = add_scope "tactic" begin function | [] -> (** Default to level 5 parsing *) - let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, 5) in + let scope = Extend.Aentryl (tac2expr, 5) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt (loc, n)] -> let () = if n < 0 || n > 6 then scope_fail () in - let scope = Extend.Aentryl (Tac2entries.Pltac.tac2expr, n) in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let () = add_scope "ident" begin function -| [] -> - let scope = Extend.Aentry Tac2entries.Pltac.q_ident in + let scope = Extend.Aentryl (tac2expr, n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () @@ -895,27 +888,21 @@ let () = add_scope "thunk" begin function | _ -> scope_fail () end -let () = add_scope "bindings" begin function -| [] -> - let scope = Extend.Aentry Tac2entries.Pltac.q_bindings in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () -end - -let add_expr_scope name entry = +let add_expr_scope name entry f = add_scope name begin function - | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, (fun e -> e)) + | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) | _ -> scope_fail () end -let () = add_expr_scope "intropattern" Tac2entries.Pltac.q_intropattern -let () = add_expr_scope "intropatterns" Tac2entries.Pltac.q_intropatterns -let () = add_expr_scope "induction_clause" Tac2entries.Pltac.q_induction_clause -let () = add_expr_scope "rewriting" Tac2entries.Pltac.q_rewriting -let () = add_expr_scope "clause" Tac2entries.Pltac.q_clause -let () = add_expr_scope "occurrences" Tac2entries.Pltac.q_occurrences -let () = add_expr_scope "dispatch" Tac2entries.Pltac.q_dispatch +let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) +let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings +let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern +let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns +let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause +let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting +let () = add_expr_scope "clause" q_clause Tac2quote.of_clause +let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences +let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.mli b/src/tac2entries.mli index cf6cdfa74b..667378030a 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -55,15 +55,17 @@ module Pltac : sig val tac2expr : raw_tacexpr Pcoq.Gram.entry -(** Quoted entries. They directly return an Ltac2 expression *) - -val q_ident : raw_tacexpr Pcoq.Gram.entry -val q_bindings : raw_tacexpr Pcoq.Gram.entry -val q_intropattern : raw_tacexpr Pcoq.Gram.entry -val q_intropatterns : raw_tacexpr Pcoq.Gram.entry -val q_induction_clause : raw_tacexpr Pcoq.Gram.entry -val q_rewriting : raw_tacexpr Pcoq.Gram.entry -val q_clause : raw_tacexpr Pcoq.Gram.entry -val q_dispatch : raw_tacexpr Pcoq.Gram.entry -val q_occurrences : raw_tacexpr Pcoq.Gram.entry +(** Quoted entries. To be used for complex notations. *) + +open Tac2qexpr + +val q_ident : Id.t located or_anti Pcoq.Gram.entry +val q_bindings : bindings Pcoq.Gram.entry +val q_intropattern : intro_pattern Pcoq.Gram.entry +val q_intropatterns : intro_pattern list located Pcoq.Gram.entry +val q_induction_clause : induction_clause Pcoq.Gram.entry +val q_rewriting : rewriting Pcoq.Gram.entry +val q_clause : clause Pcoq.Gram.entry +val q_dispatch : dispatch Pcoq.Gram.entry +val q_occurrences : occurrences Pcoq.Gram.entry end -- cgit v1.2.3 From 0232b0de849998d3394a4e6a2ab6232a75897610 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Aug 2017 17:59:49 +0200 Subject: Use references in reduction tactics. We dynamically check that the provided references are indeed evaluable ones, instead of ensuring this at internalization time. --- src/tac2stdlib.ml | 24 ++++++++++++------------ src/tac2tactics.ml | 34 ++++++++++++++++++++++++++++++++++ src/tac2tactics.mli | 11 ++++++++++- theories/Std.v | 12 +++++++----- 4 files changed, 63 insertions(+), 18 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index e3b0d6bf6b..d3430213b4 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -8,6 +8,7 @@ open Names open Locus +open Globnames open Misctypes open Genredexpr open Tac2expr @@ -70,9 +71,11 @@ let to_clause = function { onhyps = hyps; concl_occs = to_occurrences to_int_or_var concl; } | _ -> assert false -let to_evaluable_ref = function -| ValBlk (0, [| id |]) -> EvalVarRef (Value.to_ident id) -| ValBlk (1, [| cst |]) -> EvalConstRef (Value.to_constant cst) +let to_reference = function +| ValBlk (0, [| id |]) -> VarRef (Value.to_ident id) +| ValBlk (1, [| cst |]) -> ConstRef (Value.to_constant cst) +| ValBlk (2, [| ind |]) -> IndRef (Value.to_ext Value.val_inductive ind) +| ValBlk (3, [| cstr |]) -> ConstructRef (Value.to_ext Value.val_constructor cstr) | _ -> assert false let to_red_flag = function @@ -84,7 +87,7 @@ let to_red_flag = function rCofix = Value.to_bool cofix; rZeta = Value.to_bool zeta; rDelta = Value.to_bool delta; - rConst = Value.to_list to_evaluable_ref const; + rConst = Value.to_list to_reference const; } | _ -> assert false @@ -310,29 +313,26 @@ end let () = define_prim2 "tac_cbv" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in - Tactics.reduce (Cbv flags) cl + Tac2tactics.cbv flags cl end let () = define_prim2 "tac_cbn" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in - Tactics.reduce (Cbn flags) cl + Tac2tactics.cbn flags cl end let () = define_prim2 "tac_lazy" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in - Tactics.reduce (Lazy flags) cl + Tac2tactics.lazy_ flags cl end let () = define_prim2 "tac_unfold" begin fun refs cl -> - let map v = - let (ref, occ) = to_pair to_evaluable_ref (fun occ -> to_occurrences to_int_or_var occ) v in - (occ, ref) - in + let map v = to_pair to_reference (fun occ -> to_occurrences to_int_or_var occ) v in let refs = Value.to_list map refs in let cl = to_clause cl in - Tactics.reduce (Unfold refs) cl + Tac2tactics.unfold refs cl end let () = define_prim2 "tac_fold" begin fun args cl -> diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 7fdda1f17d..2f4965783f 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Pp open Util open Names open Globnames @@ -13,6 +14,7 @@ open Misctypes open Tactypes open Genredexpr open Proofview +open Proofview.Notations (** FIXME: export a better interface in Tactics *) let delayed_of_tactic tac env sigma = @@ -67,10 +69,42 @@ let map_pattern_with_occs (pat, occ) = match pat with | Pattern.PRef (VarRef id) -> (occ, Inl (EvalVarRef id)) | _ -> (occ, Inr pat) +let get_evaluable_reference = function +| VarRef id -> Proofview.tclUNIT (EvalVarRef id) +| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| r -> + Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ + Nametab.pr_global_env Id.Set.empty r ++ spc () ++ + str "to an evaluable reference.") + let simpl flags where cl = let where = Option.map map_pattern_with_occs where in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in Tactics.reduce (Simpl (flags, where)) cl +let cbv flags cl = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbv flags) cl + +let cbn flags cl = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbn flags) cl + +let lazy_ flags cl = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Lazy flags) cl + +let unfold occs cl = + let map (gr, occ) = + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + Tactics.reduce (Unfold occs) cl + let vm where cl = let where = Option.map map_pattern_with_occs where in Tactics.reduce (CbvVm where) cl diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index affbbbbdd7..d835f768a1 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -8,6 +8,7 @@ open Names open Locus +open Globnames open Genredexpr open Misctypes open Tactypes @@ -36,9 +37,17 @@ type rewriting = val rewrite : evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic -val simpl : evaluable_global_reference glob_red_flag -> +val simpl : global_reference glob_red_flag -> (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic +val cbv : global_reference glob_red_flag -> clause -> unit tactic + +val cbn : global_reference glob_red_flag -> clause -> unit tactic + +val lazy_ : global_reference glob_red_flag -> clause -> unit tactic + +val unfold : (global_reference * occurrences_expr) list -> clause -> unit tactic + val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic diff --git a/theories/Std.v b/theories/Std.v index 43ccb06192..dd81835c40 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -34,9 +34,11 @@ Ltac2 Type clause := { on_concl : occurrences; }. -Ltac2 Type evaluable_reference := [ -| EvalVarRef (ident) -| EvalConstRef (constant) +Ltac2 Type reference := [ +| VarRef (ident) +| ConstRef (constant) +| IndRef (inductive) +| ConstructRef (constructor) ]. Ltac2 Type red_flags := { @@ -46,7 +48,7 @@ Ltac2 Type red_flags := { rCofix : bool; rZeta : bool; rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) - rConst : evaluable_reference list + rConst : reference list }. Ltac2 Type 'a not_implemented. @@ -134,7 +136,7 @@ Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause - Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". -Ltac2 @ external unfold : (evaluable_reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". +Ltac2 @ external unfold : (reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". -- cgit v1.2.3 From 7d496e618f35a17b8432ac3c7205138f03c95fd2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 14:58:46 +0200 Subject: Introducing a quotation for global references. --- doc/ltac2.md | 4 ++++ src/g_ltac2.ml4 | 7 +++++++ src/tac2core.ml | 33 ++++++++++++++++++++++++++++++--- src/tac2env.ml | 5 +++-- src/tac2env.mli | 9 +++++++-- src/tac2ffi.ml | 14 ++++++++++++++ src/tac2ffi.mli | 3 +++ src/tac2interp.ml | 2 +- src/tac2stdlib.ml | 11 ++--------- tests/quot.v | 9 +++++++++ 10 files changed, 80 insertions(+), 17 deletions(-) create mode 100644 tests/quot.v diff --git a/doc/ltac2.md b/doc/ltac2.md index b3596b2977..6c4912c8f3 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -437,6 +437,10 @@ The current implementation recognizes the following built-in quotations: holes at runtime (type `Init.constr` as well). - "pattern", which parses Coq patterns and produces a pattern used for term matching (type `Init.pattern`). +- "reference", which parses either a `QUALID` or `"&" IDENT`. Qualified names + are globalized at internalization into the corresponding global reference, + while `&id` is turned into `Std.VarRef id`. This produces at runtime a + `Std.reference`. The following syntactic sugar is provided for two common cases. - `@id` is the same as ident:(id) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index e5847119e1..c70f1e882d 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -65,6 +65,7 @@ let tac2mode = Gram.entry_create "vernac:ltac2_command" let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c +let inj_reference loc c = inj_wit Tac2env.wit_reference loc c let pattern_of_qualid loc id = if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) @@ -157,6 +158,7 @@ GEXTEND Gram | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_open_constr c | IDENT "ident"; ":"; "("; c = lident; ")" -> Tac2quote.of_ident c | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> inj_pattern !@loc c + | IDENT "reference"; ":"; "("; c = globref; ")" -> inj_reference !@loc c ] ] ; let_clause: @@ -300,6 +302,11 @@ GEXTEND Gram lident: [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] ; + globref: + [ [ "&"; id = Prim.ident -> Libnames.Ident (Loc.tag ~loc:!@loc id) + | qid = Prim.qualid -> Libnames.Qualid qid + ] ] + ; END (** Quotation scopes used by notations *) diff --git a/src/tac2core.ml b/src/tac2core.ml index bec1761120..303d62a30d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -689,7 +689,7 @@ let interp_constr flags ist (c, _) = Proofview.V82.wrap_exceptions begin fun () -> let ist = to_lvar ist in let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = Val.Dyn (Value.val_constr, c) in + let c = ValExt (Val.Dyn (Value.val_constr, c)) in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c end @@ -712,7 +712,7 @@ let () = define_ml_object Stdarg.wit_open_constr obj let () = - let interp _ id = return (Val.Dyn (Value.val_ident, id)) in + let interp _ id = return (ValExt (Val.Dyn (Value.val_ident, id))) in let obj = { ml_type = t_ident; ml_interp = interp; @@ -720,13 +720,21 @@ let () = define_ml_object Stdarg.wit_ident obj let () = - let interp _ c = return (Val.Dyn (Value.val_pattern, c)) in + let interp _ c = return (ValExt (Val.Dyn (Value.val_pattern, c))) in let obj = { ml_type = t_pattern; ml_interp = interp; } in define_ml_object Tac2env.wit_pattern obj +let () = + let interp _ gr = return (Value.of_reference gr) in + let obj = { + ml_type = t_pattern; + ml_interp = interp; + } in + define_ml_object Tac2env.wit_reference obj + let () = let interp ist env sigma concl tac = let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = @@ -754,6 +762,25 @@ let () = let subst s c = Patternops.subst_pattern s c in Genintern.register_subst0 wit_pattern subst +(** References *) + +let () = + let intern ist qid = match qid with + | Libnames.Ident (_, id) -> ist, Globnames.VarRef id + | Libnames.Qualid (loc, qid) -> + let gr = + try Nametab.locate qid + with Not_found -> + Nametab.error_global_not_found ?loc qid + in + ist, gr + in + Genintern.register_intern0 wit_reference intern + +let () = + let subst s c = Globnames.subst_global_reference s c in + Genintern.register_subst0 wit_reference subst + (** Built-in notation scopes *) let add_scope s f = diff --git a/src/tac2env.ml b/src/tac2env.ml index ac2bd5fc23..65276ec57f 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -246,7 +246,7 @@ let shortest_qualid_of_projection kn = type 'a ml_object = { ml_type : type_constant; - ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; + ml_interp : environment -> 'a -> valexpr Proofview.tactic; } module MLTypeObj = @@ -271,8 +271,9 @@ let std_prefix = (** Generic arguments *) -let wit_ltac2 = Genarg.make0 "ltac2" +let wit_ltac2 = Genarg.make0 "ltac2:value" let wit_pattern = Genarg.make0 "ltac2:pattern" +let wit_reference = Genarg.make0 "ltac2:reference" let is_constructor qid = let (_, id) = repr_qualid qid in diff --git a/src/tac2env.mli b/src/tac2env.mli index e4cc8387c5..20bf24d19d 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -100,7 +100,7 @@ val interp_primitive : ml_tactic_name -> ml_tactic type 'a ml_object = { ml_type : type_constant; - ml_interp : environment -> 'a -> Geninterp.Val.t Proofview.tactic; + ml_interp : environment -> 'a -> valexpr Proofview.tactic; } val define_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object -> unit @@ -118,7 +118,12 @@ val std_prefix : ModPath.t val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type -val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern, Pattern.constr_pattern) genarg_type +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern, Util.Empty.t) genarg_type + +val wit_reference : (reference, Globnames.global_reference, Util.Empty.t) genarg_type +(** Beware, at the raw level, [Qualid [id]] has not the same meaning as + [Ident id]. The first is an unqualified global reference, the second is + the dynamic reference to id. *) (** {5 Helper functions} *) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 49b49d92fd..b506a578b1 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -7,6 +7,7 @@ (************************************************************************) open Util +open Globnames open Genarg open Geninterp open Tac2expr @@ -125,3 +126,16 @@ let to_array f = function let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c + +let of_reference = function +| VarRef id -> ValBlk (0, [| of_ident id |]) +| ConstRef cst -> ValBlk (1, [| of_constant cst |]) +| IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) +| ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) + +let to_reference = function +| ValBlk (0, [| id |]) -> VarRef (to_ident id) +| ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) +| ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) +| ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) +| _ -> assert false diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index b69ca9a382..71d90ba940 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -62,6 +62,9 @@ val to_pp : valexpr -> Pp.t val of_constant : Constant.t -> valexpr val to_constant : valexpr -> Constant.t +val of_reference : Globnames.global_reference -> valexpr +val to_reference : valexpr -> Globnames.global_reference + val of_ext : 'a Val.typ -> 'a -> valexpr val to_ext : 'a Val.typ -> valexpr -> 'a diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 664b7de3d6..d3bc79957b 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -105,7 +105,7 @@ let rec interp ist = function | GTacExt e -> let GenArg (Glbwit tag, e) = e in let tpe = Tac2env.interp_ml_object tag in - tpe.Tac2env.ml_interp ist e >>= fun e -> return (ValExt e) + tpe.Tac2env.ml_interp ist e and interp_app f args = match f with | ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index d3430213b4..eccaf95ab3 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -71,13 +71,6 @@ let to_clause = function { onhyps = hyps; concl_occs = to_occurrences to_int_or_var concl; } | _ -> assert false -let to_reference = function -| ValBlk (0, [| id |]) -> VarRef (Value.to_ident id) -| ValBlk (1, [| cst |]) -> ConstRef (Value.to_constant cst) -| ValBlk (2, [| ind |]) -> IndRef (Value.to_ext Value.val_inductive ind) -| ValBlk (3, [| cstr |]) -> ConstructRef (Value.to_ext Value.val_constructor cstr) -| _ -> assert false - let to_red_flag = function | ValBlk (0, [| beta; iota; fix; cofix; zeta; delta; const |]) -> { @@ -87,7 +80,7 @@ let to_red_flag = function rCofix = Value.to_bool cofix; rZeta = Value.to_bool zeta; rDelta = Value.to_bool delta; - rConst = Value.to_list to_reference const; + rConst = Value.to_list Value.to_reference const; } | _ -> assert false @@ -329,7 +322,7 @@ let () = define_prim2 "tac_lazy" begin fun flags cl -> end let () = define_prim2 "tac_unfold" begin fun refs cl -> - let map v = to_pair to_reference (fun occ -> to_occurrences to_int_or_var occ) v in + let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in let refs = Value.to_list map refs in let cl = to_clause cl in Tac2tactics.unfold refs cl diff --git a/tests/quot.v b/tests/quot.v new file mode 100644 index 0000000000..c9aa1f9d14 --- /dev/null +++ b/tests/quot.v @@ -0,0 +1,9 @@ +Require Import Ltac2.Ltac2. + +(** Test for quotations *) + +Ltac2 ref0 () := reference:(&x). +Ltac2 ref1 () := reference:(nat). +Ltac2 ref2 () := reference:(Datatypes.nat). +Fail Ltac2 ref () := reference:(i_certainly_dont_exist). +Fail Ltac2 ref () := reference:(And.Me.neither). -- cgit v1.2.3 From d61047ba240741b9f92ec03e7026deba79ea7b70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 15:48:14 +0200 Subject: Adding a scope for reduction flags. --- src/g_ltac2.ml4 | 37 ++++++++++++++++++++++++++++++++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 14 ++++++++++++++ src/tac2quote.ml | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2quote.mli | 2 ++ 7 files changed, 105 insertions(+), 1 deletion(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index c70f1e882d..ef3615db89 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -317,7 +317,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_rewriting q_clause q_dispatch q_occurrences; + q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -568,6 +568,41 @@ GEXTEND Gram q_occurrences: [ [ occs = occs -> occs ] ] ; + red_flag: + [ [ IDENT "beta" -> Loc.tag ~loc:!@loc @@ QBeta + | IDENT "iota" -> Loc.tag ~loc:!@loc @@ QIota + | IDENT "match" -> Loc.tag ~loc:!@loc @@ QMatch + | IDENT "fix" -> Loc.tag ~loc:!@loc @@ QFix + | IDENT "cofix" -> Loc.tag ~loc:!@loc @@ QCofix + | IDENT "zeta" -> Loc.tag ~loc:!@loc @@ QZeta + | IDENT "delta"; d = delta_flag -> d + ] ] + ; + refglobal: + [ [ "&"; id = Prim.ident -> QExpr (Libnames.Ident (Loc.tag ~loc:!@loc id)) + | qid = Prim.qualid -> QExpr (Libnames.Qualid qid) + | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + ] ] + ; + refglobals: + [ [ gl = LIST1 refglobal -> Loc.tag ~loc:!@loc gl ] ] + ; + delta_flag: + [ [ "-"; "["; idl = refglobals; "]" -> Loc.tag ~loc:!@loc @@ QDeltaBut idl + | "["; idl = refglobals; "]" -> Loc.tag ~loc:!@loc @@ QConst idl + | -> Loc.tag ~loc:!@loc @@ QDeltaBut (Loc.tag ~loc:!@loc []) + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flag -> Loc.tag ~loc:!@loc s + | d = delta_flag -> + Loc.tag ~loc:!@loc + [Loc.tag ~loc:!@loc QBeta; Loc.tag ~loc:!@loc QIota; Loc.tag ~loc:!@loc QZeta; d] + ] ] + ; + q_strategy_flag: + [ [ flag = strategy_flag -> flag ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 303d62a30d..196755346d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -930,6 +930,7 @@ let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting let () = add_expr_scope "clause" q_clause Tac2quote.of_clause let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch +let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 2490f6534b..a6c0e21ac5 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -33,6 +33,7 @@ let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" +let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 667378030a..645d37a8c6 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -68,4 +68,5 @@ val q_rewriting : rewriting Pcoq.Gram.entry val q_clause : clause Pcoq.Gram.entry val q_dispatch : dispatch Pcoq.Gram.entry val q_occurrences : occurrences Pcoq.Gram.entry +val q_strategy_flag : strategy_flag Pcoq.Gram.entry end diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 2e7fc7b44a..7c774a5c80 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -101,3 +101,17 @@ type rewriting = rewriting_r located type dispatch_r = raw_tacexpr option list * (raw_tacexpr option * raw_tacexpr option list) option type dispatch = dispatch_r located + +type red_flag_r = +| QBeta +| QIota +| QMatch +| QFix +| QCofix +| QZeta +| QConst of Libnames.reference or_anti list located +| QDeltaBut of Libnames.reference or_anti list located + +type red_flag = red_flag_r located + +type strategy_flag = red_flag list located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 8adeb15d20..4fcbcb5424 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -236,3 +236,53 @@ let of_dispatch tacs = in let map e = of_pair default (fun l -> of_list ~loc default l) (Loc.tag ~loc e) in of_pair (fun l -> of_list ~loc default l) (fun r -> of_option ~loc map r) tacs + +let make_red_flag l = + let open Genredexpr in + let rec add_flag red = function + | [] -> red + | (_, flag) :: lf -> + let red = match flag with + | QBeta -> { red with rBeta = true } + | QMatch -> { red with rMatch = true } + | QFix -> { red with rFix = true } + | QCofix -> { red with rCofix = true } + | QZeta -> { red with rZeta = true } + | QConst (loc, l) -> + if red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l } + | QDeltaBut (loc, l) -> + if red.rConst <> [] && not red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l; rDelta = true } + | QIota -> + { red with rMatch = true; rFix = true; rCofix = true } + in + add_flag red lf + in + add_flag + {rBeta = false; rMatch = false; rFix = false; rCofix = false; + rZeta = false; rDelta = false; rConst = []} + l + +let of_strategy_flag (loc, flag) = + let open Genredexpr in + let loc = Option.default dummy_loc loc in + let flag = make_red_flag flag in + let of_reference ref = + let loc = Libnames.loc_of_reference ref in + inj_wit ?loc Tac2env.wit_reference ref + in + let of_ref r = of_anti of_reference r in + CTacRec (loc, [ + std_proj "rBeta", of_bool ~loc flag.rBeta; + std_proj "rMatch", of_bool ~loc flag.rMatch; + std_proj "rFix", of_bool ~loc flag.rFix; + std_proj "rCofix", of_bool ~loc flag.rCofix; + std_proj "rZeta", of_bool ~loc flag.rZeta; + std_proj "rDelta", of_bool ~loc flag.rDelta; + std_proj "rConst", of_list ~loc of_ref flag.rConst; + ]) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 456d1fa97d..730324d051 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -55,3 +55,5 @@ val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) val of_dispatch : dispatch -> raw_tacexpr + +val of_strategy_flag : strategy_flag -> raw_tacexpr -- cgit v1.2.3 From 4c964aa3ecfbb2f6aa52274545c2e27d7d11e179 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 16:37:39 +0200 Subject: Fix typing of reference quotations. --- src/tac2core.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 196755346d..b38f0b8582 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -21,6 +21,7 @@ open Proofview.Notations module Value = Tac2ffi +let std_core n = KerName.make2 Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) module Core = @@ -35,6 +36,7 @@ let t_constr = coq_core "constr" let t_pattern = coq_core "pattern" let t_ident = coq_core "ident" let t_option = coq_core "option" +let t_reference = std_core "reference" let c_nil = coq_core "[]" let c_cons = coq_core "::" @@ -730,7 +732,7 @@ let () = let () = let interp _ gr = return (Value.of_reference gr) in let obj = { - ml_type = t_pattern; + ml_type = t_reference; ml_interp = interp; } in define_ml_object Tac2env.wit_reference obj -- cgit v1.2.3 From 3cb2f4901ea4d79ff20b45bc4d1968ada1695d3b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 16:48:44 +0200 Subject: Adding notation for the remaining reduction functions. --- tests/example2.v | 25 +++++++++++++++++++++++++ theories/Notations.v | 28 ++++++++++++++++++++++------ 2 files changed, 47 insertions(+), 6 deletions(-) diff --git a/tests/example2.v b/tests/example2.v index 1856663953..af664ef163 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -157,3 +157,28 @@ intros H. split; fold (1 + 0) (1 + 0) in H. reflexivity. Qed. + +Goal 1 + 1 = 2. +Proof. +cbv [ Nat.add ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +let x := reference:(Nat.add) in +cbn beta iota delta [ $x ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +simpl beta. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +lazy. +reflexivity. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 8c2c09a2b5..26d40fcb89 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -257,13 +257,21 @@ Ltac2 Notation "hnf" cl(opt(clause)) := Std.hnf (default_on_concl cl). Ltac2 Notation hnf := hnf. -Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.vm pl (default_on_concl cl). -Ltac2 Notation vm_compute := vm_compute. +Ltac2 Notation "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.simpl s pl (default_on_concl cl). +Ltac2 Notation simpl := simpl. -Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.native pl (default_on_concl cl). -Ltac2 Notation native_compute := native_compute. +Ltac2 Notation "cbv" s(strategy) cl(opt(clause)) := + Std.cbv s (default_on_concl cl). +Ltac2 Notation cbv := cbv. + +Ltac2 Notation "cbn" s(strategy) cl(opt(clause)) := + Std.cbn s (default_on_concl cl). +Ltac2 Notation cbn := cbn. + +Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := + Std.lazy s (default_on_concl cl). +Ltac2 Notation lazy := lazy. Ltac2 fold0 pl cl := let cl := default_on_concl cl in @@ -275,6 +283,14 @@ Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := Std.pattern pl (default_on_concl cl). +Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.vm pl (default_on_concl cl). +Ltac2 Notation vm_compute := vm_compute. + +Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.native pl (default_on_concl cl). +Ltac2 Notation native_compute := native_compute. + Ltac2 rewrite0 ev rw cl tac := let tac := match tac with | None => None -- cgit v1.2.3 From 60a98c8092a0293b852712f8e21ead6e0ef1e064 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 17:08:39 +0200 Subject: Adding a notation scope for global references. --- src/g_ltac2.ml4 | 6 +++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2quote.ml | 14 ++++++++------ src/tac2quote.mli | 2 ++ 6 files changed, 18 insertions(+), 7 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index ef3615db89..4a7ba31373 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -317,7 +317,8 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag; + q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag + q_reference; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -584,6 +585,9 @@ GEXTEND Gram | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; + q_reference: + [ [ r = refglobal -> r ] ] + ; refglobals: [ [ gl = LIST1 refglobal -> Loc.tag ~loc:!@loc gl ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index b38f0b8582..6c38d1dfd5 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -933,6 +933,7 @@ let () = add_expr_scope "clause" q_clause Tac2quote.of_clause let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag +let () = add_expr_scope "reference" q_reference Tac2quote.of_reference let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index a6c0e21ac5..d2b69aaf7d 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -33,6 +33,7 @@ let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" +let q_reference = Pcoq.Gram.entry_create "tactic:q_reference" let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" end diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 645d37a8c6..8b92bd16f6 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -68,5 +68,6 @@ val q_rewriting : rewriting Pcoq.Gram.entry val q_clause : clause Pcoq.Gram.entry val q_dispatch : dispatch Pcoq.Gram.entry val q_occurrences : occurrences Pcoq.Gram.entry +val q_reference : Libnames.reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry end diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 4fcbcb5424..9778bd18ae 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -268,15 +268,17 @@ let make_red_flag l = rZeta = false; rDelta = false; rConst = []} l +let of_reference r = + let of_ref ref = + let loc = Libnames.loc_of_reference ref in + inj_wit ?loc Tac2env.wit_reference ref + in + of_anti of_ref r + let of_strategy_flag (loc, flag) = let open Genredexpr in let loc = Option.default dummy_loc loc in let flag = make_red_flag flag in - let of_reference ref = - let loc = Libnames.loc_of_reference ref in - inj_wit ?loc Tac2env.wit_reference ref - in - let of_ref r = of_anti of_reference r in CTacRec (loc, [ std_proj "rBeta", of_bool ~loc flag.rBeta; std_proj "rMatch", of_bool ~loc flag.rMatch; @@ -284,5 +286,5 @@ let of_strategy_flag (loc, flag) = std_proj "rCofix", of_bool ~loc flag.rCofix; std_proj "rZeta", of_bool ~loc flag.rZeta; std_proj "rDelta", of_bool ~loc flag.rDelta; - std_proj "rConst", of_list ~loc of_ref flag.rConst; + std_proj "rConst", of_list ~loc of_reference flag.rConst; ]) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 730324d051..bd2303ac98 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -48,6 +48,8 @@ val of_rewriting : rewriting -> raw_tacexpr val of_occurrences : occurrences -> raw_tacexpr +val of_reference : Libnames.reference or_anti -> raw_tacexpr + val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) -- cgit v1.2.3 From c515a8acb4acbe7e73121f1060ffef31d96a1436 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 17:14:38 +0200 Subject: Adding a notation for the unfold tactic. --- tests/example2.v | 8 ++++++++ theories/Notations.v | 3 +++ 2 files changed, 11 insertions(+) diff --git a/tests/example2.v b/tests/example2.v index af664ef163..6b26b78022 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -182,3 +182,11 @@ Proof. lazy. reflexivity. Qed. + +Goal let x := 1 + 1 - 1 in x = x. +Proof. +intros x. +unfold &x at 1. +let x := reference:(Nat.sub) in unfold Nat.add, $x in x. +reflexivity. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 26d40fcb89..62d5d65d7c 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -273,6 +273,9 @@ Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := Std.lazy s (default_on_concl cl). Ltac2 Notation lazy := lazy. +Ltac2 Notation "unfold" pl(list1(seq(reference, occurrences), ",")) cl(opt(clause)) := + Std.unfold pl (default_on_concl cl). + Ltac2 fold0 pl cl := let cl := default_on_concl cl in Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). -- cgit v1.2.3 From a3bef204ec2840b879c37b0b3ba43574a6550647 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 17:32:46 +0200 Subject: Rely on quoting for lists instead of hardwiring it in the AST. --- src/g_ltac2.ml4 | 3 ++- src/tac2core.ml | 20 ++++---------------- src/tac2expr.mli | 1 - src/tac2intern.ml | 15 --------------- 4 files changed, 6 insertions(+), 33 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 4a7ba31373..7406a45207 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -125,7 +125,8 @@ GEXTEND Gram | "("; a = SELF; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) | "()" -> CTacCst (!@loc, AbsKn (Tuple 0)) | "("; ")" -> CTacCst (!@loc, AbsKn (Tuple 0)) - | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> CTacLst (Loc.tag ~loc:!@loc a) + | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + Tac2quote.of_list ~loc:!@loc (fun x -> x) a | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) | a = tactic_atom -> a ] ] diff --git a/src/tac2core.ml b/src/tac2core.ml index 6c38d1dfd5..8d0f640209 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -827,19 +827,13 @@ let () = add_scope "list0" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let scope = Extend.Alist0 scope in - let act l = - let l = List.map act l in - CTacLst (None, l) - in + let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | [tok; SexprStr (_, str)] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let sep = Extend.Atoken (CLexer.terminal str) in let scope = Extend.Alist0sep (scope, sep) in - let act l = - let l = List.map act l in - CTacLst (None, l) - in + let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end @@ -848,19 +842,13 @@ let () = add_scope "list1" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let scope = Extend.Alist1 scope in - let act l = - let l = List.map act l in - CTacLst (None, l) - in + let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | [tok; SexprStr (_, str)] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let sep = Extend.Atoken (CLexer.terminal str) in let scope = Extend.Alist1sep (scope, sep) in - let act l = - let l = List.map act l in - CTacLst (None, l) - in + let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () end diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 7efb85cbb0..76fb50181f 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -99,7 +99,6 @@ type raw_tacexpr = | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list | CTacLet of Loc.t * rec_flag * (raw_patexpr * raw_typexpr option * raw_tacexpr) list * raw_tacexpr | CTacArr of raw_tacexpr list located -| CTacLst of raw_tacexpr list located | CTacCnv of Loc.t * raw_tacexpr * raw_typexpr | CTacSeq of Loc.t * raw_tacexpr * raw_tacexpr | CTacCse of Loc.t * raw_tacexpr * raw_taccase list diff --git a/src/tac2intern.ml b/src/tac2intern.ml index b62a574a6c..865935c52d 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -195,7 +195,6 @@ let loc_of_tacexpr = function | CTacApp (loc, _, _) -> loc | CTacLet (loc, _, _, _) -> loc | CTacArr (loc, _) -> Option.default dummy_loc loc -| CTacLst (loc, _) -> Option.default dummy_loc loc | CTacCnv (loc, _, _) -> loc | CTacSeq (loc, _, _) -> loc | CTacCse (loc, _, _) -> loc @@ -735,14 +734,6 @@ let rec intern_rec env = function let fold e el = intern_rec_with_constraint env e t0 :: el in let el = e0 :: List.fold_right fold el [] in (GTacArr el, GTypRef (Other t_array, [t0])) -| CTacLst (loc, []) -> - let id = fresh_id env in - (c_nil, GTypRef (Other t_list, [GTypVar id])) -| CTacLst (loc, e0 :: el) -> - let (e0, t0) = intern_rec env e0 in - let fold e el = c_cons (intern_rec_with_constraint env e t0) el in - let el = c_cons e0 (List.fold_right fold el c_nil) in - (el, GTypRef (Other t_list, [t0])) | CTacCnv (loc, e, tc) -> let (e, t) = intern_rec env e in let tc = intern_type env tc in @@ -1229,9 +1220,6 @@ let rec globalize ids e = match e with | CTacArr (loc, el) -> let el = List.map (fun e -> globalize ids e) el in CTacArr (loc, el) -| CTacLst (loc, el) -> - let el = List.map (fun e -> globalize ids e) el in - CTacLst (loc, el) | CTacCnv (loc, e, t) -> let e = globalize ids e in CTacCnv (loc, e, t) @@ -1446,9 +1434,6 @@ let rec subst_rawexpr subst t = match t with | CTacArr (loc, el) -> let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in if el' == el then t else CTacArr (loc, el') -| CTacLst (loc, el) -> - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if el' == el then t else CTacLst (loc, el') | CTacCnv (loc, e, c) -> let e' = subst_rawexpr subst e in let c' = subst_rawtype subst c in -- cgit v1.2.3 From 6a5558405f801c466a51f32080c8dbb893a2170d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 17:34:55 +0200 Subject: Removing dead code about arrays in the AST. --- src/tac2expr.mli | 1 - src/tac2intern.ml | 15 --------------- 2 files changed, 16 deletions(-) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 76fb50181f..281ed6c81e 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -98,7 +98,6 @@ type raw_tacexpr = | CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr | CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list | CTacLet of Loc.t * rec_flag * (raw_patexpr * raw_typexpr option * raw_tacexpr) list * raw_tacexpr -| CTacArr of raw_tacexpr list located | CTacCnv of Loc.t * raw_tacexpr * raw_typexpr | CTacSeq of Loc.t * raw_tacexpr * raw_tacexpr | CTacCse of Loc.t * raw_tacexpr * raw_taccase list diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 865935c52d..765be92103 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -194,7 +194,6 @@ let loc_of_tacexpr = function | CTacFun (loc, _, _) -> loc | CTacApp (loc, _, _) -> loc | CTacLet (loc, _, _, _) -> loc -| CTacArr (loc, _) -> Option.default dummy_loc loc | CTacCnv (loc, _, _) -> loc | CTacSeq (loc, _, _) -> loc | CTacCse (loc, _, _) -> loc @@ -726,14 +725,6 @@ let rec intern_rec env = function let ids = List.fold_left fold Id.Set.empty el in if is_rec then intern_let_rec env loc ids el e else intern_let env loc ids el e -| CTacArr (loc, []) -> - let id = fresh_id env in - (GTacArr [], GTypRef (Other t_int, [GTypVar id])) -| CTacArr (loc, e0 :: el) -> - let (e0, t0) = intern_rec env e0 in - let fold e el = intern_rec_with_constraint env e t0 :: el in - let el = e0 :: List.fold_right fold el [] in - (GTacArr el, GTypRef (Other t_array, [t0])) | CTacCnv (loc, e, tc) -> let (e, t) = intern_rec env e in let tc = intern_type env tc in @@ -1217,9 +1208,6 @@ let rec globalize ids e = match e with in let bnd = List.map map bnd in CTacLet (loc, isrec, bnd, e) -| CTacArr (loc, el) -> - let el = List.map (fun e -> globalize ids e) el in - CTacArr (loc, el) | CTacCnv (loc, e, t) -> let e = globalize ids e in CTacCnv (loc, e, t) @@ -1431,9 +1419,6 @@ let rec subst_rawexpr subst t = match t with let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in if bnd' == bnd && e' == e then t else CTacLet (loc, isrec, bnd', e') -| CTacArr (loc, el) -> - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if el' == el then t else CTacArr (loc, el') | CTacCnv (loc, e, c) -> let e' = subst_rawexpr subst e in let c' = subst_rawtype subst c in -- cgit v1.2.3 From 7cd041b42588e6d9ff0e5ea127960585666c4b07 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 17:54:28 +0200 Subject: Documentation about the transition from Ltac1. --- doc/ltac2.md | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) diff --git a/doc/ltac2.md b/doc/ltac2.md index 6c4912c8f3..55780a7712 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -690,6 +690,112 @@ foo 0 ↦ (fun x => x ()) (fun _ => 0) Note that abbreviations are not typechecked at all, and may result in typing errors after expansion. +# Transition from Ltac1 + +Owing to the use of a bunch of notations, the transition shouldn't be +atrociously horrible and shockingly painful up to the point you want to retire +in the Ariège mountains, living off the land and insulting careless bypassers in +proto-georgian. + +That said, we do *not* guarantee you it is going to be a blissful walk either. +Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq +will help you. + +We list the major changes and the transition strategies hereafter. + +## Syntax changes + +Due to conflicts, a few syntactic rules have changed. + +- The dispatch tactical `tac; [foo|bar]` is now written `tac > [foo|bar]`. +- Levels of a few operators have been revised. Some tacticals now parse as if + they were a normal function, i.e. one has to put parentheses around the + argument when it is complex, e.g an abstraction. List of affected tacticals: + `try`, `repeat`, `do`, `once`, `progress`, `time`, `abstract`. +- `idtac` is no more. Either use `()` if you expect nothing to happen, + `(fun () => ())` if you want a thunk (see next section), or use printing + primitives from the `Message` module if you wand to display something. + +## Tactic delay + +Tactics are not magically delayed anymore, neither as functions nor as +arguments. It is your responsibility to thunk them beforehand and apply them +at the call site. + +A typical example of a delayed function: +``` +Ltac foo := blah. +``` +becomes +``` +Ltac2 foo () := blah. +``` + +All subsequent calls to `foo` must be applied to perform the same effect as +before. + +Likewise, for arguments: +``` +Ltac bar tac := tac; tac; tac. +``` +becomes +``` +Ltac2 bar tac := tac (); tac (); tac (). +``` + +We recommend the use of syntactic notations to ease the transition. For +instance, the first example can alternatively written as: +``` +Ltac2 foo0 () := blah. +Ltac2 Notation foo := foo0 (). +``` + +This allows to keep the subsequent calls to the tactic as-is, as the +expression `foo` will be implicitly expanded everywhere into `foo0 ()`. Such +a trick also works for arguments, as arguments of syntactic notations are +implicitly thunked. The second example could thus be written as follows. + +``` +Ltac2 bar0 tac := tac (); tac (); tac (). +Ltac2 Notation bar := bar0. +``` + +## Variable binding + +Ltac1 relies on a crazy amount of dynamic trickery to be able to tell apart +bound variables from terms, hypotheses and whatnot. There is no such thing in +Ltac2, as variables are recognized statically and other constructions do not +live in the same syntactic world. Due to the abuse of quotations, it can +sometimes be complicated to know what a mere identifier represent in a tactic +expression. We recommend tracking the context and letting the compiler spit +typing errors to understand what is going on. + +We list below the typical changes one has to perform depending on the static +errors produced by the typechecker. + +### In Ltac expressions + +- `Unbound value X`, `Unbound constructor X`: + * if `X` is meant to be a term from the current stactic environment, replace + the problematic use by `'X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +### In quotations + +- `The reference X was not found in the current environment`: + * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, + replace the problematic use by `$X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +## Exception catching + +Ltac2 features a proper exception-catching mechanism. For this reason, the +Ltac1 mechanism relying on `fail` taking integers and tacticals decreasing it +has been removed. Now exceptions are preserved by all tacticals, and it is +your duty to catch it and reraise it depending on your use. + # TODO - Implement deep pattern-matching. -- cgit v1.2.3 From 72f47973b860c8074aa976759ee1adce993dac49 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Aug 2017 18:42:21 +0200 Subject: Fix the semantics of fail, as it should enter the goal. --- theories/Notations.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Notations.v b/theories/Notations.v index 62d5d65d7c..d2c7059985 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -27,7 +27,7 @@ match Control.case t with Control.plus (fun _ => s x) (fun e => s (k e)) end. -Ltac2 fail0 (_ : unit) := Control.zero Tactic_failure. +Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero Tactic_failure). Ltac2 Notation fail := fail0 (). -- cgit v1.2.3 From c3d83f8437022986593df45c3c3920c8356d9f84 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 14:51:20 +0200 Subject: Lookahead to cheat the constr parser in order to parse "& IDENT". --- src/g_ltac2.ml4 | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 7406a45207..3d873c7369 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -54,6 +54,16 @@ let test_lpar_id_rpar = | _ -> err ()) | _ -> err ()) +let test_ampersand_ident = + Gram.Entry.of_parser "test_ampersand_ident" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "&" -> + (match stream_nth 1 strm with + | IDENT _ -> () + | _ -> err ()) + | _ -> err ()) + let tac2expr = Tac2entries.Pltac.tac2expr let tac2type = Gram.entry_create "tactic:tac2type" let tac2def_val = Gram.entry_create "tactic:tac2def_val" @@ -617,8 +627,8 @@ GEXTEND Gram [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) - | "&"; id = [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] -> - let tac = Tac2quote.of_exact_hyp ~loc:!@loc id in + | test_ampersand_ident; "&"; id = Prim.ident -> + let tac = Tac2quote.of_exact_hyp ~loc:!@loc (Loc.tag ~loc:!@loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) ] ] -- cgit v1.2.3 From 3ef5f35b0d7ec6f56f68e4319d6ec85bebaa19b8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 14:57:07 +0200 Subject: Parse specifically idents as destruction arguments. This is for backward compatibility. --- src/g_ltac2.ml4 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 3d873c7369..c1025ceba5 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -459,6 +459,7 @@ GEXTEND Gram ; destruction_arg: [ [ n = lnatural -> QElimOnAnonHyp n + | id = lident -> QElimOnIdent id | c = constr_with_bindings -> QElimOnConstr c ] ] ; -- cgit v1.2.3 From c41f5d406f627e94363b4549ef268ffa33e7b681 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 15:01:02 +0200 Subject: Respect the default goal selector in toplevel invocations. --- src/tac2entries.ml | 3 ++- tests/example2.v | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index d2b69aaf7d..73086c406e 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -700,7 +700,8 @@ let print_ltac ref = let solve default tac = let status = Proof_global.with_current_proof begin fun etac p -> let with_end_tac = if default then Some etac else None in - let (p, status) = Pfedit.solve SelectAll None tac ?with_end_tac p in + let g = Proof_bullet.get_default_goal_selector () in + let (p, status) = Pfedit.solve g None tac ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) let p = Proof.maximal_unfocus Vernacentries.command_focus p in diff --git a/tests/example2.v b/tests/example2.v index 6b26b78022..95485305dc 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -2,6 +2,8 @@ Require Import Ltac2.Ltac2. Import Ltac2.Notations. +Set Default Goal Selector "all". + Goal exists n, n = 0. Proof. split with (x := 0). -- cgit v1.2.3 From 47eb0278a3cdf93129b1742e314681d65bd6475a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 14:11:48 +0200 Subject: More bindings to primitive tactics. --- src/tac2stdlib.ml | 26 ++++++++++++++++++++++++++ src/tac2tactics.ml | 49 ++++++++++++++++++++++++++++++++++++++++++++++++- src/tac2tactics.mli | 10 +++++++++- theories/Notations.v | 33 ++++++++++++++++++++++++++++++++- theories/Std.v | 10 ++++++++++ 5 files changed, 125 insertions(+), 3 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index eccaf95ab3..d88402cbf2 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -481,10 +481,36 @@ end (** Tactics from extratactics *) +let () = define_prim2 "tac_discriminate" begin fun ev arg -> + let ev = Value.to_bool ev in + let arg = Value.to_option (fun arg -> None, to_destruction_arg arg) arg in + Tac2tactics.discriminate ev arg +end + +let () = define_prim3 "tac_injection" begin fun ev ipat arg -> + let ev = Value.to_bool ev in + let ipat = Value.to_option to_intro_patterns ipat in + let arg = Value.to_option (fun arg -> None, to_destruction_arg arg) arg in + Tac2tactics.injection ev ipat arg +end + let () = define_prim1 "tac_absurd" begin fun c -> Contradiction.absurd (Value.to_constr c) end +let () = define_prim1 "tac_contradiction" begin fun c -> + let c = Value.to_option to_constr_with_bindings c in + Contradiction.contradiction c +end + +let () = define_prim4 "tac_autorewrite" begin fun all by ids cl -> + let all = Value.to_bool all in + let by = Value.to_option (fun tac -> Proofview.tclIGNORE (thaw tac)) by in + let ids = Value.to_list Value.to_ident ids in + let cl = to_clause cl in + Tac2tactics.autorewrite ~all by ids cl +end + let () = define_prim1 "tac_subst" begin fun ids -> let ids = Value.to_list Value.to_ident ids in Equality.subst ids diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 2f4965783f..25a00fdc2e 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -16,6 +16,15 @@ open Genredexpr open Proofview open Proofview.Notations +type destruction_arg = EConstr.constr with_bindings tactic Misctypes.destruction_arg + +let tactic_infer_flags with_evar = { + Pretyping.use_typeclasses = true; + Pretyping.solve_unification_constraints = true; + Pretyping.use_hook = None; + Pretyping.fail_evar = not with_evar; + Pretyping.expand_evars = true } + (** FIXME: export a better interface in Tactics *) let delayed_of_tactic tac env sigma = let _, pv = Proofview.init sigma [] in @@ -30,7 +39,7 @@ let apply adv ev cb cl = | Some (id, cl) -> Tactics.apply_delayed_in adv ev id cb cl type induction_clause = - EConstr.constr with_bindings tactic destruction_arg * + destruction_arg * intro_pattern_naming option * or_and_intro_pattern option * Locus.clause option @@ -112,3 +121,41 @@ let vm where cl = let native where cl = let where = Option.map map_pattern_with_occs where in Tactics.reduce (CbvNative where) cl + +let on_destruction_arg tac ev arg = + Proofview.Goal.enter begin fun gl -> + match arg with + | None -> tac ev None + | Some (clear, arg) -> + let arg = match arg with + | ElimOnConstr c -> + let env = Proofview.Goal.env gl in + Proofview.tclEVARMAP >>= fun sigma -> + c >>= fun (c, lbind) -> + Proofview.tclEVARMAP >>= fun sigma' -> + let flags = tactic_infer_flags ev in + let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in + Proofview.tclUNIT (Some sigma', ElimOnConstr (c, lbind)) + | ElimOnIdent id -> Proofview.tclUNIT (None, ElimOnIdent id) + | ElimOnAnonHyp n -> Proofview.tclUNIT (None, ElimOnAnonHyp n) + in + arg >>= fun (sigma', arg) -> + let arg = Some (clear, arg) in + match sigma' with + | None -> tac ev arg + | Some sigma' -> + Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' + end + +let discriminate ev arg = on_destruction_arg Equality.discr_tac ev arg + +let injection ev ipat arg = + let tac ev arg = Equality.injClause ipat ev arg in + on_destruction_arg tac ev arg + +let autorewrite ~all by ids cl = + let conds = if all then Some Equality.AllMatches else None in + let ids = List.map Id.to_string ids in + match by with + | None -> Autorewrite.auto_multi_rewrite ?conds ids cl + | Some by -> Autorewrite.auto_multi_rewrite_with ?conds by ids cl diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index d835f768a1..8939d2a9dd 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -14,6 +14,8 @@ open Misctypes open Tactypes open Proofview +type destruction_arg = EConstr.constr with_bindings tactic Misctypes.destruction_arg + (** Local reimplementations of tactics variants from Coq *) val apply : advanced_flag -> evars_flag -> @@ -21,7 +23,7 @@ val apply : advanced_flag -> evars_flag -> (Id.t * intro_pattern option) option -> unit tactic type induction_clause = - EConstr.constr with_bindings tactic destruction_arg * + destruction_arg * intro_pattern_naming option * or_and_intro_pattern option * clause option @@ -51,3 +53,9 @@ val unfold : (global_reference * occurrences_expr) list -> clause -> unit tactic val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic + +val discriminate : evars_flag -> destruction_arg option -> unit tactic + +val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic + +val autorewrite : all:bool -> unit tactic option -> Id.t list -> clause -> unit tactic diff --git a/theories/Notations.v b/theories/Notations.v index d2c7059985..2d52904faf 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -130,6 +130,23 @@ Ltac2 Notation split := split. Ltac2 Notation "esplit" bnd(thunk(bindings)) := split0 true bnd. Ltac2 Notation esplit := esplit. +Ltac2 exists0 ev bnds := match bnds with +| [] => split0 ev (fun () => Std.NoBindings) +| _ => + let rec aux bnds := match bnds with + | [] => () + | bnd :: bnds => split0 ev bnd; aux bnds + end in + aux bnds +end. + +(* +Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. + +Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. +Ltac2 Notation eexists := eexists. +*) + Ltac2 left0 ev bnd := enter_h ev Std.left bnd. Ltac2 Notation "left" bnd(thunk(bindings)) := left0 false bnd. @@ -316,7 +333,7 @@ Ltac2 Notation "erewrite" tac(opt(seq("by", thunk(tactic)))) := rewrite0 true rw cl tac. -(** Other base tactics *) +(** coretactics *) Ltac2 Notation reflexivity := Std.reflexivity (). @@ -329,3 +346,17 @@ Ltac2 Notation admit := Std.admit (). Ltac2 Notation clear := Std.keep []. Ltac2 Notation refine := Control.refine. + +(** extratactics *) + +Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). + +Ltac2 Notation absurd := absurd0. + +Ltac2 subst0 ids := match ids with +| [] => Std.subst_all () +| _ => Std.subst ids +end. + +Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. +Ltac2 Notation subst := subst. diff --git a/theories/Std.v b/theories/Std.v index dd81835c40..f380c10af8 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -184,7 +184,17 @@ Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". +(** coretactics *) + +(** extratactics *) + +Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". +Ltac2 @ external injection : evar_flag -> intro_pattern list option -> destruction_arg option -> unit := "ltac2" "tac_injection". + Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". +Ltac2 @ external contradiction : constr_with_bindings option -> unit := "ltac2" "tac_contradiction". + +Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> clause -> unit := "ltac2" "tac_autorewrite". Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". -- cgit v1.2.3 From 6875b016b0a502b03296e5f97f26cf0f6699a7aa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 17:16:01 +0200 Subject: Do not return STRING scopes in the tuple produced by "seq" scopes. --- doc/ltac2.md | 6 ++++-- src/tac2core.ml | 13 ++++++++----- src/tac2quote.ml | 7 ++++++- src/tac2quote.mli | 2 ++ theories/Notations.v | 33 +++------------------------------ 5 files changed, 23 insertions(+), 38 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 55780a7712..a645331e2d 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -615,8 +615,10 @@ The following scopes are built-in. + parses the string *s* as a keyword, if it is already a keyword, otherwise as an IDENT. Returns `()`. - seq(*scope₁*, ..., *scopeₙ*): - + parses *scope₁*, ..., *scopeₙ* in this order, and produces a n-tuple made - out of the parsed values in the same order. It is forbidden for the various + + parses *scope₁*, ..., *scopeₙ* in this order, and produces a tuple made + out of the parsed values in the same order. As an optimization, all + subscopes of the form STRING are left out of the returned tuple, instead + of returning a useless unit value. It is forbidden for the various subscopes to refer to the global entry using self of next. For now there is no way to declare new scopes from Ltac2 side, but this is diff --git a/src/tac2core.ml b/src/tac2core.ml index 8d0f640209..7a8f3ceb44 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -963,13 +963,12 @@ let rec generalize_symbol : type _ converter = | CvNil : (Loc.t -> raw_tacexpr) converter -| CvCns : 'act converter * ('a -> raw_tacexpr) -> ('a -> 'act) converter +| CvCns : 'act converter * ('a -> raw_tacexpr) option -> ('a -> 'act) converter let rec apply : type a. a converter -> raw_tacexpr list -> a = function -| CvNil -> fun accu loc -> - let cst = CTacCst (loc, AbsKn (Tuple (List.length accu))) in - CTacApp (loc, cst, accu) -| CvCns (c, f) -> fun accu x -> apply c (f x :: accu) +| CvNil -> fun accu loc -> Tac2quote.of_tuple ~loc accu +| CvCns (c, None) -> fun accu x -> apply c accu +| CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) type seqrule = | Seqrule : ('act, Loc.t -> raw_tacexpr) norec_rule * 'act converter -> seqrule @@ -983,6 +982,10 @@ let rec make_seq_rule = function let scope = generalize_symbol scope in let Seqrule (r, c) = make_seq_rule rem in let r = { norec_rule = Next (r.norec_rule, scope.any_symbol) } in + let f = match tok with + | SexprStr _ -> None (** Leave out mere strings *) + | _ -> Some f + in Seqrule (r, CvCns (c, f)) let () = add_scope "seq" begin fun toks -> diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 9778bd18ae..dbd2fd0529 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -46,7 +46,12 @@ let of_pair f g (loc, (e1, e2)) = let loc = Option.default dummy_loc loc in CTacApp (loc, CTacCst (loc, AbsKn (Tuple 2)), [f e1; g e2]) -let of_tuple ?loc el = +let of_tuple ?loc el = match el with +| [] -> + let loc = Option.default dummy_loc loc in + CTacCst (loc, AbsKn (Tuple 0)) +| [e] -> e +| el -> let loc = Option.default dummy_loc loc in let len = List.length el in CTacApp (loc, CTacCst (loc, AbsKn (Tuple len)), el) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index bd2303ac98..7f3d9dce6e 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -24,6 +24,8 @@ val of_int : int located -> raw_tacexpr val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) located -> raw_tacexpr +val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr + val of_variable : Id.t located -> raw_tacexpr val of_ident : Id.t located -> raw_tacexpr diff --git a/theories/Notations.v b/theories/Notations.v index 2d52904faf..bb27a34627 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -175,14 +175,7 @@ Ltac2 Notation econstructor := econstructor. Ltac2 Notation "econstructor" n(tactic) bnd(thunk(bindings)) := constructor0 true n bnd. Ltac2 elim0 ev c bnd use := - let f ev ((c, bnd, use)) := - let use := match use with - | None => None - | Some u => - let ((_, c, wth)) := u in Some (c, wth) - end in - Std.elim ev (c, bnd) use - in + let f ev ((c, bnd, use)) := Std.elim ev (c, bnd) use in enter_h ev f (fun () => c (), bnd (), use ()). Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) @@ -219,14 +212,7 @@ Ltac2 Notation "apply" apply0 true false cb cl. Ltac2 induction0 ev ic use := - let f ev use := - let use := match use with - | None => None - | Some u => - let ((_, c, wth)) := u in Some (c, wth) - end in - Std.induction ev ic use - in + let f ev use := Std.induction ev ic use in enter_h ev f use. Ltac2 Notation "induction" @@ -240,14 +226,7 @@ Ltac2 Notation "einduction" induction0 true ic use. Ltac2 destruct0 ev ic use := - let f ev use := - let use := match use with - | None => None - | Some u => - let ((_, c, wth)) := u in Some (c, wth) - end in - Std.destruct ev ic use - in + let f ev use := Std.destruct ev ic use in enter_h ev f use. Ltac2 Notation "destruct" @@ -312,12 +291,6 @@ Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause Ltac2 Notation native_compute := native_compute. Ltac2 rewrite0 ev rw cl tac := - let tac := match tac with - | None => None - | Some p => - let ((_, tac)) := p in - Some tac - end in let cl := default_on_concl cl in Std.rewrite ev rw cl tac. -- cgit v1.2.3 From 029dd0fcfc5641b689356c467e2f0fb1d3fa178c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 18:02:49 +0200 Subject: Renaming the bindings scope into with_bindings. --- src/g_ltac2.ml4 | 4 ++-- src/tac2core.ml | 2 +- src/tac2entries.ml | 2 +- src/tac2entries.mli | 2 +- theories/Notations.v | 40 ++++++++++++++++++++-------------------- 5 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index c1025ceba5..95fcf79000 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -327,7 +327,7 @@ open Tac2entries.Pltac let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram - GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause + GLOBAL: q_ident q_with_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_reference; anti: @@ -365,7 +365,7 @@ GEXTEND Gram Loc.tag ~loc:!@loc @@ QImplicitBindings bl ] ] ; - q_bindings: + q_with_bindings: [ [ bl = with_bindings -> bl ] ] ; intropatterns: diff --git a/src/tac2core.ml b/src/tac2core.ml index 7a8f3ceb44..342e8f51e8 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -912,7 +912,7 @@ let add_expr_scope name entry f = end let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) -let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings +let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 73086c406e..6c8c2348fe 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -25,7 +25,7 @@ struct let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" -let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" +let q_with_bindings = Pcoq.Gram.entry_create "tactic:q_with_bindings" let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 8b92bd16f6..d22ae7a953 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -60,7 +60,7 @@ val tac2expr : raw_tacexpr Pcoq.Gram.entry open Tac2qexpr val q_ident : Id.t located or_anti Pcoq.Gram.entry -val q_bindings : bindings Pcoq.Gram.entry +val q_with_bindings : bindings Pcoq.Gram.entry val q_intropattern : intro_pattern Pcoq.Gram.entry val q_intropatterns : intro_pattern list located Pcoq.Gram.entry val q_induction_clause : induction_clause Pcoq.Gram.entry diff --git a/theories/Notations.v b/theories/Notations.v index bb27a34627..8345344d94 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -124,10 +124,10 @@ Ltac2 Notation eintros := eintros. Ltac2 split0 ev bnd := enter_h ev Std.split bnd. -Ltac2 Notation "split" bnd(thunk(bindings)) := split0 false bnd. +Ltac2 Notation "split" bnd(thunk(with_bindings)) := split0 false bnd. Ltac2 Notation split := split. -Ltac2 Notation "esplit" bnd(thunk(bindings)) := split0 true bnd. +Ltac2 Notation "esplit" bnd(thunk(with_bindings)) := split0 true bnd. Ltac2 Notation esplit := esplit. Ltac2 exists0 ev bnds := match bnds with @@ -141,26 +141,26 @@ Ltac2 exists0 ev bnds := match bnds with end. (* -Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. +Ltac2 Notation "exists" bnd(list0(thunk(with_bindings), ",")) := exists0 false bnd. -Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. +Ltac2 Notation "eexists" bnd(list0(thunk(with_bindings), ",")) := exists0 true bnd. Ltac2 Notation eexists := eexists. *) Ltac2 left0 ev bnd := enter_h ev Std.left bnd. -Ltac2 Notation "left" bnd(thunk(bindings)) := left0 false bnd. +Ltac2 Notation "left" bnd(thunk(with_bindings)) := left0 false bnd. Ltac2 Notation left := left. -Ltac2 Notation "eleft" bnd(thunk(bindings)) := left0 true bnd. +Ltac2 Notation "eleft" bnd(thunk(with_bindings)) := left0 true bnd. Ltac2 Notation eleft := eleft. Ltac2 right0 ev bnd := enter_h ev Std.right bnd. -Ltac2 Notation "right" bnd(thunk(bindings)) := right0 false bnd. +Ltac2 Notation "right" bnd(thunk(with_bindings)) := right0 false bnd. Ltac2 Notation right := right. -Ltac2 Notation "eright" bnd(thunk(bindings)) := right0 true bnd. +Ltac2 Notation "eright" bnd(thunk(with_bindings)) := right0 true bnd. Ltac2 Notation eright := eright. Ltac2 constructor0 ev n bnd := @@ -168,22 +168,22 @@ Ltac2 constructor0 ev n bnd := Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). Ltac2 Notation constructor := constructor. -Ltac2 Notation "constructor" n(tactic) bnd(thunk(bindings)) := constructor0 false n bnd. +Ltac2 Notation "constructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 false n bnd. Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). Ltac2 Notation econstructor := econstructor. -Ltac2 Notation "econstructor" n(tactic) bnd(thunk(bindings)) := constructor0 true n bnd. +Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. Ltac2 elim0 ev c bnd use := let f ev ((c, bnd, use)) := Std.elim ev (c, bnd) use in enter_h ev f (fun () => c (), bnd (), use ()). -Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(bindings)) - use(thunk(opt(seq("using", constr, bindings)))) := +Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := elim0 false c bnd use. -Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(bindings)) - use(thunk(opt(seq("using", constr, bindings)))) := +Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := elim0 true c bnd use. Ltac2 apply0 adv ev cb cl := @@ -202,12 +202,12 @@ Ltac2 apply0 adv ev cb cl := Std.apply adv ev cb cl. Ltac2 Notation "eapply" - cb(list1(thunk(seq(constr, bindings)), ",")) + cb(list1(thunk(seq(constr, with_bindings)), ",")) cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := apply0 true true cb cl. Ltac2 Notation "apply" - cb(list1(thunk(seq(constr, bindings)), ",")) + cb(list1(thunk(seq(constr, with_bindings)), ",")) cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := apply0 true false cb cl. @@ -217,12 +217,12 @@ Ltac2 induction0 ev ic use := Ltac2 Notation "induction" ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, bindings)))) := + use(thunk(opt(seq("using", constr, with_bindings)))) := induction0 false ic use. Ltac2 Notation "einduction" ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, bindings)))) := + use(thunk(opt(seq("using", constr, with_bindings)))) := induction0 true ic use. Ltac2 destruct0 ev ic use := @@ -231,12 +231,12 @@ Ltac2 destruct0 ev ic use := Ltac2 Notation "destruct" ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, bindings)))) := + use(thunk(opt(seq("using", constr, with_bindings)))) := destruct0 false ic use. Ltac2 Notation "edestruct" ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, bindings)))) := + use(thunk(opt(seq("using", constr, with_bindings)))) := destruct0 true ic use. Ltac2 default_on_concl cl := -- cgit v1.2.3 From 8e6338d862873d7e377f59664bbd89e16c0a7309 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 18:03:54 +0200 Subject: Introducing a distinct bindings scope. --- src/g_ltac2.ml4 | 7 +++++-- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + 4 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 95fcf79000..e7ab574747 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -327,9 +327,9 @@ open Tac2entries.Pltac let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram - GLOBAL: q_ident q_with_bindings q_intropattern q_intropatterns q_induction_clause + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_reference; + q_reference q_with_bindings; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -365,6 +365,9 @@ GEXTEND Gram Loc.tag ~loc:!@loc @@ QImplicitBindings bl ] ] ; + q_bindings: + [ [ bl = bindings -> bl ] ] + ; q_with_bindings: [ [ bl = with_bindings -> bl ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index 342e8f51e8..b67d70a5cb 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -912,6 +912,7 @@ let add_expr_scope name entry f = end let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) +let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 6c8c2348fe..91c8d10e2d 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -25,6 +25,7 @@ struct let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" +let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" let q_with_bindings = Pcoq.Gram.entry_create "tactic:q_with_bindings" let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" diff --git a/src/tac2entries.mli b/src/tac2entries.mli index d22ae7a953..2c5862b149 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -60,6 +60,7 @@ val tac2expr : raw_tacexpr Pcoq.Gram.entry open Tac2qexpr val q_ident : Id.t located or_anti Pcoq.Gram.entry +val q_bindings : bindings Pcoq.Gram.entry val q_with_bindings : bindings Pcoq.Gram.entry val q_intropattern : intro_pattern Pcoq.Gram.entry val q_intropatterns : intro_pattern list located Pcoq.Gram.entry -- cgit v1.2.3 From b3471b2bf449041b47c19e8e12249e4bb36af3ec Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Aug 2017 18:06:36 +0200 Subject: Adding more notations for the lulz. --- tests/example2.v | 16 ++++++++++++++++ theories/Notations.v | 21 +++++++++++++++++---- 2 files changed, 33 insertions(+), 4 deletions(-) diff --git a/tests/example2.v b/tests/example2.v index 95485305dc..a7eb02050b 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -192,3 +192,19 @@ unfold &x at 1. let x := reference:(Nat.sub) in unfold Nat.add, $x in x. reflexivity. Qed. + +Goal exists x y : nat, x = y. +Proof. +exists 0, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +eexists _, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +refine '(let x := 0 in _). +eexists; exists &x; reflexivity. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 8345344d94..2a496b3faf 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -140,12 +140,11 @@ Ltac2 exists0 ev bnds := match bnds with aux bnds end. -(* -Ltac2 Notation "exists" bnd(list0(thunk(with_bindings), ",")) := exists0 false bnd. +Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. +(* Ltac2 Notation exists := exists. *) -Ltac2 Notation "eexists" bnd(list0(thunk(with_bindings), ",")) := exists0 true bnd. +Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. Ltac2 Notation eexists := eexists. -*) Ltac2 left0 ev bnd := enter_h ev Std.left bnd. @@ -308,6 +307,20 @@ Ltac2 Notation "erewrite" (** coretactics *) +Ltac2 exact0 ev c := + Control.enter (fun _ => + match ev with + | true => + let c := c () in + Control.refine (fun _ => c) + | false => + Control.with_holes c (fun c => Control.refine (fun _ => c)) + end + ). + +Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. +Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. + Ltac2 Notation reflexivity := Std.reflexivity (). Ltac2 Notation assumption := Std.assumption (). -- cgit v1.2.3 From 126dc656963a7feb589b2a3574f0c55ad84d5f69 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Aug 2017 00:52:39 +0200 Subject: Allowing to insert calls to Ltac1 references in Ltac2. --- doc/ltac2.md | 11 +++++++++++ src/g_ltac2.ml4 | 5 +++++ src/tac2core.ml | 14 ++++++++++++++ 3 files changed, 30 insertions(+) diff --git a/doc/ltac2.md b/doc/ltac2.md index a645331e2d..51e3ab664d 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -692,6 +692,17 @@ foo 0 ↦ (fun x => x ()) (fun _ => 0) Note that abbreviations are not typechecked at all, and may result in typing errors after expansion. +# Compatibility layer with Ltac1 + +## Ltac1 from Ltac2 + +One can call Ltac1 code from Ltac2 by using the `ltac1` quotation. It parses +a Ltac1 expression, and semantics of this quotation is the evaluation of the +corresponding code for its side effects. + +Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited +to the use of standalone function calls. + # Transition from Ltac1 Owing to the use of a bunch of notations, the transition shouldn't be diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index e7ab574747..6822b8e7ba 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -72,10 +72,14 @@ let tac2def_ext = Gram.entry_create "tactic:tac2def_ext" let tac2def_syn = Gram.entry_create "tactic:tac2def_syn" let tac2mode = Gram.entry_create "vernac:ltac2_command" +(** FUCK YOU API *) +let ltac1_expr = (Obj.magic Pltac.tactic_expr : Tacexpr.raw_tactic_expr Gram.entry) + let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c let inj_reference loc c = inj_wit Tac2env.wit_reference loc c +let inj_ltac1 loc e = inj_wit Tacarg.wit_tactic loc e let pattern_of_qualid loc id = if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) @@ -170,6 +174,7 @@ GEXTEND Gram | IDENT "ident"; ":"; "("; c = lident; ")" -> Tac2quote.of_ident c | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> inj_pattern !@loc c | IDENT "reference"; ":"; "("; c = globref; ")" -> inj_reference !@loc c + | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> inj_ltac1 !@loc qid ] ] ; let_clause: diff --git a/src/tac2core.ml b/src/tac2core.ml index b67d70a5cb..b95410f40e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -737,6 +737,20 @@ let () = } in define_ml_object Tac2env.wit_reference obj +let () = + let interp _ tac = + (** FUCK YOU API *) + (Obj.magic Ltac_plugin.Tacinterp.eval_tactic tac : unit Proofview.tactic) >>= fun () -> + return v_unit + in + let obj = { + ml_type = t_unit; + ml_interp = interp; + } in + define_ml_object Ltac_plugin.Tacarg.wit_tactic obj + +(** Ltac2 in terms *) + let () = let interp ist env sigma concl tac = let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = -- cgit v1.2.3 From bec2a0ad6eb60d33b5e3ab613d108f456df42a49 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 26 Aug 2017 09:40:31 +0200 Subject: Typos --- doc/ltac2.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 51e3ab664d..5b1776b64f 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -488,7 +488,7 @@ Ltac2 Definition myconstr () := constr:(nat -> 0). ``` Term antiquotations are type-checked in the enclosing Ltac2 typing context -of the corresponding term expression. For instance, the following with +of the corresponding term expression. For instance, the following will type-check. ``` @@ -523,7 +523,7 @@ This pattern is so common that we provide dedicated Ltac2 and Coq term notations for it. - `&x` as an Ltac2 expression expands to `hyp @x`. -- `&x` as an Coq constr expression expands to +- `&x` as a Coq constr expression expands to `ltac2:(refine (fun () => hyp @x))`. #### Dynamic semantics @@ -538,7 +538,7 @@ under focus, with the hypotheses coming from the current environment extended with the bound variables of the term, and the resulting term is fed into the quoted term. -Relative orders of evaluation of antiquotations and quoted term is not +Relative orders of evaluation of antiquotations and quoted term are not specified. For instance, in the following example, `tac` will be evaluated in a context -- cgit v1.2.3 From 7f562a9539522e56004596a751758a08cee798b1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Aug 2017 16:58:06 +0200 Subject: Allowing calls to Ltac2 inside Ltac1. --- doc/ltac2.md | 22 ++++++++++++++++++++-- src/tac2core.ml | 20 ++++++++++++++++++++ tests/compat.v | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 2 deletions(-) create mode 100644 tests/compat.v diff --git a/doc/ltac2.md b/doc/ltac2.md index 5b1776b64f..d1c5c68494 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -698,11 +698,30 @@ errors after expansion. One can call Ltac1 code from Ltac2 by using the `ltac1` quotation. It parses a Ltac1 expression, and semantics of this quotation is the evaluation of the -corresponding code for its side effects. +corresponding code for its side effects. In particular, in cannot return values, +and the quotation has type `unit`. Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited to the use of standalone function calls. +## Ltac2 from Ltac1 + +Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation +instead. + +Note that the tactic expression is evaluated eagerly, if one wants to use it as +an argument to a Ltac1 function, she has to resort to the good old +`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately +and won't print anything. + +``` +Ltac mytac tac := idtac "wow"; tac. + +Goal True. +Proof. +mytac ltac2:(fail). +``` + # Transition from Ltac1 Owing to the use of a bunch of notations, the transition shouldn't be @@ -812,6 +831,5 @@ your duty to catch it and reraise it depending on your use. # TODO - Implement deep pattern-matching. -- Implement compatibility layer with Ltac1 - Craft an expressive set of primitive functions - Implement native compilation to OCaml diff --git a/src/tac2core.ml b/src/tac2core.ml index b95410f40e..118bea0f8e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -765,6 +765,26 @@ let () = in Pretyping.register_constr_interp0 wit_ltac2 interp +(** Ltac2 in Ltac1 *) + +let () = + (** FUCK YOU API *) + let e = (Obj.magic Tac2entries.Pltac.tac2expr : _ API.Pcoq.Gram.entry) in + let inject (loc, v) = Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in + Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) + +let () = + let open Ltac_plugin in + let open Tacinterp in + let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in + (** FUCK YOU API *) + let idtac = (Obj.magic idtac : Geninterp.Val.t) in + let interp ist tac = + Tac2interp.interp Tac2interp.empty_environment tac >>= fun _ -> + Ftactic.return idtac + in + Geninterp.register_interp0 wit_ltac2 interp + (** Patterns *) let () = diff --git a/tests/compat.v b/tests/compat.v new file mode 100644 index 0000000000..44421349da --- /dev/null +++ b/tests/compat.v @@ -0,0 +1,56 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +(** Test calls to Ltac1 from Ltac2 *) + +Ltac2 foo () := ltac1:(discriminate). + +Goal true = false -> False. +Proof. +foo (). +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(match goal with [ H : ?P |- _ ] => rewrite H end); reflexivity. +Qed. + +Goal true = false -> false = true. +Proof. +(** FIXME when the non-strict mode is implemented. *) +Fail intros H; ltac1:(rewrite H); reflexivity. +Abort. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac2 bar nay := ltac1:(discriminate nay). + +(** Test calls to Ltac2 from Ltac1 *) + +Set Default Proof Mode "Classic". + +Ltac foo := ltac2:(foo ()). + +Goal true = false -> False. +Proof. +ltac2:(foo ()). +Qed. + +Goal true = false -> False. +Proof. +foo. +Qed. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac bar x := ltac2:(foo x). + +Ltac mytac tac := idtac "wow". + +Goal True. +Proof. +(** Fails because quotation is evaluated eagerly *) +Fail mytac ltac2:(fail). +(** One has to thunk thanks to the idtac trick *) +let t := idtac; ltac2:(fail) in mytac t. +constructor. +Qed. -- cgit v1.2.3 From 9bbdee3c09c92654bb8937b9939a9b9c69c23d1d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Aug 2017 01:04:19 +0200 Subject: Introducing rebindable toplevel definitions. --- doc/ltac2.md | 13 ++++++++- src/g_ltac2.ml4 | 20 +++++++++---- src/tac2entries.ml | 84 +++++++++++++++++++++++++++++++++++++++++++++++++---- src/tac2entries.mli | 2 +- src/tac2env.ml | 14 ++++++--- src/tac2env.mli | 10 +++++-- src/tac2expr.mli | 5 ++-- src/tac2intern.ml | 29 ++++++++++++++---- src/tac2intern.mli | 4 +++ src/tac2interp.ml | 2 +- tests/rebind.v | 24 +++++++++++++++ 11 files changed, 180 insertions(+), 27 deletions(-) create mode 100644 tests/rebind.v diff --git a/doc/ltac2.md b/doc/ltac2.md index d1c5c68494..5c057b3ead 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -218,7 +218,7 @@ Limitations: for now, deep pattern matching is not implemented yet. One can define a new global Ltac2 value using the following syntax. ``` VERNAC ::= -| "Ltac2" RECFLAG LIDENT ":=" TERM +| "Ltac2" MUTFLAG RECFLAG LIDENT ":=" TERM ``` For semantic reasons, the body of the Ltac2 definition must be a syntactical @@ -227,6 +227,17 @@ values. If the `RECFLAG` is set, the tactic is expanded into a recursive binding. +If the `MUTFLAG` is set, the definition can be redefined at a later stage. This +can be performed through the following command. + +``` +VERNAC ::= +| "Ltac2" "Set" QUALID ":=" TERM +``` + +Mutable definitions act like dynamic binding, i.e. at runtime, the last defined +value for this entry is chosen. This is useful for global flags and the like. + ## Reduction We use the usual ML call-by-value reduction, with an otherwise unspecified diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 6822b8e7ba..ae7e255896 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -70,6 +70,7 @@ let tac2def_val = Gram.entry_create "tactic:tac2def_val" let tac2def_typ = Gram.entry_create "tactic:tac2def_typ" let tac2def_ext = Gram.entry_create "tactic:tac2def_ext" let tac2def_syn = Gram.entry_create "tactic:tac2def_syn" +let tac2def_mut = Gram.entry_create "tactic:tac2def_mut" let tac2mode = Gram.entry_create "vernac:ltac2_command" (** FUCK YOU API *) @@ -90,7 +91,8 @@ let pattern_of_qualid loc id = CErrors.user_err ~loc (Pp.str "Syntax error") GEXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn; + GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + tac2def_mut; tac2pat: [ "1" LEFTA [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> @@ -158,6 +160,10 @@ GEXTEND Gram [ [ IDENT "rec" -> true | -> false ] ] ; + mut_flag: + [ [ IDENT "mutable" -> true + | -> false ] ] + ; typ_param: [ [ "'"; id = Prim.ident -> id ] ] ; @@ -228,10 +234,13 @@ GEXTEND Gram ] ] ; tac2def_val: - [ [ isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> - StrVal (isrec, l) + [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + StrVal (mut, isrec, l) ] ] ; + tac2def_mut: + [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> StrMut (qid, e) ] ] + ; tac2typ_knd: [ [ t = tac2type -> CTydDef (Some t) | "["; ".."; "]" -> CTydOpn @@ -253,7 +262,7 @@ GEXTEND Gram | -> [] ] ] ; tac2rec_field: - [ [ mut = [ -> false | IDENT "mutable" -> true]; id = Prim.ident; ":"; t = tac2type -> (id, mut, t) ] ] + [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> (id, mut, t) ] ] ; tac2rec_fieldexprs: [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> f :: l @@ -653,11 +662,12 @@ PRINTED BY pr_ltac2entry | [ tac2def_typ(t) ] -> [ t ] | [ tac2def_ext(e) ] -> [ e ] | [ tac2def_syn(e) ] -> [ e ] +| [ tac2def_mut(e) ] -> [ e ] END let classify_ltac2 = function | StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow -| StrVal _ | StrPrm _ | StrTyp _ -> Vernac_classifier.classify_as_sideeff +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ -> Vernac_classifier.classify_as_sideeff VERNAC COMMAND EXTEND VernacDeclareTactic2Definition | [ "Ltac2" ltac2_entry(e) ] => [ classify_ltac2 e ] -> [ diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 91c8d10e2d..da7c07c134 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -42,20 +42,31 @@ end type tacdef = { tacdef_local : bool; + tacdef_mutable : bool; tacdef_expr : glb_tacexpr; tacdef_type : type_scheme; } let perform_tacdef visibility ((sp, kn), def) = let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp (TacConstant kn) in - Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) + let data = { + Tac2env.gdata_expr = def.tacdef_expr; + gdata_type = def.tacdef_type; + gdata_mutable = def.tacdef_mutable; + } in + Tac2env.define_global kn data let load_tacdef i obj = perform_tacdef (Until i) obj let open_tacdef i obj = perform_tacdef (Exactly i) obj let cache_tacdef ((sp, kn), def) = let () = Tac2env.push_ltac (Until 1) sp (TacConstant kn) in - Tac2env.define_global kn (def.tacdef_expr, def.tacdef_type) + let data = { + Tac2env.gdata_expr = def.tacdef_expr; + gdata_type = def.tacdef_type; + gdata_mutable = def.tacdef_mutable; + } in + Tac2env.define_global kn data let subst_tacdef (subst, def) = let expr' = subst_expr subst def.tacdef_expr in @@ -296,7 +307,7 @@ let inline_rec_tactic tactics = in List.map map tactics -let register_ltac ?(local = false) isrec tactics = +let register_ltac ?(local = false) ?(mut = false) isrec tactics = let map ((loc, na), e) = let id = match na with | Anonymous -> @@ -329,6 +340,7 @@ let register_ltac ?(local = false) isrec tactics = let iter (id, e, t) = let def = { tacdef_local = local; + tacdef_mutable = mut; tacdef_expr = e; tacdef_type = t; } in @@ -423,6 +435,7 @@ let register_primitive ?(local = false) (loc, id) t ml = let e = GTacFun (bnd, GTacPrm (ml, arg)) in let def = { tacdef_local = local; + tacdef_mutable = false; tacdef_expr = e; tacdef_type = t; } in @@ -659,13 +672,72 @@ let register_notation ?(local = false) tkn lev body = match tkn, lev with } in Lib.add_anonymous_leaf (inTac2Notation ext) +type redefinition = { + redef_kn : ltac_constant; + redef_body : glb_tacexpr; +} + +let perform_redefinition (_, redef) = + let kn = redef.redef_kn in + let data, _ = Tac2env.interp_global kn in + let data = { data with Tac2env.gdata_expr = redef.redef_body } in + Tac2env.define_global kn data + +let subst_redefinition (subst, redef) = + let kn = Mod_subst.subst_kn subst redef.redef_kn in + let body = Tac2intern.subst_expr subst redef.redef_body in + if kn == redef.redef_kn && body == redef.redef_body then redef + else { redef_kn = kn; redef_body = body } + +let classify_redefinition o = Substitute o + +let inTac2Redefinition : redefinition -> obj = + declare_object {(default_object "TAC2-REDEFINITION") with + cache_function = perform_redefinition; + open_function = (fun _ -> perform_redefinition); + subst_function = subst_redefinition; + classify_function = classify_redefinition } + +let register_redefinition ?(local = false) (loc, qid) e = + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) + in + let kn = match kn with + | TacConstant kn -> kn + | TacAlias _ -> + user_err ?loc (str "Cannot redefine syntactic abbreviations") + in + let (data, _) = Tac2env.interp_global kn in + let () = + if not (data.Tac2env.gdata_mutable) then + user_err ?loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") + in + let (e, t) = intern e in + let () = + if not (is_value e) then + user_err ?loc (str "Tactic definition must be a syntactical value") + in + let () = + if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then + let name = int_name () in + user_err ?loc (str "Type " ++ pr_glbtype name (snd t) ++ + str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) + in + let def = { + redef_kn = kn; + redef_body = e; + } in + Lib.add_anonymous_leaf (inTac2Redefinition def) + (** Toplevel entries *) let register_struct ?local str = match str with -| StrVal (isrec, e) -> register_ltac ?local isrec e +| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e +| StrMut (qid, e) -> register_redefinition ?local qid e (** Printing *) @@ -685,7 +757,9 @@ let print_ltac ref = in match kn with | TacConstant kn -> - let (e, _, (_, t)) = Tac2env.interp_global kn in + let data, _ = Tac2env.interp_global kn in + let e = data.Tac2env.gdata_expr in + let (_, t) = data.Tac2env.gdata_type in let name = int_name () in Feedback.msg_notice ( hov 0 ( diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 2c5862b149..acb99a34b1 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -13,7 +13,7 @@ open Tac2expr (** {5 Toplevel definitions} *) -val register_ltac : ?local:bool -> rec_flag -> +val register_ltac : ?local:bool -> ?mut:bool -> rec_flag -> (Name.t located * raw_tacexpr) list -> unit val register_type : ?local:bool -> rec_flag -> diff --git a/src/tac2env.ml b/src/tac2env.ml index 65276ec57f..59344e336b 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -12,6 +12,12 @@ open Names open Libnames open Tac2expr +type global_data = { + gdata_expr : glb_tacexpr; + gdata_type : type_scheme; + gdata_mutable : bool; +} + type constructor_data = { cdata_prms : int; cdata_type : type_constant; @@ -28,7 +34,7 @@ type projection_data = { } type ltac_state = { - ltac_tactics : (glb_tacexpr * type_scheme) KNmap.t; + ltac_tactics : global_data KNmap.t; ltac_constructors : constructor_data KNmap.t; ltac_projections : projection_data KNmap.t; ltac_types : glb_quant_typedef KNmap.t; @@ -49,7 +55,7 @@ let ltac_state = Summary.ref empty_state ~name:"ltac2-state" let rec eval_pure = function | GTacAtm (AtmInt n) -> ValInt n | GTacRef kn -> - let (e, _) = + let { gdata_expr = e } = try KNmap.find kn ltac_state.contents.ltac_tactics with Not_found -> assert false in @@ -68,8 +74,8 @@ let define_global kn e = ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } let interp_global kn = - let (e, t) = KNmap.find kn ltac_state.contents.ltac_tactics in - (e, eval_pure e, t) + let data = KNmap.find kn ltac_state.contents.ltac_tactics in + (data, eval_pure data.gdata_expr) let define_constructor kn t = let state = !ltac_state in diff --git a/src/tac2env.mli b/src/tac2env.mli index 20bf24d19d..8a5fb531d8 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -16,8 +16,14 @@ open Tac2expr (** {5 Toplevel definition of values} *) -val define_global : ltac_constant -> (glb_tacexpr * type_scheme) -> unit -val interp_global : ltac_constant -> (glb_tacexpr * valexpr * type_scheme) +type global_data = { + gdata_expr : glb_tacexpr; + gdata_type : type_scheme; + gdata_mutable : bool; +} + +val define_global : ltac_constant -> global_data -> unit +val interp_global : ltac_constant -> global_data * valexpr (** {5 Toplevel definition of types} *) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 281ed6c81e..78611d51ca 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -154,7 +154,7 @@ type sexpr = (** {5 Toplevel statements} *) type strexpr = -| StrVal of rec_flag * (Name.t located * raw_tacexpr) list +| StrVal of mutable_flag * rec_flag * (Name.t located * raw_tacexpr) list (** Term definition *) | StrTyp of rec_flag * (qualid located * redef_flag * raw_quant_typedef) list (** Type definition *) @@ -162,7 +162,8 @@ type strexpr = (** External definition *) | StrSyn of sexpr list * int option * raw_tacexpr (** Syntactic extensions *) - +| StrMut of qualid located * raw_tacexpr + (** Redefinition of mutable globals *) (** {5 Dynamic semantics} *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 765be92103..ef0763ff8e 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -360,20 +360,20 @@ let eq_or_tuple eq t1 t2 = match t1, t2 with | Other o1, Other o2 -> eq o1 o2 | _ -> false -let rec unify env t1 t2 = match kind env t1, kind env t2 with +let rec unify0 env t1 t2 = match kind env t1, kind env t2 with | GTypVar id, t | t, GTypVar id -> unify_var env id t | GTypArrow (t1, u1), GTypArrow (t2, u2) -> - let () = unify env t1 t2 in - unify env u1 u2 + let () = unify0 env t1 t2 in + unify0 env u1 u2 | GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> if eq_or_tuple KerName.equal kn1 kn2 then - List.iter2 (fun t1 t2 -> unify env t1 t2) tl1 tl2 + List.iter2 (fun t1 t2 -> unify0 env t1 t2) tl1 tl2 else raise (CannotUnify (t1, t2)) | _ -> raise (CannotUnify (t1, t2)) let unify ?loc env t1 t2 = - try unify env t1 t2 + try unify0 env t1 t2 with CannotUnify (u1, u2) -> user_err ?loc (str "This expression has type " ++ pr_glbtype env t1 ++ str " but an expression was expected of type " ++ pr_glbtype env t2) @@ -663,7 +663,7 @@ let rec intern_rec env = function let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) | ArgArg (TacConstant kn) -> - let (_, _, sch) = Tac2env.interp_global kn in + let { Tac2env.gdata_type = sch }, _ = Tac2env.interp_global kn in (GTacRef kn, fresh_type_scheme env sch) | ArgArg (TacAlias kn) -> let e = Tac2env.interp_alias kn in @@ -1162,6 +1162,23 @@ let intern_open_type t = let t = normalize env (count, vars) t in (!count, t) +(** Subtyping *) + +let check_subtype t1 t2 = + let env = empty_env () in + let t1 = fresh_type_scheme env t1 in + (** We build a substitution mimicking rigid variable by using dummy refs *) + let mb = MBId.make DirPath.empty (Id.of_string "_t") in + let rigid i = + let kn = KerName.make (MPbound mb) DirPath.empty (Label.make "_t") in + GTypRef (Other kn, []) + in + let (n, t2) = t2 in + let subst = Array.init n rigid in + let substf i = subst.(i) in + let t2 = subst_type substf t2 in + try unify0 env t1 t2; true with CannotUnify _ -> false + (** Globalization *) let get_projection0 var = match var with diff --git a/src/tac2intern.mli b/src/tac2intern.mli index 898df649ba..dac074a0eb 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -22,6 +22,10 @@ val intern_open_type : raw_typexpr -> type_scheme val is_value : glb_tacexpr -> bool val check_unit : ?loc:Loc.t -> type_scheme -> unit +val check_subtype : type_scheme -> type_scheme -> bool +(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] + also have type [t2]. *) + val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef diff --git a/src/tac2interp.ml b/src/tac2interp.ml index d3bc79957b..3e1a048d29 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -38,7 +38,7 @@ let get_var ist id = anomaly (str "Unbound variable " ++ Id.print id) let get_ref ist kn = - try pi2 (Tac2env.interp_global kn) with Not_found -> + try snd (Tac2env.interp_global kn) with Not_found -> anomaly (str "Unbound reference" ++ KerName.print kn) let return = Proofview.tclUNIT diff --git a/tests/rebind.v b/tests/rebind.v new file mode 100644 index 0000000000..270fdd0b69 --- /dev/null +++ b/tests/rebind.v @@ -0,0 +1,24 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 mutable foo () := constructor. + +Goal True. +Proof. +foo (). +Qed. + +Ltac2 Set foo := fun _ => fail. + +Goal True. +Proof. +Fail foo (). +constructor. +Qed. + +(** Not the right type *) +Fail Ltac2 Set foo := 0. + +Ltac2 bar () := (). + +(** Cannot redefine non-mutable tactics *) +Fail Ltac2 Set bar := fun _ => (). -- cgit v1.2.3 From c6d28beca01809dbd06b3b36ea53bd4a94824083 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Aug 2017 17:07:15 +0200 Subject: Proper handling of rigid variables in subtyping. --- src/tac2intern.ml | 8 ++------ tests/rebind.v | 10 ++++++++++ 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index ef0763ff8e..40e0ffb34e 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -1167,12 +1167,8 @@ let intern_open_type t = let check_subtype t1 t2 = let env = empty_env () in let t1 = fresh_type_scheme env t1 in - (** We build a substitution mimicking rigid variable by using dummy refs *) - let mb = MBId.make DirPath.empty (Id.of_string "_t") in - let rigid i = - let kn = KerName.make (MPbound mb) DirPath.empty (Label.make "_t") in - GTypRef (Other kn, []) - in + (** We build a substitution mimicking rigid variable by using dummy tuples *) + let rigid i = GTypRef (Tuple i, []) in let (n, t2) = t2 in let subst = Array.init n rigid in let substf i = subst.(i) in diff --git a/tests/rebind.v b/tests/rebind.v index 270fdd0b69..e1c20a2059 100644 --- a/tests/rebind.v +++ b/tests/rebind.v @@ -22,3 +22,13 @@ Ltac2 bar () := (). (** Cannot redefine non-mutable tactics *) Fail Ltac2 Set bar := fun _ => (). + +(** Subtype check *) + +Ltac2 mutable rec f x := f x. + +Fail Ltac2 Set f := fun x => x. + +Ltac2 mutable g x := x. + +Ltac2 Set g := f. -- cgit v1.2.3 From 4c822dbb1c01139e95c165515777703263806ec1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Aug 2017 17:17:00 +0200 Subject: Ensure no confusion with unit in rigid variables. --- src/tac2intern.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 40e0ffb34e..5c1c90e924 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -1168,7 +1168,7 @@ let check_subtype t1 t2 = let env = empty_env () in let t1 = fresh_type_scheme env t1 in (** We build a substitution mimicking rigid variable by using dummy tuples *) - let rigid i = GTypRef (Tuple i, []) in + let rigid i = GTypRef (Tuple (i + 1), []) in let (n, t2) = t2 in let subst = Array.init n rigid in let substf i = subst.(i) in -- cgit v1.2.3 From e430e9823960a136ee65c5977d89113574413449 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Aug 2017 20:22:12 +0200 Subject: Fix semantics of the solve tactical. --- theories/Notations.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Notations.v b/theories/Notations.v index 2a496b3faf..ea31d4ef47 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -84,7 +84,7 @@ Ltac2 rec solve0 tacs := match tacs with | [] => Control.zero Tactic_failure | tac :: tacs => - Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => first0 tacs)) + Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) end. Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. -- cgit v1.2.3 From 0a5097752646f5bf3fd542880d4e33ece771f588 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Aug 2017 20:44:53 +0200 Subject: Notation for clear. --- theories/Notations.v | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/theories/Notations.v b/theories/Notations.v index ea31d4ef47..46c0e5e79f 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -329,7 +329,13 @@ Ltac2 Notation etransitivity := Std.etransitivity (). Ltac2 Notation admit := Std.admit (). -Ltac2 Notation clear := Std.keep []. +Ltac2 clear0 ids := match ids with +| [] => Std.keep [] +| _ => Std.clear ids +end. + +Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. +Ltac2 Notation clear := clear. Ltac2 Notation refine := Control.refine. -- cgit v1.2.3 From 6bb9c33f0e35a694ca253bc766f9a235d2073a4f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Aug 2017 21:33:55 +0200 Subject: Do not reuse the Val.t type in toplevel values. --- src/tac2core.ml | 6 +++--- src/tac2expr.mli | 2 +- src/tac2ffi.ml | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 118bea0f8e..5b752840a4 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -691,7 +691,7 @@ let interp_constr flags ist (c, _) = Proofview.V82.wrap_exceptions begin fun () -> let ist = to_lvar ist in let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = ValExt (Val.Dyn (Value.val_constr, c)) in + let c = ValExt (Value.val_constr, c) in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c end @@ -714,7 +714,7 @@ let () = define_ml_object Stdarg.wit_open_constr obj let () = - let interp _ id = return (ValExt (Val.Dyn (Value.val_ident, id))) in + let interp _ id = return (ValExt (Value.val_ident, id)) in let obj = { ml_type = t_ident; ml_interp = interp; @@ -722,7 +722,7 @@ let () = define_ml_object Stdarg.wit_ident obj let () = - let interp _ c = return (ValExt (Val.Dyn (Value.val_pattern, c))) in + let interp _ c = return (ValExt (Value.val_pattern, c)) in let obj = { ml_type = t_pattern; ml_interp = interp; diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 78611d51ca..0c9112d902 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -186,7 +186,7 @@ type valexpr = (** Closures *) | ValOpn of KerName.t * valexpr array (** Open constructors *) -| ValExt of Geninterp.Val.t +| ValExt : 'a Geninterp.Val.typ * 'a -> valexpr (** Arbitrary data *) and closure = { diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index b506a578b1..a9a0f5a479 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -33,7 +33,7 @@ let val_univ = Val.create "ltac2:universe" let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ = Val.create "ltac2:kont" -let extract_val (type a) (tag : a Val.typ) (Val.Dyn (tag', v)) : a = +let extract_val (type a) (type b) (tag : a Val.typ) (tag' : b Val.typ) (v : b) : a = match Val.eq tag tag' with | None -> assert false | Some Refl -> v @@ -78,10 +78,10 @@ let rec to_list f = function | _ -> assert false let of_ext tag c = - ValExt (Val.Dyn (tag, c)) + ValExt (tag, c) let to_ext tag = function -| ValExt e -> extract_val tag e +| ValExt (tag', e) -> extract_val tag tag' e | _ -> assert false let of_constr c = of_ext val_constr c -- cgit v1.2.3 From 99ec137899c2684da2a8c221f333e0e9adee2c48 Mon Sep 17 00:00:00 2001 From: gallais Date: Mon, 28 Aug 2017 14:33:17 +0200 Subject: typos --- doc/ltac2.md | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 5c057b3ead..dd0dc391c6 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -149,7 +149,7 @@ Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `RECFLAG` is set. Open variants are a special kind of variant types whose constructors are not -statically defined, but can instead by extended dynamically. A typical example +statically defined, but can instead be extended dynamically. A typical example is the standard `exn` type. Pattern-matching must always include a catch-all clause. They can be extended by the following command. @@ -358,21 +358,21 @@ If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is list concatenation, while `case` is pattern-matching. The backtracking is first-class, i.e. one can write -`plus "x" (fun () => "y") : string` producing a backtracking string. +`plus (fun () => "x") (fun _ => "y") : string` producing a backtracking string. These operations are expected to satisfy a few equations, most notably that they form a monoid compatible with sequentialization. ``` plus t zero ≡ t () -plus (fun () -> zero e) f ≡ f e -plus (plus t f) g ≡ plus t (fun e -> plus (f e) g) +plus (fun () => zero e) f ≡ f e +plus (plus t f) g ≡ plus t (fun e => plus (f e) g) -case (fun () -> zero e) ≡ Err e -case (fun () -> plus (fun () -> t) f) ≡ Val t f +case (fun () => zero e) ≡ Err e +case (fun () => plus (fun () => t) f) ≡ Val t f let x := zero e in u ≡ zero e -let x := plus t f in u ≡ plus (fun () -> let x := t in u) (fun e -> let x := f e in u) +let x := plus t f in u ≡ plus (fun () => let x := t in u) (fun e => let x := f e in u) (t, u, f, g, e values) ``` @@ -809,7 +809,7 @@ Ltac1 relies on a crazy amount of dynamic trickery to be able to tell apart bound variables from terms, hypotheses and whatnot. There is no such thing in Ltac2, as variables are recognized statically and other constructions do not live in the same syntactic world. Due to the abuse of quotations, it can -sometimes be complicated to know what a mere identifier represent in a tactic +sometimes be complicated to know what a mere identifier represents in a tactic expression. We recommend tracking the context and letting the compiler spit typing errors to understand what is going on. -- cgit v1.2.3 From ee7ebf17245c65b630d5b7c01de8ad9253bd9523 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Aug 2017 20:31:33 +0200 Subject: Fix coq/ltac2#6: Expected and actual types are flipped. --- src/tac2intern.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 5c1c90e924..9d22b18af4 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -947,7 +947,7 @@ and intern_case env loc e pl = in brT in - let () = unify ~loc:(loc_of_tacexpr br) env ret tbr in + let () = unify ~loc:(loc_of_tacexpr br) env tbr ret in intern_branch rem in let () = intern_branch pl in -- cgit v1.2.3 From ad730081c470705fed0c3741a0373090ab9c7d17 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Aug 2017 22:00:44 +0200 Subject: Fix README. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 4d6879d8af..73785f6368 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ bug-ridden. Don't mistake this for a final product! Installation ============ -This should compile with Coq 8.7, assuming the `COQLIB` variable is set +This should compile with Coq master, assuming the `COQBIN` variable is set correctly. Standard procedures for `coq_makefile`-generated plugins apply. Demo -- cgit v1.2.3 From 8ba24b7342c3885145406e588859a3e1e356987d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Aug 2017 22:43:32 +0200 Subject: Binding primitives to generate fresh variables. --- _CoqProject | 1 + src/tac2core.ml | 45 ++++++++++++++++++++++++++++++++++++++++++++- theories/Fresh.v | 26 ++++++++++++++++++++++++++ 3 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 theories/Fresh.v diff --git a/_CoqProject b/_CoqProject index 4116d17554..ffe1dda032 100644 --- a/_CoqProject +++ b/_CoqProject @@ -36,6 +36,7 @@ theories/Control.v theories/Message.v theories/Constr.v theories/Pattern.v +theories/Fresh.v theories/Std.v theories/Notations.v theories/Ltac2.v diff --git a/src/tac2core.ml b/src/tac2core.ml index 5b752840a4..4a4f9afd88 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -66,7 +66,8 @@ let of_rec_declaration (nas, ts, cs) = Value.of_array Value.of_constr ts, Value.of_array Value.of_constr cs) -let val_valexpr = Val.create "ltac2:valexpr" +let val_valexpr : valexpr Val.typ = Val.create "ltac2:valexpr" +let val_free : Id.Set.t Val.typ = Val.create "ltac2:free" (** Stdlib exceptions *) @@ -593,6 +594,43 @@ let prm_check_interrupt : ml_tactic = function | [_] -> Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit | _ -> assert false +(** Fresh *) + +let prm_free_union : ml_tactic = function +| [set1; set2] -> + let set1 = Value.to_ext val_free set1 in + let set2 = Value.to_ext val_free set2 in + let ans = Id.Set.union set1 set2 in + return (Value.of_ext val_free ans) +| _ -> assert false + +let prm_free_of_ids : ml_tactic = function +| [ids] -> + let ids = Value.to_list Value.to_ident ids in + let free = List.fold_right Id.Set.add ids Id.Set.empty in + return (Value.of_ext val_free free) +| _ -> assert false + +let prm_free_of_constr : ml_tactic = function +| [c] -> + let c = Value.to_constr c in + Proofview.tclEVARMAP >>= fun sigma -> + let rec fold accu c = match EConstr.kind sigma c with + | Constr.Var id -> Id.Set.add id accu + | _ -> EConstr.fold sigma fold accu c + in + let ans = fold Id.Set.empty c in + return (Value.of_ext val_free ans) +| _ -> assert false + +let prm_fresh : ml_tactic = function +| [avoid; id] -> + let avoid = Value.to_ext val_free avoid in + let id = Value.to_ident id in + let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in + return (Value.of_ident nid) +| _ -> assert false + (** Registering *) let () = Tac2env.define_primitive (pname "print") prm_print @@ -656,6 +694,11 @@ let () = Tac2env.define_primitive (pname "abstract") prm_abstract let () = Tac2env.define_primitive (pname "time") prm_time let () = Tac2env.define_primitive (pname "check_interrupt") prm_check_interrupt +let () = Tac2env.define_primitive (pname "fresh_fresh") prm_fresh +let () = Tac2env.define_primitive (pname "fresh_free_union") prm_free_union +let () = Tac2env.define_primitive (pname "fresh_free_of_ids") prm_free_of_ids +let () = Tac2env.define_primitive (pname "fresh_free_of_constr") prm_free_of_constr + (** ML types *) let constr_flags () = diff --git a/theories/Fresh.v b/theories/Fresh.v new file mode 100644 index 0000000000..5e876bb077 --- /dev/null +++ b/theories/Fresh.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> t := "ltac2" "fresh_free_union". + +Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". + +Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". + +End Free. + +Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". +(** Generate a fresh identifier with the given base name which is not a + member of the provided set of free variables. *) -- cgit v1.2.3 From ece1cc059c26351d05a0ef41131c663c37cb7761 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 00:40:40 +0200 Subject: Binding an unsafe substitution function. --- src/tac2core.ml | 10 ++++++++++ theories/Constr.v | 4 ++++ 2 files changed, 14 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index 4a4f9afd88..0fe4bc5fde 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -366,6 +366,15 @@ let prm_constr_kind : ml_tactic = function end | _ -> assert false +let prm_constr_substnl : ml_tactic = function +| [subst; k; c] -> + let subst = Value.to_list Value.to_constr subst in + let k = Value.to_int k in + let c = Value.to_constr c in + let ans = EConstr.Vars.substnl subst k c in + return (Value.of_constr ans) +| _ -> assert false + (** Patterns *) let prm_pattern_matches : ml_tactic = function @@ -653,6 +662,7 @@ let () = Tac2env.define_primitive (pname "string_set") prm_string_set let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal let () = Tac2env.define_primitive (pname "constr_kind") prm_constr_kind +let () = Tac2env.define_primitive (pname "constr_substnl") prm_constr_substnl let () = Tac2env.define_primitive (pname "pattern_matches") prm_pattern_matches let () = Tac2env.define_primitive (pname "pattern_matches_subterm") prm_pattern_matches_subterm diff --git a/theories/Constr.v b/theories/Constr.v index d7cd3b58a3..bb02d94531 100644 --- a/theories/Constr.v +++ b/theories/Constr.v @@ -40,4 +40,8 @@ Ltac2 Type kind := [ Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". +Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". +(** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with + [r₁;...;rₙ] in [c]. *) + End Unsafe. -- cgit v1.2.3 From db03c10aaafd3c0128a5b7504f14d4b7aaca842e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 01:16:21 +0200 Subject: Implementing Ltac2 antiquotations in constr syntax. --- src/g_ltac2.ml4 | 14 ++++++++++++++ src/tac2quote.ml | 5 +++++ src/tac2quote.mli | 3 +++ tests/quot.v | 7 +++++++ 4 files changed, 29 insertions(+) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index ae7e255896..672db12f1d 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -64,6 +64,16 @@ let test_ampersand_ident = | _ -> err ()) | _ -> err ()) +let test_dollar_ident = + Gram.Entry.of_parser "test_dollar_ident" + (fun strm -> + match stream_nth 0 strm with + | IDENT "$" | KEYWORD "$" -> + (match stream_nth 1 strm with + | IDENT _ -> () + | _ -> err ()) + | _ -> err ()) + let tac2expr = Tac2entries.Pltac.tac2expr let tac2type = Gram.entry_create "tactic:tac2type" let tac2def_val = Gram.entry_create "tactic:tac2def_val" @@ -649,6 +659,10 @@ GEXTEND Gram let tac = Tac2quote.of_exact_hyp ~loc:!@loc (Loc.tag ~loc:!@loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) + | test_dollar_ident; "$"; id = Prim.ident -> + let tac = Tac2quote.of_exact_var ~loc:!@loc (Loc.tag ~loc:!@loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) ] ] ; END diff --git a/src/tac2quote.ml b/src/tac2quote.ml index dbd2fd0529..f87e370032 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -233,6 +233,11 @@ let of_exact_hyp ?loc id = let refine = CTacRef (AbsKn (TacConstant (control_core "refine"))) in CTacApp (loc, refine, [thunk (of_hyp ~loc id)]) +let of_exact_var ?loc id = + let loc = Option.default dummy_loc loc in + let refine = CTacRef (AbsKn (TacConstant (control_core "refine"))) in + CTacApp (loc, refine, [thunk (of_variable id)]) + let of_dispatch tacs = let loc = Option.default dummy_loc (fst tacs) in let default = function diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 7f3d9dce6e..b2687f01a3 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -58,6 +58,9 @@ val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) +val of_exact_var : ?loc:Loc.t -> Id.t located -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + val of_dispatch : dispatch -> raw_tacexpr val of_strategy_flag : strategy_flag -> raw_tacexpr diff --git a/tests/quot.v b/tests/quot.v index c9aa1f9d14..4fa9c4fa4e 100644 --- a/tests/quot.v +++ b/tests/quot.v @@ -7,3 +7,10 @@ Ltac2 ref1 () := reference:(nat). Ltac2 ref2 () := reference:(Datatypes.nat). Fail Ltac2 ref () := reference:(i_certainly_dont_exist). Fail Ltac2 ref () := reference:(And.Me.neither). + +Goal True. +Proof. +let x := constr:(I) in +let y := constr:((fun z => z) $x) in +Control.refine (fun _ => y). +Qed. -- cgit v1.2.3 From 9f79d601c0863d5144fc07c5cea0e03ef41d244b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 14:04:23 +0200 Subject: Factorizing code for declaration of primitive tactics. --- src/tac2core.ml | 382 ++++++++++++++++++++++---------------------------------- 1 file changed, 152 insertions(+), 230 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 0fe4bc5fde..609dd40587 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -53,6 +53,10 @@ open Core let v_unit = ValInt 0 +let to_block = function +| ValBlk (_, v) -> v +| _ -> assert false + let of_name c = match c with | Anonymous -> Value.of_option Value.of_ident None | Name id -> Value.of_option Value.of_ident (Some id) @@ -111,146 +115,159 @@ let pf_apply f = (** Primitives *) -(** Printing *) +let define0 name f = Tac2env.define_primitive (pname name) begin function +| [_] -> f +| _ -> assert false +end -let prm_print : ml_tactic = function -| [pp] -> wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) +let define1 name f = Tac2env.define_primitive (pname name) begin function +| [x] -> f x | _ -> assert false +end -let prm_message_of_int : ml_tactic = function -| [ValInt s] -> return (Value.of_pp (int s)) +let define2 name f = Tac2env.define_primitive (pname name) begin function +| [x; y] -> f x y | _ -> assert false +end -let prm_message_of_string : ml_tactic = function -| [ValStr s] -> return (Value.of_pp (str (Bytes.to_string s))) +let define3 name f = Tac2env.define_primitive (pname name) begin function +| [x; y; z] -> f x y z | _ -> assert false +end -let prm_message_of_constr : ml_tactic = function -| [c] -> +(** Printing *) + +let () = define1 "print" begin fun pp -> + wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) +end + +let () = define1 "message_of_int" begin fun n -> + let n = Value.to_int n in + return (Value.of_pp (int n)) +end + +let () = define1 "message_of_string" begin fun s -> + let s = Value.to_string s in + return (Value.of_pp (str (Bytes.to_string s))) +end + +let () = define1 "message_of_constr" begin fun c -> pf_apply begin fun env sigma -> let c = Value.to_constr c in let pp = Printer.pr_econstr_env env sigma c in return (Value.of_pp pp) end -| _ -> assert false +end -let prm_message_of_ident : ml_tactic = function -| [c] -> +let () = define1 "message_of_ident" begin fun c -> let c = Value.to_ident c in let pp = Id.print c in return (Value.of_pp pp) -| _ -> assert false +end -let prm_message_concat : ml_tactic = function -| [m1; m2] -> +let () = define2 "message_concat" begin fun m1 m2 -> let m1 = Value.to_pp m1 in let m2 = Value.to_pp m2 in return (Value.of_pp (Pp.app m1 m2)) -| _ -> assert false +end (** Array *) -let prm_array_make : ml_tactic = function -| [ValInt n; x] -> +let () = define2 "array_make" begin fun n x -> + let n = Value.to_int n in if n < 0 || n > Sys.max_array_length then throw err_outofbounds else wrap (fun () -> ValBlk (0, Array.make n x)) -| _ -> assert false +end -let prm_array_length : ml_tactic = function -| [ValBlk (_, v)] -> return (ValInt (Array.length v)) -| _ -> assert false +let () = define1 "array_length" begin fun v -> + let v = to_block v in + return (ValInt (Array.length v)) +end -let prm_array_set : ml_tactic = function -| [ValBlk (_, v); ValInt n; x] -> +let () = define3 "array_set" begin fun v n x -> + let v = to_block v in + let n = Value.to_int n in if n < 0 || n >= Array.length v then throw err_outofbounds else wrap_unit (fun () -> v.(n) <- x) -| _ -> assert false +end -let prm_array_get : ml_tactic = function -| [ValBlk (_, v); ValInt n] -> +let () = define2 "array_get" begin fun v n -> + let v = to_block v in + let n = Value.to_int n in if n < 0 || n >= Array.length v then throw err_outofbounds else wrap (fun () -> v.(n)) -| _ -> assert false +end (** Ident *) -let prm_ident_equal : ml_tactic = function -| [id1; id2] -> +let () = define2 "ident_equal" begin fun id1 id2 -> let id1 = Value.to_ident id1 in let id2 = Value.to_ident id2 in return (Value.of_bool (Id.equal id1 id2)) -| _ -> assert false +end -let prm_ident_to_string : ml_tactic = function -| [id] -> +let () = define1 "ident_to_string" begin fun id -> let id = Value.to_ident id in return (Value.of_string (Id.to_string id)) -| _ -> assert false +end -let prm_ident_of_string : ml_tactic = function -| [s] -> +let () = define1 "ident_of_string" begin fun s -> let s = Value.to_string s in let id = try Some (Id.of_string s) with _ -> None in return (Value.of_option Value.of_ident id) -| _ -> assert false +end (** Int *) -let prm_int_equal : ml_tactic = function -| [m; n] -> +let () = define2 "int_equal" begin fun m n -> return (Value.of_bool (Value.to_int m == Value.to_int n)) -| _ -> assert false +end -let binop f : ml_tactic = function -| [m; n] -> return (Value.of_int (f (Value.to_int m) (Value.to_int n))) -| _ -> assert false +let binop n f = define2 n begin fun m n -> + return (Value.of_int (f (Value.to_int m) (Value.to_int n))) +end -let prm_int_compare args = binop Int.compare args -let prm_int_add args = binop (+) args -let prm_int_sub args = binop (-) args -let prm_int_mul args = binop ( * ) args +let () = binop "int_compare" Int.compare +let () = binop "int_add" (+) +let () = binop "int_sub" (-) +let () = binop "int_mul" ( * ) -let prm_int_neg : ml_tactic = function -| [m] -> return (Value.of_int (~- (Value.to_int m))) -| _ -> assert false +let () = define1 "int_neg" begin fun m -> + return (Value.of_int (~- (Value.to_int m))) +end (** String *) -let prm_string_make : ml_tactic = function -| [n; c] -> +let () = define2 "string_make" begin fun n c -> let n = Value.to_int n in let c = Value.to_char c in if n < 0 || n > Sys.max_string_length then throw err_outofbounds else wrap (fun () -> Value.of_string (Bytes.make n c)) -| _ -> assert false +end -let prm_string_length : ml_tactic = function -| [s] -> +let () = define1 "string_length" begin fun s -> return (Value.of_int (Bytes.length (Value.to_string s))) -| _ -> assert false +end -let prm_string_set : ml_tactic = function -| [s; n; c] -> +let () = define3 "string_set" begin fun s n c -> let s = Value.to_string s in let n = Value.to_int n in let c = Value.to_char c in if n < 0 || n >= Bytes.length s then throw err_outofbounds else wrap_unit (fun () -> Bytes.set s n c) -| _ -> assert false +end -let prm_string_get : ml_tactic = function -| [s; n] -> +let () = define2 "string_get" begin fun s n -> let s = Value.to_string s in let n = Value.to_int n in if n < 0 || n >= Bytes.length s then throw err_outofbounds else wrap (fun () -> Value.of_char (Bytes.get s n)) -| _ -> assert false +end (** Terms *) (** constr -> constr *) -let prm_constr_type : ml_tactic = function -| [c] -> +let () = define1 "constr_type" begin fun c -> let c = Value.to_constr c in let get_type env sigma = Proofview.V82.wrap_exceptions begin fun () -> @@ -259,20 +276,18 @@ let prm_constr_type : ml_tactic = function Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t end in pf_apply get_type -| _ -> assert false +end (** constr -> constr *) -let prm_constr_equal : ml_tactic = function -| [c1; c2] -> +let () = define2 "constr_equal" begin fun c1 c2 -> let c1 = Value.to_constr c1 in let c2 = Value.to_constr c2 in Proofview.tclEVARMAP >>= fun sigma -> let b = EConstr.eq_constr sigma c1 c2 in Proofview.tclUNIT (Value.of_bool b) -| _ -> assert false +end -let prm_constr_kind : ml_tactic = function -| [c] -> +let () = define1 "constr_kind" begin fun c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> let c = Value.to_constr c in @@ -364,21 +379,19 @@ let prm_constr_kind : ml_tactic = function Value.of_constr c; |]) end -| _ -> assert false +end -let prm_constr_substnl : ml_tactic = function -| [subst; k; c] -> +let () = define3 "constr_substnl" begin fun subst k c -> let subst = Value.to_list Value.to_constr subst in let k = Value.to_int k in let c = Value.to_constr c in let ans = EConstr.Vars.substnl subst k c in return (Value.of_constr ans) -| _ -> assert false +end (** Patterns *) -let prm_pattern_matches : ml_tactic = function -| [pat; c] -> +let () = define2 "pattern_matches" begin fun pat c -> let pat = Value.to_pattern pat in let c = Value.to_constr c in pf_apply begin fun env sigma -> @@ -394,10 +407,9 @@ let prm_pattern_matches : ml_tactic = function return (Value.of_list of_pair ans) end end -| _ -> assert false +end -let prm_pattern_matches_subterm : ml_tactic = function -| [pat; c] -> +let () = define2 "pattern_matches_subterm" begin fun pat c -> let pat = Value.to_pattern pat in let c = Value.to_constr c in let open Constr_matching in @@ -413,74 +425,66 @@ let prm_pattern_matches_subterm : ml_tactic = function let ans = Constr_matching.match_appsubterm env sigma pat c in of_ans ans end -| _ -> assert false +end -let prm_pattern_instantiate : ml_tactic = function -| [ctx; c] -> +let () = define2 "pattern_instantiate" begin fun ctx c -> let ctx = EConstr.Unsafe.to_constr (Value.to_constr ctx) in let c = EConstr.Unsafe.to_constr (Value.to_constr c) in let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in return (Value.of_constr (EConstr.of_constr ans)) -| _ -> assert false +end (** Error *) -let prm_throw : ml_tactic = function -| [e] -> +let () = define1 "throw" begin fun e -> let (e, info) = Value.to_exn e in Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) -| _ -> assert false +end (** Control *) (** exn -> 'a *) -let prm_zero : ml_tactic = function -| [e] -> +let () = define1 "zero" begin fun e -> let (e, info) = Value.to_exn e in Proofview.tclZERO ~info e -| _ -> assert false +end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) -let prm_plus : ml_tactic = function -| [x; k] -> +let () = define2 "plus" begin fun x k -> Proofview.tclOR (thaw x) (fun e -> interp_app k [Value.of_exn e]) -| _ -> assert false +end (** (unit -> 'a) -> 'a *) -let prm_once : ml_tactic = function -| [f] -> Proofview.tclONCE (thaw f) -| _ -> assert false +let () = define1 "once" begin fun f -> + Proofview.tclONCE (thaw f) +end (** (unit -> unit) list -> unit *) -let prm_dispatch : ml_tactic = function -| [l] -> +let () = define1 "dispatch" begin fun l -> let l = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) l in Proofview.tclDISPATCH l >>= fun () -> return v_unit -| _ -> assert false +end (** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let prm_extend : ml_tactic = function -| [lft; tac; rgt] -> +let () = define3 "extend" begin fun lft tac rgt -> let lft = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) lft in let tac = Proofview.tclIGNORE (thaw tac) in let rgt = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) rgt in Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit -| _ -> assert false +end (** (unit -> unit) -> unit *) -let prm_enter : ml_tactic = function -| [f] -> +let () = define1 "enter" begin fun f -> let f = Proofview.tclIGNORE (thaw f) in Proofview.tclINDEPENDENT f >>= fun () -> return v_unit -| _ -> assert false +end let k_var = Id.of_string "k" let e_var = Id.of_string "e" let prm_apply_kont_h = pname "apply_kont" (** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) -let prm_case : ml_tactic = function -| [f] -> +let () = define1 "case" begin fun f -> Proofview.tclCASE (thaw f) >>= begin function | Proofview.Next (x, k) -> let k = { @@ -491,52 +495,48 @@ let prm_case : ml_tactic = function return (ValBlk (0, [| Value.of_tuple [| x; ValCls k |] |])) | Proofview.Fail e -> return (ValBlk (1, [| Value.of_exn e |])) end -| _ -> assert false +end (** 'a kont -> exn -> 'a *) -let prm_apply_kont : ml_tactic = function -| [k; e] -> (Value.to_ext Value.val_kont k) (Value.to_exn e) -| _ -> assert false +let () = define2 "apply_kont" begin fun k e -> + (Value.to_ext Value.val_kont k) (Value.to_exn e) +end (** int -> int -> (unit -> 'a) -> 'a *) -let prm_focus : ml_tactic = function -| [i; j; tac] -> +let () = define3 "focus" begin fun i j tac -> let i = Value.to_int i in let j = Value.to_int j in Proofview.tclFOCUS i j (thaw tac) -| _ -> assert false +end (** unit -> unit *) -let prm_shelve : ml_tactic = function -| [_] -> Proofview.shelve >>= fun () -> return v_unit -| _ -> assert false +let () = define0 "shelve" begin + Proofview.shelve >>= fun () -> return v_unit +end (** unit -> unit *) -let prm_shelve_unifiable : ml_tactic = function -| [_] -> Proofview.shelve_unifiable >>= fun () -> return v_unit -| _ -> assert false +let () = define0 "shelve_unifiable" begin + Proofview.shelve_unifiable >>= fun () -> return v_unit +end -let prm_new_goal : ml_tactic = function -| [ev] -> +let () = define1 "new_goal" begin fun ev -> let ev = Evar.unsafe_of_int (Value.to_int ev) in Proofview.tclEVARMAP >>= fun sigma -> if Evd.mem sigma ev then Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit else throw err_notfound -| _ -> assert false +end (** unit -> constr *) -let prm_goal : ml_tactic = function -| [_] -> +let () = define0 "goal" begin Proofview.Goal.enter_one begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in return (Value.of_constr concl) end -| _ -> assert false +end (** ident -> constr *) -let prm_hyp : ml_tactic = function -| [id] -> +let () = define1 "hyp" begin fun id -> let id = Value.to_ident id in pf_apply begin fun env _ -> let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in @@ -544,10 +544,9 @@ let prm_hyp : ml_tactic = function else Tacticals.New.tclZEROMSG (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (** FIXME: Do something more sensible *) end -| _ -> assert false +end -let prm_hyps : ml_tactic = function -| [_] -> +let () = define0 "hyps" begin pf_apply begin fun env _ -> let open Context.Named.Declaration in let hyps = List.rev (Environ.named_context env) in @@ -562,66 +561,59 @@ let prm_hyps : ml_tactic = function in return (Value.of_list map hyps) end -| _ -> assert false +end (** (unit -> constr) -> unit *) -let prm_refine : ml_tactic = function -| [c] -> +let () = define1 "refine" begin fun c -> let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in Proofview.Goal.nf_enter begin fun gl -> Refine.generic_refine ~typecheck:true c gl end >>= fun () -> return v_unit -| _ -> assert false +end -let prm_with_holes : ml_tactic = function -| [x; f] -> +let () = define2 "with_holes" begin fun x f -> Proofview.tclEVARMAP >>= fun sigma0 -> thaw x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> Tacticals.New.tclWITHHOLES false (interp_app f [ans]) sigma -| _ -> assert false +end -let prm_progress : ml_tactic = function -| [f] -> Proofview.tclPROGRESS (thaw f) -| _ -> assert false +let () = define1 "progress" begin fun f -> + Proofview.tclPROGRESS (thaw f) +end -let prm_abstract : ml_tactic = function -| [id; f] -> +let () = define2 "abstract" begin fun id f -> let id = Value.to_option Value.to_ident id in Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> return v_unit -| _ -> assert false +end -let prm_time : ml_tactic = function -| [s; f] -> +let () = define2 "time" begin fun s f -> let s = Value.to_option Value.to_string s in Proofview.tclTIME s (thaw f) -| _ -> assert false +end -let prm_check_interrupt : ml_tactic = function -| [_] -> Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit -| _ -> assert false +let () = define0 "check_interrupt" begin + Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit +end (** Fresh *) -let prm_free_union : ml_tactic = function -| [set1; set2] -> +let () = define2 "fresh_free_union" begin fun set1 set2 -> let set1 = Value.to_ext val_free set1 in let set2 = Value.to_ext val_free set2 in let ans = Id.Set.union set1 set2 in return (Value.of_ext val_free ans) -| _ -> assert false +end -let prm_free_of_ids : ml_tactic = function -| [ids] -> +let () = define1 "fresh_free_of_ids" begin fun ids -> let ids = Value.to_list Value.to_ident ids in let free = List.fold_right Id.Set.add ids Id.Set.empty in return (Value.of_ext val_free free) -| _ -> assert false +end -let prm_free_of_constr : ml_tactic = function -| [c] -> +let () = define1 "fresh_free_of_constr" begin fun c -> let c = Value.to_constr c in Proofview.tclEVARMAP >>= fun sigma -> let rec fold accu c = match EConstr.kind sigma c with @@ -630,84 +622,14 @@ let prm_free_of_constr : ml_tactic = function in let ans = fold Id.Set.empty c in return (Value.of_ext val_free ans) -| _ -> assert false +end -let prm_fresh : ml_tactic = function -| [avoid; id] -> +let () = define2 "fresh_fresh" begin fun avoid id -> let avoid = Value.to_ext val_free avoid in let id = Value.to_ident id in let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in return (Value.of_ident nid) -| _ -> assert false - -(** Registering *) - -let () = Tac2env.define_primitive (pname "print") prm_print -let () = Tac2env.define_primitive (pname "message_of_string") prm_message_of_string -let () = Tac2env.define_primitive (pname "message_of_int") prm_message_of_int -let () = Tac2env.define_primitive (pname "message_of_constr") prm_message_of_constr -let () = Tac2env.define_primitive (pname "message_of_ident") prm_message_of_ident -let () = Tac2env.define_primitive (pname "message_concat") prm_message_concat - -let () = Tac2env.define_primitive (pname "array_make") prm_array_make -let () = Tac2env.define_primitive (pname "array_length") prm_array_length -let () = Tac2env.define_primitive (pname "array_get") prm_array_get -let () = Tac2env.define_primitive (pname "array_set") prm_array_set - -let () = Tac2env.define_primitive (pname "string_make") prm_string_make -let () = Tac2env.define_primitive (pname "string_length") prm_string_length -let () = Tac2env.define_primitive (pname "string_get") prm_string_get -let () = Tac2env.define_primitive (pname "string_set") prm_string_set - -let () = Tac2env.define_primitive (pname "constr_type") prm_constr_type -let () = Tac2env.define_primitive (pname "constr_equal") prm_constr_equal -let () = Tac2env.define_primitive (pname "constr_kind") prm_constr_kind -let () = Tac2env.define_primitive (pname "constr_substnl") prm_constr_substnl - -let () = Tac2env.define_primitive (pname "pattern_matches") prm_pattern_matches -let () = Tac2env.define_primitive (pname "pattern_matches_subterm") prm_pattern_matches_subterm -let () = Tac2env.define_primitive (pname "pattern_instantiate") prm_pattern_instantiate - -let () = Tac2env.define_primitive (pname "int_equal") prm_int_equal -let () = Tac2env.define_primitive (pname "int_compare") prm_int_compare -let () = Tac2env.define_primitive (pname "int_neg") prm_int_neg -let () = Tac2env.define_primitive (pname "int_add") prm_int_add -let () = Tac2env.define_primitive (pname "int_sub") prm_int_sub -let () = Tac2env.define_primitive (pname "int_mul") prm_int_mul - -let () = Tac2env.define_primitive (pname "ident_equal") prm_ident_equal -let () = Tac2env.define_primitive (pname "ident_to_string") prm_ident_to_string -let () = Tac2env.define_primitive (pname "ident_of_string") prm_ident_of_string - -let () = Tac2env.define_primitive (pname "throw") prm_throw - -let () = Tac2env.define_primitive (pname "zero") prm_zero -let () = Tac2env.define_primitive (pname "plus") prm_plus -let () = Tac2env.define_primitive (pname "once") prm_once -let () = Tac2env.define_primitive (pname "dispatch") prm_dispatch -let () = Tac2env.define_primitive (pname "extend") prm_extend -let () = Tac2env.define_primitive (pname "enter") prm_enter -let () = Tac2env.define_primitive (pname "case") prm_case -let () = Tac2env.define_primitive (pname "apply_kont") prm_apply_kont - -let () = Tac2env.define_primitive (pname "focus") prm_focus -let () = Tac2env.define_primitive (pname "shelve") prm_shelve -let () = Tac2env.define_primitive (pname "shelve_unifiable") prm_shelve_unifiable -let () = Tac2env.define_primitive (pname "new_goal") prm_new_goal -let () = Tac2env.define_primitive (pname "goal") prm_goal -let () = Tac2env.define_primitive (pname "hyp") prm_hyp -let () = Tac2env.define_primitive (pname "hyps") prm_hyps -let () = Tac2env.define_primitive (pname "refine") prm_refine -let () = Tac2env.define_primitive (pname "with_holes") prm_with_holes -let () = Tac2env.define_primitive (pname "progress") prm_progress -let () = Tac2env.define_primitive (pname "abstract") prm_abstract -let () = Tac2env.define_primitive (pname "time") prm_time -let () = Tac2env.define_primitive (pname "check_interrupt") prm_check_interrupt - -let () = Tac2env.define_primitive (pname "fresh_fresh") prm_fresh -let () = Tac2env.define_primitive (pname "fresh_free_union") prm_free_union -let () = Tac2env.define_primitive (pname "fresh_free_of_ids") prm_free_of_ids -let () = Tac2env.define_primitive (pname "fresh_free_of_constr") prm_free_of_constr +end (** ML types *) -- cgit v1.2.3 From f6154c8a086faee725b4f41fb4b2586d7cb6c51d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 15:19:30 +0200 Subject: Removing dead code for handling of array litterals. --- src/tac2env.ml | 2 +- src/tac2expr.mli | 1 - src/tac2intern.ml | 6 ++---- src/tac2interp.ml | 3 --- src/tac2print.ml | 2 -- 5 files changed, 3 insertions(+), 11 deletions(-) diff --git a/src/tac2env.ml b/src/tac2env.ml index 59344e336b..dd8a07ffc6 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -65,7 +65,7 @@ let rec eval_pure = function | GTacCst (_, n, []) -> ValInt n | GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) | GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_pure el) -| GTacAtm (AtmStr _) | GTacArr _ | GTacLet _ | GTacVar _ | GTacSet _ +| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ | GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> anomaly (Pp.str "Term is not a syntactical value") diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 0c9112d902..42203a32e5 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -126,7 +126,6 @@ type glb_tacexpr = | GTacFun of Name.t list * glb_tacexpr | GTacApp of glb_tacexpr * glb_tacexpr list | GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr -| GTacArr of glb_tacexpr list | GTacCst of case_info * int * glb_tacexpr list | GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array | GTacPrj of type_constant * glb_tacexpr * int diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 9d22b18af4..02dfa1c08b 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -416,13 +416,13 @@ let rec is_value = function | GTacCst (_, _, []) -> true | GTacOpn (_, el) -> List.for_all is_value el | GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el -| GTacArr _ | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ +| GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ | GTacWth _ -> false let is_rec_rhs = function | GTacFun _ -> true | GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ -| GTacSet _ | GTacArr _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacSet _ | GTacExt _ | GTacPrm _ | GTacCst _ | GTacCse _ | GTacOpn _ | GTacWth _ -> false let rec fv_type f t accu = match t with @@ -1294,8 +1294,6 @@ let rec subst_expr subst e = match e with | GTacLet (r, bs, e) -> let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in GTacLet (r, bs, subst_expr subst e) -| GTacArr el -> - GTacArr (List.map (fun e -> subst_expr subst e) el) | GTacCst (t, n, el) as e0 -> let t' = subst_or_tuple subst_kn subst t in let el' = List.smartmap (fun e -> subst_expr subst e) el in diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 3e1a048d29..3490b1a2a8 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -79,9 +79,6 @@ let rec interp ist = function let iter (_, e) = e.clos_env <- ist in let () = List.iter iter fixs in interp ist e -| GTacArr el -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (ValBlk (0, Array.of_list el)) | GTacCst (_, n, []) -> return (ValInt n) | GTacCst (_, n, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> diff --git a/src/tac2print.ml b/src/tac2print.ml index e3095c7a89..29f78f251e 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -177,8 +177,6 @@ let pr_glbexpr_gen lvl c = | E2 | E3 | E4 | E5 -> fun x -> x in paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) - | GTacArr cl -> - mt () (** FIXME when implemented *) | GTacCst (Other tpe, n, cl) -> begin match Tac2env.interp_type tpe with | _, GTydAlg { galg_constructors = def } -> -- cgit v1.2.3 From 94397f6e022176a29add6369f0a310b1d7decf62 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 15:23:37 +0200 Subject: Pass Ltac2 variables in a dedicated environment for generic arguments. This is a way to hack around the fact that various interpretation functions rely wrongly on the values of the environment to do nasty tricks. Typically, the interpretation of terms is broken, as it will fail when there is a bound variable with the same name as a hypothesis, instead of producing the hypothesis itself. --- src/tac2core.ml | 10 ++-------- src/tac2interp.ml | 19 +++++++++++++++++++ src/tac2interp.mli | 5 +++++ tests/quot.v | 10 ++++++++++ 4 files changed, 36 insertions(+), 8 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 609dd40587..d14849a2a6 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -656,8 +656,7 @@ let open_constr_no_classes_flags () = (** Embed all Ltac2 data into Values *) let to_lvar ist = let open Glob_ops in - let map e = Val.Dyn (val_valexpr, e) in - let lfun = Id.Map.map map ist in + let lfun = Tac2interp.set_env ist Id.Map.empty in { empty_lvar with Glob_term.ltac_genargs = lfun } let interp_constr flags ist (c, _) = @@ -728,12 +727,7 @@ let () = let () = let interp ist env sigma concl tac = - let fold id (Val.Dyn (tag, v)) (accu : environment) : environment = - match Val.eq tag val_valexpr with - | None -> accu - | Some Refl -> Id.Map.add id v accu - in - let ist = Id.Map.fold fold ist Id.Map.empty in + let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (interp ist tac) in let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in (EConstr.of_constr c, sigma) diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 3490b1a2a8..691c795502 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -155,3 +155,22 @@ and interp_set ist e p r = match e with return (ValInt 0) | ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> anomaly (str "Unexpected value shape") + +(** Cross-boundary hacks. *) + +open Geninterp + +let val_env : environment Val.typ = Val.create "ltac2:env" +let env_ref = Id.of_string_soft "@@ltac2_env@@" + +let extract_env (Val.Dyn (tag, v)) : environment = +match Val.eq tag val_env with +| None -> assert false +| Some Refl -> v + +let get_env ist = + try extract_env (Id.Map.find env_ref ist) + with Not_found -> empty_environment + +let set_env env ist = + Id.Map.add env_ref (Val.Dyn (val_env, env)) ist diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 42e9e3adeb..f99008c506 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -17,6 +17,11 @@ val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic val interp_app : valexpr -> valexpr list -> valexpr Proofview.tactic +(** {5 Cross-boundary encodings} *) + +val get_env : Glob_term.unbound_ltac_var_map -> environment +val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound_ltac_var_map + (** {5 Exceptions} *) exception LtacError of KerName.t * valexpr array diff --git a/tests/quot.v b/tests/quot.v index 4fa9c4fa4e..624c4ad0c1 100644 --- a/tests/quot.v +++ b/tests/quot.v @@ -14,3 +14,13 @@ let x := constr:(I) in let y := constr:((fun z => z) $x) in Control.refine (fun _ => y). Qed. + +Goal True. +Proof. +(** Here, Ltac2 should not put its variables in the same environment as + Ltac1 otherwise the second binding fails as x is bound but not an + ident. *) +let x := constr:(I) in +let y := constr:((fun x => x) $x) in +Control.refine (fun _ => y). +Qed. -- cgit v1.2.3 From 31e686c2904c3015eaec18ce502d4e8afe565850 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 18:17:19 +0200 Subject: Rolling our own dynamic types for Ltac2. This prevents careless confusions with generic arguments from Coq. --- _CoqProject | 2 ++ src/ltac2_plugin.mlpack | 1 + src/tac2core.ml | 6 +++--- src/tac2dyn.ml | 9 +++++++++ src/tac2dyn.mli | 11 +++++++++++ src/tac2expr.mli | 2 +- src/tac2ffi.ml | 14 +++++--------- src/tac2ffi.mli | 30 +++++++++++++++--------------- src/tac2interp.ml | 2 +- src/tac2interp.mli | 2 +- 10 files changed, 49 insertions(+), 30 deletions(-) create mode 100644 src/tac2dyn.ml create mode 100644 src/tac2dyn.mli diff --git a/_CoqProject b/_CoqProject index ffe1dda032..fc9df4ee3f 100644 --- a/_CoqProject +++ b/_CoqProject @@ -2,6 +2,8 @@ -I src/ -bypass-API +src/tac2dyn.ml +src/tac2dyn.mli src/tac2expr.mli src/tac2env.ml src/tac2env.mli diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index f9fa2fafd8..92f391a085 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -1,3 +1,4 @@ +Tac2dyn Tac2env Tac2print Tac2intern diff --git a/src/tac2core.ml b/src/tac2core.ml index d14849a2a6..e865c1378f 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -10,8 +10,8 @@ open CSig open Pp open Names open Genarg -open Geninterp open Tac2env +open Tac2dyn open Tac2expr open Tac2interp open Tac2entries.Pltac @@ -70,8 +70,8 @@ let of_rec_declaration (nas, ts, cs) = Value.of_array Value.of_constr ts, Value.of_array Value.of_constr cs) -let val_valexpr : valexpr Val.typ = Val.create "ltac2:valexpr" -let val_free : Id.Set.t Val.typ = Val.create "ltac2:free" +let val_valexpr : valexpr Val.tag = Val.create "ltac2:valexpr" +let val_free : Id.Set.t Val.tag = Val.create "ltac2:free" (** Stdlib exceptions *) diff --git a/src/tac2dyn.ml b/src/tac2dyn.ml new file mode 100644 index 0000000000..3f4fbca712 --- /dev/null +++ b/src/tac2dyn.ml @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) and closure = { diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index a9a0f5a479..61b6d56b6c 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -9,18 +9,14 @@ open Util open Globnames open Genarg -open Geninterp +open Tac2dyn open Tac2expr open Tac2interp (** Dynamic tags *) -let val_tag t = match val_tag t with -| Val.Base t -> t -| _ -> assert false - -let val_constr = val_tag (topwit Stdarg.wit_constr) -let val_ident = val_tag (topwit Stdarg.wit_ident) +let val_constr = Val.create "ltac2:constr" +let val_ident = Val.create "ltac2:ident" let val_pattern = Val.create "ltac2:pattern" let val_pp = Val.create "ltac2:pp" let val_sort = Val.create "ltac2:sort" @@ -30,10 +26,10 @@ let val_constant = Val.create "ltac2:constant" let val_constructor = Val.create "ltac2:constructor" let val_projection = Val.create "ltac2:projection" let val_univ = Val.create "ltac2:universe" -let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ = +let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag = Val.create "ltac2:kont" -let extract_val (type a) (type b) (tag : a Val.typ) (tag' : b Val.typ) (v : b) : a = +let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with | None -> assert false | Some Refl -> v diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 71d90ba940..1ce163256d 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Geninterp open Names open EConstr +open Tac2dyn open Tac2expr (** {5 Ltac2 FFI} *) @@ -65,20 +65,20 @@ val to_constant : valexpr -> Constant.t val of_reference : Globnames.global_reference -> valexpr val to_reference : valexpr -> Globnames.global_reference -val of_ext : 'a Val.typ -> 'a -> valexpr -val to_ext : 'a Val.typ -> valexpr -> 'a +val of_ext : 'a Val.tag -> 'a -> valexpr +val to_ext : 'a Val.tag -> valexpr -> 'a (** {5 Dynamic tags} *) -val val_constr : EConstr.t Val.typ -val val_ident : Id.t Val.typ -val val_pattern : Pattern.constr_pattern Val.typ -val val_pp : Pp.t Val.typ -val val_sort : ESorts.t Val.typ -val val_cast : Constr.cast_kind Val.typ -val val_inductive : inductive Val.typ -val val_constant : Constant.t Val.typ -val val_constructor : constructor Val.typ -val val_projection : Projection.t Val.typ -val val_univ : Univ.universe_level Val.typ -val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.typ +val val_constr : EConstr.t Val.tag +val val_ident : Id.t Val.tag +val val_pattern : Pattern.constr_pattern Val.tag +val val_pp : Pp.t Val.tag +val val_sort : ESorts.t Val.tag +val val_cast : Constr.cast_kind Val.tag +val val_inductive : inductive Val.tag +val val_constant : Constant.t Val.tag +val val_constructor : constructor Val.tag +val val_projection : Projection.t Val.tag +val val_univ : Univ.universe_level Val.tag +val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 691c795502..3be95ac828 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -23,7 +23,7 @@ let () = register_handler begin function | _ -> raise Unhandled end -let val_exn = Geninterp.Val.create "ltac2:exn" +let val_exn = Tac2dyn.Val.create "ltac2:exn" type environment = valexpr Id.Map.t diff --git a/src/tac2interp.mli b/src/tac2interp.mli index f99008c506..18522c3c91 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -27,6 +27,6 @@ val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound exception LtacError of KerName.t * valexpr array (** Ltac2-defined exceptions seen from OCaml side *) -val val_exn : Exninfo.iexn Geninterp.Val.typ +val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] should be put into a value with tag [val_exn]. *) -- cgit v1.2.3 From 63d36d429edd2e85cbebe69f66e8949b25b46c70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 18:32:38 +0200 Subject: Rolling our own generic arguments. --- src/g_ltac2.ml4 | 6 ++-- src/tac2core.ml | 101 ++++++++++++++++++++++++++++-------------------------- src/tac2dyn.ml | 18 ++++++++++ src/tac2dyn.mli | 23 +++++++++++++ src/tac2env.ml | 35 +++++++++++++------ src/tac2env.mli | 23 +++++++++---- src/tac2expr.mli | 4 +-- src/tac2ffi.ml | 1 + src/tac2ffi.mli | 1 + src/tac2intern.ml | 20 +++++------ src/tac2interp.ml | 3 +- src/tac2print.ml | 10 ++---- src/tac2quote.ml | 8 ++--- 13 files changed, 160 insertions(+), 93 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 672db12f1d..4e62fab715 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -86,11 +86,11 @@ let tac2mode = Gram.entry_create "vernac:ltac2_command" (** FUCK YOU API *) let ltac1_expr = (Obj.magic Pltac.tactic_expr : Tacexpr.raw_tactic_expr Gram.entry) -let inj_wit wit loc x = CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) -let inj_open_constr loc c = inj_wit Stdarg.wit_open_constr loc c +let inj_wit wit loc x = CTacExt (loc, wit, x) +let inj_open_constr loc c = inj_wit Tac2env.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c let inj_reference loc c = inj_wit Tac2env.wit_reference loc c -let inj_ltac1 loc e = inj_wit Tacarg.wit_tactic loc e +let inj_ltac1 loc e = inj_wit Tac2env.wit_ltac1 loc e let pattern_of_qualid loc id = if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) diff --git a/src/tac2core.ml b/src/tac2core.ml index e865c1378f..cbc7c4744e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -70,9 +70,6 @@ let of_rec_declaration (nas, ts, cs) = Value.of_array Value.of_constr ts, Value.of_array Value.of_constr cs) -let val_valexpr : valexpr Val.tag = Val.create "ltac2:valexpr" -let val_free : Id.Set.t Val.tag = Val.create "ltac2:free" - (** Stdlib exceptions *) let err_notfocussed = @@ -601,16 +598,16 @@ end (** Fresh *) let () = define2 "fresh_free_union" begin fun set1 set2 -> - let set1 = Value.to_ext val_free set1 in - let set2 = Value.to_ext val_free set2 in + let set1 = Value.to_ext Value.val_free set1 in + let set2 = Value.to_ext Value.val_free set2 in let ans = Id.Set.union set1 set2 in - return (Value.of_ext val_free ans) + return (Value.of_ext Value.val_free ans) end let () = define1 "fresh_free_of_ids" begin fun ids -> let ids = Value.to_list Value.to_ident ids in let free = List.fold_right Id.Set.add ids Id.Set.empty in - return (Value.of_ext val_free free) + return (Value.of_ext Value.val_free free) end let () = define1 "fresh_free_of_constr" begin fun c -> @@ -621,11 +618,11 @@ let () = define1 "fresh_free_of_constr" begin fun c -> | _ -> EConstr.fold sigma fold accu c in let ans = fold Id.Set.empty c in - return (Value.of_ext val_free ans) + return (Value.of_ext Value.val_free ans) end let () = define2 "fresh_fresh" begin fun avoid id -> - let avoid = Value.to_ext val_free avoid in + let avoid = Value.to_ext Value.val_free avoid in let id = Value.to_ident id in let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in return (Value.of_ident nid) @@ -659,7 +656,11 @@ let to_lvar ist = let lfun = Tac2interp.set_env ist Id.Map.empty in { empty_lvar with Glob_term.ltac_genargs = lfun } -let interp_constr flags ist (c, _) = +let intern_constr ist c = + let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in + c + +let interp_constr flags ist c = let open Pretyping in pf_apply begin fun env sigma -> Proofview.V82.wrap_exceptions begin fun () -> @@ -672,56 +673,90 @@ let interp_constr flags ist (c, _) = end let () = + let intern = intern_constr in let interp ist c = interp_constr (constr_flags ()) ist c in let obj = { ml_type = t_constr; + ml_intern = intern; + ml_subst = Detyping.subst_glob_constr; ml_interp = interp; } in - define_ml_object Stdarg.wit_constr obj + define_ml_object Tac2env.wit_constr obj let () = + let intern = intern_constr in let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in let obj = { ml_type = t_constr; + ml_intern = intern; + ml_subst = Detyping.subst_glob_constr; ml_interp = interp; } in - define_ml_object Stdarg.wit_open_constr obj + define_ml_object Tac2env.wit_open_constr obj let () = let interp _ id = return (ValExt (Value.val_ident, id)) in let obj = { ml_type = t_ident; + ml_intern = (fun _ id -> id); ml_interp = interp; + ml_subst = (fun _ id -> id); } in - define_ml_object Stdarg.wit_ident obj + define_ml_object Tac2env.wit_ident obj let () = + let intern ist c = + let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in + pat + in let interp _ c = return (ValExt (Value.val_pattern, c)) in let obj = { ml_type = t_pattern; + ml_intern = intern; ml_interp = interp; + ml_subst = Patternops.subst_pattern; } in define_ml_object Tac2env.wit_pattern obj let () = + let intern ist qid = match qid with + | Libnames.Ident (_, id) -> Globnames.VarRef id + | Libnames.Qualid (loc, qid) -> + let gr = + try Nametab.locate qid + with Not_found -> + Nametab.error_global_not_found ?loc qid + in + gr + in + let subst s c = Globnames.subst_global_reference s c in let interp _ gr = return (Value.of_reference gr) in let obj = { ml_type = t_reference; + ml_intern = intern; + ml_subst = subst; ml_interp = interp; } in define_ml_object Tac2env.wit_reference obj let () = + let intern ist tac = + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + tac + in let interp _ tac = (** FUCK YOU API *) (Obj.magic Ltac_plugin.Tacinterp.eval_tactic tac : unit Proofview.tactic) >>= fun () -> return v_unit in + let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in let obj = { ml_type = t_unit; + ml_intern = intern; + ml_subst = subst; ml_interp = interp; } in - define_ml_object Ltac_plugin.Tacarg.wit_tactic obj + define_ml_object Tac2env.wit_ltac1 obj (** Ltac2 in terms *) @@ -754,38 +789,6 @@ let () = in Geninterp.register_interp0 wit_ltac2 interp -(** Patterns *) - -let () = - let intern ist c = - let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in - ist, pat - in - Genintern.register_intern0 wit_pattern intern - -let () = - let subst s c = Patternops.subst_pattern s c in - Genintern.register_subst0 wit_pattern subst - -(** References *) - -let () = - let intern ist qid = match qid with - | Libnames.Ident (_, id) -> ist, Globnames.VarRef id - | Libnames.Qualid (loc, qid) -> - let gr = - try Nametab.locate qid - with Not_found -> - Nametab.error_global_not_found ?loc qid - in - ist, gr - in - Genintern.register_intern0 wit_reference intern - -let () = - let subst s c = Globnames.subst_global_reference s c in - Genintern.register_subst0 wit_reference subst - (** Built-in notation scopes *) let add_scope s f = @@ -806,7 +809,7 @@ let add_generic_scope s entry arg = let parse = function | [] -> let scope = Extend.Aentry entry in - let act x = CTacExt (dummy_loc, in_gen (rawwit arg) x) in + let act x = CTacExt (dummy_loc, arg, x) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () in @@ -927,8 +930,8 @@ let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference -let () = add_generic_scope "constr" Pcoq.Constr.constr Stdarg.wit_constr -let () = add_generic_scope "open_constr" Pcoq.Constr.constr Stdarg.wit_open_constr +let () = add_generic_scope "constr" Pcoq.Constr.constr wit_constr +let () = add_generic_scope "open_constr" Pcoq.Constr.constr wit_open_constr let () = add_generic_scope "pattern" Pcoq.Constr.constr wit_pattern (** seq scope, a bit hairy *) diff --git a/src/tac2dyn.ml b/src/tac2dyn.ml index 3f4fbca712..896676f08b 100644 --- a/src/tac2dyn.ml +++ b/src/tac2dyn.ml @@ -6,4 +6,22 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module Arg = +struct + module DYN = Dyn.Make(struct end) + module Map = DYN.Map + type ('a, 'b) tag = ('a * 'b) DYN.tag + let eq = DYN.eq + let repr = DYN.repr + let create = DYN.create +end + +module type Param = sig type ('raw, 'glb) t end + +module ArgMap (M : Param) = +struct + type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack + include Arg.Map(struct type 'a t = 'a pack end) +end + module Val = Dyn.Make(struct end) diff --git a/src/tac2dyn.mli b/src/tac2dyn.mli index e4b18ba373..e995296840 100644 --- a/src/tac2dyn.mli +++ b/src/tac2dyn.mli @@ -8,4 +8,27 @@ (** Dynamic arguments for Ltac2. *) +module Arg : +sig + type ('a, 'b) tag + val create : string -> ('a, 'b) tag + val eq : ('a1, 'b1) tag -> ('a2, 'b2) tag -> ('a1 * 'b1, 'a2 * 'b2) CSig.eq option + val repr : ('a, 'b) tag -> string +end +(** Arguments that are part of an AST. *) + +module type Param = sig type ('raw, 'glb) t end + +module ArgMap (M : Param) : +sig + type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack + type t + val empty : t + val add : ('a, 'b) Arg.tag -> ('a * 'b) pack -> t -> t + val remove : ('a, 'b) Arg.tag -> t -> t + val find : ('a, 'b) Arg.tag -> t -> ('a * 'b) pack + val mem : ('a, 'b) Arg.tag -> t -> bool +end + module Val : Dyn.S +(** Toplevel values *) diff --git a/src/tac2env.ml b/src/tac2env.ml index dd8a07ffc6..39821b1cb6 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -10,6 +10,7 @@ open CErrors open Util open Names open Libnames +open Tac2dyn open Tac2expr type global_data = { @@ -250,22 +251,31 @@ let shortest_qualid_of_projection kn = let sp = KNmap.find kn tab.tab_proj_rev in KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj -type 'a ml_object = { +type ('a, 'b) ml_object = { ml_type : type_constant; - ml_interp : environment -> 'a -> valexpr Proofview.tactic; + ml_intern : Genintern.glob_sign -> 'a -> 'b; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; } module MLTypeObj = struct - type ('a, 'b, 'c) obj = 'b ml_object - let name = "ltac2_ml_type" - let default _ = None + type ('a, 'b) t = ('a, 'b) ml_object end -module MLType = Genarg.Register(MLTypeObj) +module MLType = Tac2dyn.ArgMap(MLTypeObj) -let define_ml_object t tpe = MLType.register0 t tpe -let interp_ml_object t = MLType.obj t +let ml_object_table = ref MLType.empty + +let define_ml_object t tpe = + ml_object_table := MLType.add t (MLType.Pack tpe) !ml_object_table + +let interp_ml_object t = + try + let MLType.Pack ans = MLType.find t !ml_object_table in + ans + with Not_found -> + CErrors.anomaly Pp.(str "Unknown object type " ++ str (Tac2dyn.Arg.repr t)) (** Absolute paths *) @@ -278,8 +288,13 @@ let std_prefix = (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2:value" -let wit_pattern = Genarg.make0 "ltac2:pattern" -let wit_reference = Genarg.make0 "ltac2:reference" + +let wit_pattern = Arg.create "pattern" +let wit_reference = Arg.create "reference" +let wit_ident = Arg.create "ident" +let wit_constr = Arg.create "constr" +let wit_open_constr = Arg.create "open_constr" +let wit_ltac1 = Arg.create "ltac1" let is_constructor qid = let (_, id) = repr_qualid qid in diff --git a/src/tac2env.mli b/src/tac2env.mli index 8a5fb531d8..0ab6543178 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -10,6 +10,7 @@ open Genarg open Names open Libnames open Nametab +open Tac2dyn open Tac2expr (** Ltac2 global environment *) @@ -104,13 +105,15 @@ val interp_primitive : ml_tactic_name -> ml_tactic (** {5 ML primitive types} *) -type 'a ml_object = { +type ('a, 'b) ml_object = { ml_type : type_constant; - ml_interp : environment -> 'a -> valexpr Proofview.tactic; + ml_intern : Genintern.glob_sign -> 'a -> 'b; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; } -val define_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object -> unit -val interp_ml_object : ('a, 'b, 'c) genarg_type -> 'b ml_object +val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit +val interp_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object (** {5 Absolute paths} *) @@ -124,13 +127,21 @@ val std_prefix : ModPath.t val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type -val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern, Util.Empty.t) genarg_type +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag -val wit_reference : (reference, Globnames.global_reference, Util.Empty.t) genarg_type +val wit_ident : (Id.t, Id.t) Arg.tag + +val wit_reference : (reference, Globnames.global_reference) Arg.tag (** Beware, at the raw level, [Qualid [id]] has not the same meaning as [Ident id]. The first is an unqualified global reference, the second is the dynamic reference to id. *) +val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_ltac1 : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr) Arg.tag + (** {5 Helper functions} *) val is_constructor : qualid -> bool diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 0b02ba2656..ccff8e7756 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -104,7 +104,7 @@ type raw_tacexpr = | CTacRec of Loc.t * raw_recexpr | CTacPrj of Loc.t * raw_tacexpr * ltac_projection or_relid | CTacSet of Loc.t * raw_tacexpr * ltac_projection or_relid * raw_tacexpr -| CTacExt of Loc.t * raw_generic_argument +| CTacExt : Loc.t * ('a, _) Tac2dyn.Arg.tag * 'a -> raw_tacexpr and raw_taccase = raw_patexpr * raw_tacexpr @@ -132,7 +132,7 @@ type glb_tacexpr = | GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr | GTacOpn of ltac_constructor * glb_tacexpr list | GTacWth of glb_tacexpr open_match -| GTacExt of glob_generic_argument +| GTacExt : (_, 'a) Tac2dyn.Arg.tag * 'a -> glb_tacexpr | GTacPrm of ml_tactic_name * glb_tacexpr list (** {5 Parsing & Printing} *) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 61b6d56b6c..6fc3b2e0f2 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -28,6 +28,7 @@ let val_projection = Val.create "ltac2:projection" let val_univ = Val.create "ltac2:universe" let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag = Val.create "ltac2:kont" +let val_free : Names.Id.Set.t Val.tag = Val.create "ltac2:free" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 1ce163256d..33b1010213 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -82,3 +82,4 @@ val val_constructor : constructor Val.tag val val_projection : Projection.t Val.tag val val_univ : Univ.universe_level Val.tag val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag +val val_free : Id.Set.t Val.tag diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 02dfa1c08b..051b3af5c7 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -200,7 +200,7 @@ let loc_of_tacexpr = function | CTacRec (loc, _) -> loc | CTacPrj (loc, _, _) -> loc | CTacSet (loc, _, _, _) -> loc -| CTacExt (loc, _) -> loc +| CTacExt (loc, _, _) -> loc let loc_of_patexpr = function | CPatVar (loc, _) -> Option.default dummy_loc loc @@ -769,17 +769,16 @@ let rec intern_rec env = function let ret = subst_type substf pinfo.pdata_ptyp in let r = intern_rec_with_constraint env r ret in (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) -| CTacExt (loc, ext) -> +| CTacExt (loc, tag, arg) -> let open Genintern in - let GenArg (Rawwit tag, _) = ext in let tpe = interp_ml_object tag in (** External objects do not have access to the named context because this is not stable by dynamic semantics. *) let genv = Global.env_of_context Environ.empty_named_context_val in let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let (_, ext) = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> generic_intern ist ext) () in - (GTacExt ext, GTypRef (Other tpe.ml_type, [])) + let arg = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> tpe.ml_intern ist arg) () in + (GTacExt (tag, arg), GTypRef (Other tpe.ml_type, [])) and intern_rec_with_constraint env e exp = let loc = loc_of_tacexpr e in @@ -1248,8 +1247,8 @@ let rec globalize ids e = match e with let p = get_projection0 p in let e' = globalize ids e' in CTacSet (loc, e, AbsKn p, e') -| CTacExt (loc, arg) -> - let arg = pr_argument_type (genarg_tag arg) in +| CTacExt (loc, tag, arg) -> + let arg = str (Tac2dyn.Arg.repr tag) in CErrors.user_err ~loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) and globalize_case ids (p, e) = @@ -1324,9 +1323,10 @@ let rec subst_expr subst e = match e with let e' = subst_expr subst e in let r' = subst_expr subst r in if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') -| GTacExt ext -> - let ext' = Genintern.generic_substitute subst ext in - if ext' == ext then e else GTacExt ext' +| GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + let arg' = tpe.ml_subst subst arg in + if arg' == arg then e else GTacExt (tag, arg') | GTacOpn (kn, el) as e0 -> let kn' = subst_kn subst kn in let el' = List.smartmap (fun e -> subst_expr subst e) el in diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 3be95ac828..f458f6e81f 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -99,8 +99,7 @@ let rec interp ist = function | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> Tac2env.interp_primitive ml el -| GTacExt e -> - let GenArg (Glbwit tag, e) = e in +| GTacExt (tag, e) -> let tpe = Tac2env.interp_ml_object tag in tpe.Tac2env.ml_interp ist e diff --git a/src/tac2print.ml b/src/tac2print.ml index 29f78f251e..6943697b45 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -279,13 +279,9 @@ let pr_glbexpr_gen lvl c = in let c = pr_constructor kn in paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) - | GTacExt arg -> - let GenArg (Glbwit tag, arg) = arg in - let name = match tag with - | ExtraArg tag -> ArgT.repr tag - | _ -> assert false - in - hov 0 (str name ++ str ":" ++ paren (Genprint.glb_print tag arg)) + | GTacExt (tag, arg) -> + let name = Tac2dyn.Arg.repr tag in + hov 0 (str name ++ str ":" ++ paren (str "_")) (** FIXME *) | GTacPrm (prm, args) -> let args = match args with | [] -> mt () diff --git a/src/tac2quote.ml b/src/tac2quote.ml index f87e370032..279ab53b67 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -65,7 +65,7 @@ let of_option ?loc f opt = match opt with let inj_wit ?loc wit x = let loc = Option.default dummy_loc loc in - CTacExt (loc, Genarg.in_gen (Genarg.rawwit wit) x) + CTacExt (loc, wit, x) let of_variable (loc, id) = let qid = Libnames.qualid_of_ident id in @@ -77,15 +77,15 @@ let of_anti f = function | QExpr x -> f x | QAnti id -> of_variable id -let of_ident (loc, id) = inj_wit ?loc Stdarg.wit_ident id +let of_ident (loc, id) = inj_wit ?loc Tac2env.wit_ident id let of_constr c = let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc Stdarg.wit_constr c + inj_wit ?loc Tac2env.wit_constr c let of_open_constr c = let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc Stdarg.wit_open_constr c + inj_wit ?loc Tac2env.wit_open_constr c let of_bool ?loc b = let c = if b then coq_core "true" else coq_core "false" in -- cgit v1.2.3 From 033ac67e2513f2bd3588cc577906538f5b291da4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 21:18:36 +0200 Subject: Centralizing tag declarations. --- src/tac2ffi.ml | 27 ++++++++++++++------------- src/tac2ffi.mli | 4 ++++ src/tac2interp.ml | 2 -- src/tac2interp.mli | 4 ---- 4 files changed, 18 insertions(+), 19 deletions(-) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 6fc3b2e0f2..4d84da14ce 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -15,20 +15,21 @@ open Tac2interp (** Dynamic tags *) -let val_constr = Val.create "ltac2:constr" -let val_ident = Val.create "ltac2:ident" -let val_pattern = Val.create "ltac2:pattern" -let val_pp = Val.create "ltac2:pp" -let val_sort = Val.create "ltac2:sort" -let val_cast = Val.create "ltac2:cast" -let val_inductive = Val.create "ltac2:inductive" -let val_constant = Val.create "ltac2:constant" -let val_constructor = Val.create "ltac2:constructor" -let val_projection = Val.create "ltac2:projection" -let val_univ = Val.create "ltac2:universe" +let val_exn = Val.create "exn" +let val_constr = Val.create "constr" +let val_ident = Val.create "ident" +let val_pattern = Val.create "pattern" +let val_pp = Val.create "pp" +let val_sort = Val.create "sort" +let val_cast = Val.create "cast" +let val_inductive = Val.create "inductive" +let val_constant = Val.create "constant" +let val_constructor = Val.create "constructor" +let val_projection = Val.create "projection" +let val_univ = Val.create "universe" let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag = - Val.create "ltac2:kont" -let val_free : Names.Id.Set.t Val.tag = Val.create "ltac2:free" + Val.create "kont" +let val_free : Names.Id.Set.t Val.tag = Val.create "free" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 33b1010213..cf1d7e81a1 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -83,3 +83,7 @@ val val_projection : Projection.t Val.tag val val_univ : Univ.universe_level Val.tag val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag val val_free : Id.Set.t Val.tag + +val val_exn : Exninfo.iexn Tac2dyn.Val.tag +(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] + should be put into a value with tag [val_exn]. *) diff --git a/src/tac2interp.ml b/src/tac2interp.ml index f458f6e81f..c15331571b 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -23,8 +23,6 @@ let () = register_handler begin function | _ -> raise Unhandled end -let val_exn = Tac2dyn.Val.create "ltac2:exn" - type environment = valexpr Id.Map.t let empty_environment = Id.Map.empty diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 18522c3c91..1ac26b48db 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -26,7 +26,3 @@ val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound exception LtacError of KerName.t * valexpr array (** Ltac2-defined exceptions seen from OCaml side *) - -val val_exn : Exninfo.iexn Tac2dyn.Val.tag -(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] - should be put into a value with tag [val_exn]. *) -- cgit v1.2.3 From ba68fcd85dd38f0094c8eac157080670354e473e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 22:31:34 +0200 Subject: Fixing printing of tactic expressions. --- src/tac2core.ml | 17 +++++++++++++++++ src/tac2env.ml | 1 + src/tac2env.mli | 1 + src/tac2print.ml | 4 ++-- 4 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index cbc7c4744e..7d18bf693e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -675,32 +675,38 @@ let interp_constr flags ist c = let () = let intern = intern_constr in let interp ist c = interp_constr (constr_flags ()) ist c in + let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in let obj = { ml_type = t_constr; ml_intern = intern; ml_subst = Detyping.subst_glob_constr; ml_interp = interp; + ml_print = print; } in define_ml_object Tac2env.wit_constr obj let () = let intern = intern_constr in let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in let obj = { ml_type = t_constr; ml_intern = intern; ml_subst = Detyping.subst_glob_constr; ml_interp = interp; + ml_print = print; } in define_ml_object Tac2env.wit_open_constr obj let () = let interp _ id = return (ValExt (Value.val_ident, id)) in + let print _ id = str "ident:(" ++ Id.print id ++ str ")" in let obj = { ml_type = t_ident; ml_intern = (fun _ id -> id); ml_interp = interp; ml_subst = (fun _ id -> id); + ml_print = print; } in define_ml_object Tac2env.wit_ident obj @@ -709,12 +715,14 @@ let () = let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in pat in + let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in let interp _ c = return (ValExt (Value.val_pattern, c)) in let obj = { ml_type = t_pattern; ml_intern = intern; ml_interp = interp; ml_subst = Patternops.subst_pattern; + ml_print = print; } in define_ml_object Tac2env.wit_pattern obj @@ -731,11 +739,16 @@ let () = in let subst s c = Globnames.subst_global_reference s c in let interp _ gr = return (Value.of_reference gr) in + let print _ = function + | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" + | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" + in let obj = { ml_type = t_reference; ml_intern = intern; ml_subst = subst; ml_interp = interp; + ml_print = print; } in define_ml_object Tac2env.wit_reference obj @@ -750,11 +763,15 @@ let () = return v_unit in let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic (Obj.magic env) tac ++ str ")" + in let obj = { ml_type = t_unit; ml_intern = intern; ml_subst = subst; ml_interp = interp; + ml_print = print; } in define_ml_object Tac2env.wit_ltac1 obj diff --git a/src/tac2env.ml b/src/tac2env.ml index 39821b1cb6..489113c031 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -256,6 +256,7 @@ type ('a, 'b) ml_object = { ml_intern : Genintern.glob_sign -> 'a -> 'b; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; } module MLTypeObj = diff --git a/src/tac2env.mli b/src/tac2env.mli index 0ab6543178..0ef62d67ed 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -110,6 +110,7 @@ type ('a, 'b) ml_object = { ml_intern : Genintern.glob_sign -> 'a -> 'b; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; } val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit diff --git a/src/tac2print.ml b/src/tac2print.ml index 6943697b45..939f44aeaf 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -280,8 +280,8 @@ let pr_glbexpr_gen lvl c = let c = pr_constructor kn in paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) | GTacExt (tag, arg) -> - let name = Tac2dyn.Arg.repr tag in - hov 0 (str name ++ str ":" ++ paren (str "_")) (** FIXME *) + let tpe = interp_ml_object tag in + hov 0 (tpe.ml_print (Global.env ()) arg) (** FIXME *) | GTacPrm (prm, args) -> let args = match args with | [] -> mt () -- cgit v1.2.3 From 93e888000664191fa608a8fa0f8057bdda8fe084 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 22:51:37 +0200 Subject: Fix printing of Ltac2 in quotations. --- src/tac2core.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index 7d18bf693e..95fd29ec33 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -806,6 +806,12 @@ let () = in Geninterp.register_interp0 wit_ltac2 interp +let () = + let pr_raw _ = mt () in + let pr_glb e = Tac2print.pr_glbexpr e in + let pr_top _ = mt () in + Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top + (** Built-in notation scopes *) let add_scope s f = -- cgit v1.2.3 From 5a157fdc706860473638b295c95dd2a6eaa33a41 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Aug 2017 23:23:26 +0200 Subject: Binding reduction functions acting on terms. --- src/tac2core.mli | 2 ++ src/tac2stdlib.ml | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2tactics.ml | 57 ++++++++++++++++++++++++++++++++++ src/tac2tactics.mli | 24 +++++++++++++++ theories/Std.v | 13 ++++++++ 5 files changed, 185 insertions(+) diff --git a/src/tac2core.mli b/src/tac2core.mli index 566b7efbb7..9fae65bb3e 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -26,3 +26,5 @@ val c_true : ltac_constructor val c_false : ltac_constructor end + +val pf_apply : (Environ.env -> Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index d88402cbf2..2a57fdc705 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -352,6 +352,95 @@ let () = define_prim2 "tac_native" begin fun where cl -> Tac2tactics.native where cl end +(** Reduction functions *) + +let define_red1 name tac = + let tac = function + | [x] -> tac x >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + +let define_red2 name tac = + let tac = function + | [x; y] -> tac x y >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + +let define_red3 name tac = + let tac = function + | [x; y; z] -> tac x y z >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + +let () = define_red1 "eval_red" begin fun c -> + let c = Value.to_constr c in + Tac2tactics.eval_red c +end + +let () = define_red1 "eval_hnf" begin fun c -> + let c = Value.to_constr c in + Tac2tactics.eval_hnf c +end + +let () = define_red3 "eval_simpl" begin fun flags where c -> + let flags = to_red_flag flags in + let where = Value.to_option to_pattern_with_occs where in + let c = Value.to_constr c in + Tac2tactics.eval_simpl flags where c +end + +let () = define_red2 "eval_cbv" begin fun flags c -> + let flags = to_red_flag flags in + let c = Value.to_constr c in + Tac2tactics.eval_cbv flags c +end + +let () = define_red2 "eval_cbn" begin fun flags c -> + let flags = to_red_flag flags in + let c = Value.to_constr c in + Tac2tactics.eval_cbn flags c +end + +let () = define_red2 "eval_lazy" begin fun flags c -> + let flags = to_red_flag flags in + let c = Value.to_constr c in + Tac2tactics.eval_lazy flags c +end + +let () = define_red2 "eval_unfold" begin fun refs c -> + let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in + let refs = Value.to_list map refs in + let c = Value.to_constr c in + Tac2tactics.eval_unfold refs c +end + +let () = define_red2 "eval_fold" begin fun args c -> + let args = Value.to_list Value.to_constr args in + let c = Value.to_constr c in + Tac2tactics.eval_fold args c +end + +let () = define_red2 "eval_pattern" begin fun where c -> + let where = Value.to_list (fun p -> to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) p) where in + let c = Value.to_constr c in + Tac2tactics.eval_pattern where c +end + +let () = define_red2 "eval_vm" begin fun where c -> + let where = Value.to_option to_pattern_with_occs where in + let c = Value.to_constr c in + Tac2tactics.eval_vm where c +end + +let () = define_red2 "eval_native" begin fun where c -> + let where = Value.to_option to_pattern_with_occs where in + let c = Value.to_constr c in + Tac2tactics.eval_native where c +end + let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> let ev = Value.to_bool ev in let rw = Value.to_list to_rewriting rw in diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 25a00fdc2e..a95e60bc97 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -122,6 +122,63 @@ let native where cl = let where = Option.map map_pattern_with_occs where in Tactics.reduce (CbvNative where) cl +let eval_fun red c = + Tac2core.pf_apply begin fun env sigma -> + let (redfun, _) = Redexpr.reduction_of_red_expr env red in + let (sigma, ans) = redfun env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT ans + end + +let eval_red c = + eval_fun (Red false) c + +let eval_hnf c = + eval_fun Hnf c + +let eval_simpl flags where c = + let where = Option.map map_pattern_with_occs where in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Simpl (flags, where)) c + +let eval_cbv flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbv flags) c + +let eval_cbn flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbn flags) c + +let eval_lazy flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Lazy flags) c + +let eval_unfold occs c = + let map (gr, occ) = + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + eval_fun (Unfold occs) c + +let eval_fold cl c = + eval_fun (Fold cl) c + +let eval_pattern where c = + let where = List.map (fun (pat, occ) -> (occ, pat)) where in + eval_fun (Pattern where) c + +let eval_vm where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvVm where) c + +let eval_native where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvNative where) c + let on_destruction_arg tac ev arg = Proofview.Goal.enter begin fun gl -> match arg with diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 8939d2a9dd..87489bb248 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -9,6 +9,7 @@ open Names open Locus open Globnames +open EConstr open Genredexpr open Misctypes open Tactypes @@ -54,6 +55,29 @@ val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit ta val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic +val eval_red : constr -> constr tactic + +val eval_hnf : constr -> constr tactic + +val eval_simpl : global_reference glob_red_flag -> + (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic + +val eval_cbv : global_reference glob_red_flag -> constr -> constr tactic + +val eval_cbn : global_reference glob_red_flag -> constr -> constr tactic + +val eval_lazy : global_reference glob_red_flag -> constr -> constr tactic + +val eval_unfold : (global_reference * occurrences_expr) list -> constr -> constr tactic + +val eval_fold : constr list -> constr -> constr tactic + +val eval_pattern : (EConstr.t * occurrences_expr) list -> constr -> constr tactic + +val eval_vm : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic + +val eval_native : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic + val discriminate : evars_flag -> destruction_arg option -> unit tactic val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic diff --git a/theories/Std.v b/theories/Std.v index f380c10af8..2fa2c34da6 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -142,6 +142,19 @@ Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "lta Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_hnf : constr -> constr := "ltac2" "eval_hnf". +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_simpl : red_flags -> (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_simpl". +Ltac2 @ external eval_cbv : red_flags -> constr -> constr := "ltac2" "eval_cbv". +Ltac2 @ external eval_cbn : red_flags -> constr -> constr := "ltac2" "eval_cbn". +Ltac2 @ external eval_lazy : red_flags -> constr -> constr := "ltac2" "eval_lazy". +Ltac2 @ external eval_unfold : (reference * occurrences) list -> constr -> constr := "ltac2" "eval_unfold". +Ltac2 @ external eval_fold : constr list -> constr -> constr := "ltac2" "eval_fold". +Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr := "ltac2" "eval_pattern". +Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". +Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". + Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". -- cgit v1.2.3 From 84047666ce13f1eec440d38d9784ae125612507c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Aug 2017 18:09:05 +0200 Subject: Fix the type of the Constructor constructor. --- theories/Constr.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Constr.v b/theories/Constr.v index bb02d94531..801192d628 100644 --- a/theories/Constr.v +++ b/theories/Constr.v @@ -31,7 +31,7 @@ Ltac2 Type kind := [ | App (constr, constr array) | Constant (constant, instance) | Ind (inductive, instance) -| Constructor (inductive, instance) +| Constructor (constructor, instance) | Case (constr, constr, constr array) | Fix (int array, int, ident option array, constr array, constr array) | CoFix (int, ident option array, constr array, constr array) -- cgit v1.2.3 From 40edf6a111ae2b9f0a230c2617b3e86e8fbfa6dd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Aug 2017 18:15:09 +0200 Subject: Fix coq/ltac2#3: Constructor expects n arguments should name which constructor it is. --- src/tac2intern.ml | 17 ++++++++++------- src/tac2intern.mli | 2 +- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 051b3af5c7..88824386d9 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -206,9 +206,10 @@ let loc_of_patexpr = function | CPatVar (loc, _) -> Option.default dummy_loc loc | CPatRef (loc, _, _) -> loc -let error_nargs_mismatch loc nargs nfound = - user_err ~loc (str "Constructor expects " ++ int nargs ++ - str " arguments, but is applied to " ++ int nfound ++ +let error_nargs_mismatch loc kn nargs nfound = + let cstr = Tac2env.shortest_qualid_of_constructor kn in + user_err ~loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ + int nargs ++ str " arguments, but is applied to " ++ int nfound ++ str " arguments") let error_nparams_mismatch loc nargs nfound = @@ -924,8 +925,10 @@ and intern_case env loc e pl = let ids = List.map get_id args in let nids = List.length ids in let nargs = List.length arity in - let () = - if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids + let () = match knc with + | Tuple n -> assert (n == nids) + | Other knc -> + if not (Int.equal nids nargs) then error_nargs_mismatch loc knc nargs nids in let fold env id tpe = (** Instantiate all arguments *) @@ -993,7 +996,7 @@ and intern_case env loc e pl = let nids = List.length ids in let nargs = List.length data.cdata_args in let () = - if not (Int.equal nids nargs) then error_nargs_mismatch loc nargs nids + if not (Int.equal nids nargs) then error_nargs_mismatch loc knc nargs nids in let fold env id tpe = (** Instantiate all arguments *) @@ -1033,7 +1036,7 @@ and intern_constructor env loc kn args = match kn with | None -> (GTacOpn (kn, args), ans) else - error_nargs_mismatch loc nargs (List.length args) + error_nargs_mismatch loc kn nargs (List.length args) | Tuple n -> assert (Int.equal n (List.length args)); let types = List.init n (fun i -> GTypVar (fresh_id env)) in diff --git a/src/tac2intern.mli b/src/tac2intern.mli index dac074a0eb..8c997b741e 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -41,5 +41,5 @@ val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr (** Errors *) -val error_nargs_mismatch : Loc.t -> int -> int -> 'a +val error_nargs_mismatch : Loc.t -> ltac_constructor -> int -> int -> 'a val error_nparams_mismatch : Loc.t -> int -> int -> 'a -- cgit v1.2.3 From edc4126a37d7ea8f99142b706c9e6b6eb806443e Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Thu, 31 Aug 2017 12:32:51 -0400 Subject: Require Ltac2.Fresh in Ltac2.Ltac2 --- theories/Ltac2.v | 1 + 1 file changed, 1 insertion(+) diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 07229797da..996236325c 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -15,6 +15,7 @@ Require Ltac2.Array. Require Ltac2.Message. Require Ltac2.Constr. Require Ltac2.Control. +Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. Require Ltac2.Notations. -- cgit v1.2.3 From 7efbf5add76d640b5083110a5163bb8c1b98dabd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Aug 2017 18:55:35 +0200 Subject: Fix coq/ltac2#10: Antiquotation syntax breaks when backtracking across `Require`. --- src/g_ltac2.ml4 | 2 ++ src/tac2entries.ml | 12 ++++++++++++ src/tac2entries.mli | 4 ++++ 3 files changed, 18 insertions(+) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 4e62fab715..bfd2ab1a11 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -650,6 +650,7 @@ END (** Extension of constr syntax *) +let () = Hook.set Tac2entries.register_constr_quotations begin fun () -> GEXTEND Gram Pcoq.Constr.operconstr: LEVEL "0" [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> @@ -666,6 +667,7 @@ GEXTEND Gram ] ] ; END +end let pr_ltac2entry _ = mt () (** FIXME *) let pr_ltac2expr _ = mt () (** FIXME *) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index da7c07c134..2895fda060 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -819,10 +819,22 @@ let def_unit = { let t_list = coq_def "list" +let (f_register_constr_quotations, register_constr_quotations) = Hook.make () + +let perform_constr_quotations (_, ()) = Hook.get f_register_constr_quotations () + +(** Dummy object that register global rules when Require is called *) +let inTac2ConstrQuotations : unit -> obj = + declare_object {(default_object "TAC2-CONSTR-QUOT") with + cache_function = perform_constr_quotations; + load_function = fun _ -> perform_constr_quotations; + } + let _ = Mltop.declare_cache_obj begin fun () -> ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); register_prim_alg "list" 1 [ ("[]", []); ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); ]; + Lib.add_anonymous_leaf (inTac2ConstrQuotations ()); end "ltac2_plugin" diff --git a/src/tac2entries.mli b/src/tac2entries.mli index acb99a34b1..7ed45e62e5 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -72,3 +72,7 @@ val q_occurrences : occurrences Pcoq.Gram.entry val q_reference : Libnames.reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry end + +(** {5 Hooks} *) + +val register_constr_quotations : (unit -> unit) Hook.t -- cgit v1.2.3 From e89c5c3de0f00de2732f385087a3461b4e6f3a84 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Aug 2017 19:36:50 +0200 Subject: Expand the primitive functions on terms. --- src/tac2core.ml | 131 +++++++++++++++++++++++++++++++++++++++++++++++++++--- src/tac2ffi.ml | 1 + src/tac2ffi.mli | 1 + theories/Constr.v | 15 ++++++- 4 files changed, 141 insertions(+), 7 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 95fd29ec33..1f500352cf 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -61,15 +61,32 @@ let of_name c = match c with | Anonymous -> Value.of_option Value.of_ident None | Name id -> Value.of_option Value.of_ident (Some id) -let of_instance sigma u = - let u = Univ.Instance.to_array (EConstr.EInstance.kind sigma u) in +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let of_instance u = + let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in Value.of_array (fun v -> Value.of_ext Value.val_univ v) u +let to_instance u = + let u = Value.to_array (fun v -> Value.to_ext Value.val_univ v) u in + EConstr.EInstance.make (Univ.Instance.of_array u) + let of_rec_declaration (nas, ts, cs) = (Value.of_array of_name nas, Value.of_array Value.of_constr ts, Value.of_array Value.of_constr cs) +let to_rec_declaration (nas, ts, cs) = + (Value.to_array to_name nas, + Value.to_array Value.to_constr ts, + Value.to_array Value.to_constr cs) + +let of_result f = function +| Inl c -> ValBlk (0, [|f c|]) +| Inr e -> ValBlk (1, [|Value.of_exn e|]) + (** Stdlib exceptions *) let err_notfocussed = @@ -335,20 +352,21 @@ let () = define1 "constr_kind" begin fun c -> | Const (cst, u) -> ValBlk (10, [| Value.of_constant cst; - of_instance sigma u; + of_instance u; |]) | Ind (ind, u) -> ValBlk (11, [| Value.of_ext Value.val_inductive ind; - of_instance sigma u; + of_instance u; |]) | Construct (cstr, u) -> ValBlk (12, [| Value.of_ext Value.val_constructor cstr; - of_instance sigma u; + of_instance u; |]) - | Case (_, c, t, bl) -> + | Case (ci, c, t, bl) -> ValBlk (13, [| + Value.of_ext Value.val_case ci; Value.of_constr c; Value.of_constr t; Value.of_array Value.of_constr bl; @@ -378,6 +396,99 @@ let () = define1 "constr_kind" begin fun c -> end end +let () = define1 "constr_make" begin fun knd -> + let open Constr in + let c = match knd with + | ValBlk (0, [|n|]) -> + let n = Value.to_int n in + EConstr.mkRel n + | ValBlk (1, [|id|]) -> + let id = Value.to_ident id in + EConstr.mkVar id + | ValBlk (2, [|n|]) -> + let n = Value.to_int n in + EConstr.mkMeta n + | ValBlk (3, [|evk; args|]) -> + let evk = Evar.unsafe_of_int (Value.to_int evk) in + let args = Value.to_array Value.to_constr args in + EConstr.mkEvar (evk, args) + | ValBlk (4, [|s|]) -> + let s = Value.to_ext Value.val_sort s in + EConstr.mkSort (EConstr.Unsafe.to_sorts s) + | ValBlk (5, [|c; k; t|]) -> + let c = Value.to_constr c in + let k = Value.to_ext Value.val_cast k in + let t = Value.to_constr t in + EConstr.mkCast (c, k, t) + | ValBlk (6, [|na; t; u|]) -> + let na = to_name na in + let t = Value.to_constr t in + let u = Value.to_constr u in + EConstr.mkProd (na, t, u) + | ValBlk (7, [|na; t; c|]) -> + let na = to_name na in + let t = Value.to_constr t in + let u = Value.to_constr c in + EConstr.mkLambda (na, t, u) + | ValBlk (8, [|na; b; t; c|]) -> + let na = to_name na in + let b = Value.to_constr b in + let t = Value.to_constr t in + let c = Value.to_constr c in + EConstr.mkLetIn (na, b, t, c) + | ValBlk (9, [|c; cl|]) -> + let c = Value.to_constr c in + let cl = Value.to_array Value.to_constr cl in + EConstr.mkApp (c, cl) + | ValBlk (10, [|cst; u|]) -> + let cst = Value.to_constant cst in + let u = to_instance u in + EConstr.mkConstU (cst, u) + | ValBlk (11, [|ind; u|]) -> + let ind = Value.to_ext Value.val_inductive ind in + let u = to_instance u in + EConstr.mkIndU (ind, u) + | ValBlk (12, [|cstr; u|]) -> + let cstr = Value.to_ext Value.val_constructor cstr in + let u = to_instance u in + EConstr.mkConstructU (cstr, u) + | ValBlk (13, [|ci; c; t; bl|]) -> + let ci = Value.to_ext Value.val_case ci in + let c = Value.to_constr c in + let t = Value.to_constr t in + let bl = Value.to_array Value.to_constr bl in + EConstr.mkCase (ci, c, t, bl) + | ValBlk (14, [|recs; i; nas; ts; cs|]) -> + let recs = Value.to_array Value.to_int recs in + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkFix ((recs, i), def) + | ValBlk (15, [|i; nas; ts; cs|]) -> + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkCoFix (i, def) + | ValBlk (16, [|p; c|]) -> + let p = Value.to_ext Value.val_projection p in + let c = Value.to_constr c in + EConstr.mkProj (p, c) + | _ -> assert false + in + return (Value.of_constr c) +end + +let () = define1 "constr_check" begin fun c -> + let c = Value.to_constr c in + pf_apply begin fun env sigma -> + try + let (sigma, _) = Typing.type_of env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (of_result Value.of_constr (Inl c)) + with e when CErrors.noncritical e -> + let e = CErrors.push e in + return (of_result Value.of_constr (Inr e)) + end +end + let () = define3 "constr_substnl" begin fun subst k c -> let subst = Value.to_list Value.to_constr subst in let k = Value.to_int k in @@ -386,6 +497,14 @@ let () = define3 "constr_substnl" begin fun subst k c -> return (Value.of_constr ans) end +let () = define3 "constr_closenl" begin fun ids k c -> + let ids = Value.to_list Value.to_ident ids in + let k = Value.to_int k in + let c = Value.to_constr c in + let ans = EConstr.Vars.substn_vars k ids c in + return (Value.of_constr ans) +end + (** Patterns *) let () = define2 "pattern_matches" begin fun pat c -> diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 4d84da14ce..a1f9debdcb 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -26,6 +26,7 @@ let val_inductive = Val.create "inductive" let val_constant = Val.create "constant" let val_constructor = Val.create "constructor" let val_projection = Val.create "projection" +let val_case = Val.create "case" let val_univ = Val.create "universe" let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag = Val.create "kont" diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index cf1d7e81a1..e836319349 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -80,6 +80,7 @@ val val_inductive : inductive Val.tag val val_constant : Constant.t Val.tag val val_constructor : constructor Val.tag val val_projection : Projection.t Val.tag +val val_case : Constr.case_info Val.tag val val_univ : Univ.universe_level Val.tag val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag val val_free : Id.Set.t Val.tag diff --git a/theories/Constr.v b/theories/Constr.v index 801192d628..3e67a486cf 100644 --- a/theories/Constr.v +++ b/theories/Constr.v @@ -18,6 +18,8 @@ Module Unsafe. (** Low-level access to kernel terms. Use with care! *) +Ltac2 Type case. + Ltac2 Type kind := [ | Rel (int) | Var (ident) @@ -32,7 +34,7 @@ Ltac2 Type kind := [ | Constant (constant, instance) | Ind (inductive, instance) | Constructor (constructor, instance) -| Case (constr, constr, constr array) +| Case (case, constr, constr, constr array) | Fix (int array, int, ident option array, constr array, constr array) | CoFix (int, ident option array, constr array, constr array) | Proj (projection, constr) @@ -40,8 +42,19 @@ Ltac2 Type kind := [ Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". +Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". + +Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". +(** Checks that a constr generated by unsafe means is indeed safe in the + current environment, and returns it, or the error otherwise. Panics if + not focussed. *) + Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". (** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with [r₁;...;rₙ] in [c]. *) +Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "constr_closenl". +(** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with + [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) + End Unsafe. -- cgit v1.2.3 From 72e3d2e563e08627559065ff0289403591d99682 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Aug 2017 23:49:21 +0200 Subject: Properly handling internal errors from Coq. --- src/tac2ffi.ml | 14 +++++++++++--- tests/errors.v | 12 ++++++++++++ theories/Init.v | 6 ++++++ 3 files changed, 29 insertions(+), 3 deletions(-) create mode 100644 tests/errors.v diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index a1f9debdcb..dd20de5ef5 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -92,14 +92,22 @@ let to_ident c = to_ext val_ident c let of_pattern c = of_ext val_pattern c let to_pattern c = to_ext val_pattern c +let internal_err = + let open Names in + KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string "Internal")) + (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with | LtacError (kn, c) -> ValOpn (kn, c) -| _ -> of_ext val_exn c +| _ -> ValOpn (internal_err, [|of_ext val_exn c|]) let to_exn c = match c with -| ValOpn (kn, c) -> (LtacError (kn, c), Exninfo.null) -| _ -> to_ext val_exn c +| ValOpn (kn, c) -> + if Names.KerName.equal kn internal_err then + to_ext val_exn c.(0) + else + (LtacError (kn, c), Exninfo.null) +| _ -> assert false let of_option f = function | None -> ValInt 0 diff --git a/tests/errors.v b/tests/errors.v new file mode 100644 index 0000000000..e7beff3420 --- /dev/null +++ b/tests/errors.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Ltac2. + +Goal True. +Proof. +let x := Control.plus + (fun () => let _ := constr:(nat -> 0) in 0) + (fun e => match e with Not_found => 1 | _ => 2 end) in +match Int.equal x 2 with +| true => () +| false => Control.throw Tactic_failure +end. +Abort. diff --git a/theories/Init.v b/theories/Init.v index 1591747eb4..baaf5956b2 100644 --- a/theories/Init.v +++ b/theories/Init.v @@ -46,6 +46,12 @@ Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. (** Pervasive exceptions *) +Ltac2 Type err. +(** Coq internal errors. Cannot be constructed, merely passed around. *) + +Ltac2 Type exn ::= [ Internal (err) ]. +(** Wrapper around the errors raised by Coq implementation. *) + Ltac2 Type exn ::= [ Out_of_bounds ]. (** Used for bound checking, e.g. with String and Array. *) -- cgit v1.2.3 From 2a0a48834f0b90319e56ae9f4a172fe6855583c0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 1 Sep 2017 00:19:33 +0200 Subject: Passing an optional message to Tactic_failure. --- tests/errors.v | 2 +- theories/Init.v | 2 +- theories/Notations.v | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/errors.v b/tests/errors.v index e7beff3420..c677f6af5d 100644 --- a/tests/errors.v +++ b/tests/errors.v @@ -7,6 +7,6 @@ let x := Control.plus (fun e => match e with Not_found => 1 | _ => 2 end) in match Int.equal x 2 with | true => () -| false => Control.throw Tactic_failure +| false => Control.throw (Tactic_failure None) end. Abort. diff --git a/theories/Init.v b/theories/Init.v index baaf5956b2..04394e2c5d 100644 --- a/theories/Init.v +++ b/theories/Init.v @@ -67,5 +67,5 @@ Ltac2 Type exn ::= [ Not_found ]. Ltac2 Type exn ::= [ Match_failure ]. (** Used to signal a pattern didn't match a term. *) -Ltac2 Type exn ::= [ Tactic_failure ]. +Ltac2 Type exn ::= [ Tactic_failure (message option) ]. (** Generic error for tactic failure. *) diff --git a/theories/Notations.v b/theories/Notations.v index 46c0e5e79f..411367eab1 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -27,7 +27,7 @@ match Control.case t with Control.plus (fun _ => s x) (fun e => s (k e)) end. -Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero Tactic_failure). +Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero (Tactic_failure None)). Ltac2 Notation fail := fail0 (). @@ -69,7 +69,7 @@ Ltac2 Notation progress := progress0. Ltac2 rec first0 tacs := match tacs with -| [] => Control.zero Tactic_failure +| [] => Control.zero (Tactic_failure None) | tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) end. @@ -77,12 +77,12 @@ Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs Ltac2 complete tac := let ans := tac () in - Control.enter (fun () => Control.zero Tactic_failure); + Control.enter (fun () => Control.zero (Tactic_failure None)); ans. Ltac2 rec solve0 tacs := match tacs with -| [] => Control.zero Tactic_failure +| [] => Control.zero (Tactic_failure None) | tac :: tacs => Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) end. -- cgit v1.2.3 From 1f7a2ea0e0513620bb946c10923d38f845061afa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 1 Sep 2017 00:27:35 +0200 Subject: Ensuring the Ltac definitions have lowercase names. --- src/tac2entries.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 2895fda060..efdc995a69 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -307,6 +307,10 @@ let inline_rec_tactic tactics = in List.map map tactics +let check_lowercase (loc, id) = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") + let register_ltac ?(local = false) ?(mut = false) isrec tactics = let map ((loc, na), e) = let id = match na with @@ -314,6 +318,7 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = user_err ?loc (str "Tactic definition must have a name") | Name id -> id in + let () = check_lowercase (loc, id) in ((loc, id), e) in let tactics = List.map map tactics in @@ -648,8 +653,9 @@ let inTac2Abbreviation : abbreviation -> obj = classify_function = classify_abbreviation} let register_notation ?(local = false) tkn lev body = match tkn, lev with -| [SexprRec (_, (_, Some id), [])], None -> +| [SexprRec (_, (loc, Some id), [])], None -> (** Tactic abbreviation *) + let () = check_lowercase (loc, id) in let body = Tac2intern.globalize Id.Set.empty body in let abbr = { abbr_body = body } in ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) -- cgit v1.2.3 From 0efde84daaa6b032e40a920a36793181724de87a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 2 Sep 2017 17:38:31 +0200 Subject: Fix coq/ltac2#15: Ltac2 scope cannot be disabled after it is required. Instead of setting globally the option, we add a hook to set it in the init object of the plugin. --- src/tac2entries.ml | 20 ++++++++++++++------ theories/Init.v | 2 -- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index efdc995a69..a503a0ab4c 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -827,13 +827,21 @@ let t_list = coq_def "list" let (f_register_constr_quotations, register_constr_quotations) = Hook.make () -let perform_constr_quotations (_, ()) = Hook.get f_register_constr_quotations () +let cache_ltac2_init (_, ()) = + Hook.get f_register_constr_quotations () + +let load_ltac2_init _ (_, ()) = + Hook.get f_register_constr_quotations () + +let open_ltac2_init _ (_, ()) = + Goptions.set_string_option_value_gen None ["Default"; "Proof"; "Mode"] "Ltac2" (** Dummy object that register global rules when Require is called *) -let inTac2ConstrQuotations : unit -> obj = - declare_object {(default_object "TAC2-CONSTR-QUOT") with - cache_function = perform_constr_quotations; - load_function = fun _ -> perform_constr_quotations; +let inTac2Init : unit -> obj = + declare_object {(default_object "TAC2-INIT") with + cache_function = cache_ltac2_init; + load_function = load_ltac2_init; + open_function = open_ltac2_init; } let _ = Mltop.declare_cache_obj begin fun () -> @@ -842,5 +850,5 @@ let _ = Mltop.declare_cache_obj begin fun () -> ("[]", []); ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); ]; - Lib.add_anonymous_leaf (inTac2ConstrQuotations ()); + Lib.add_anonymous_leaf (inTac2Init ()); end "ltac2_plugin" diff --git a/theories/Init.v b/theories/Init.v index 04394e2c5d..16e7d7a6f9 100644 --- a/theories/Init.v +++ b/theories/Init.v @@ -8,8 +8,6 @@ Declare ML Module "ltac2_plugin". -Global Set Default Proof Mode "Ltac2". - (** Primitive types *) Ltac2 Type int. -- cgit v1.2.3 From f84c0b96f11d5d1f130d36c0c04597ddeca6001f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 2 Sep 2017 18:19:34 +0200 Subject: Fix coq/ltac2#12: Error should name which match cases are unhandled. --- src/tac2intern.ml | 11 +++++++---- src/tac2print.ml | 16 ++++++++++++---- src/tac2print.mli | 1 + 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 88824386d9..b9e77f3cf5 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -953,12 +953,15 @@ and intern_case env loc e pl = intern_branch rem in let () = intern_branch pl in - let map = function - | None -> user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) + let map n is_const = function + | None -> + let kn = match kn with Other kn -> kn | _ -> assert false in + let cstr = pr_internal_constructor kn n is_const in + user_err ~loc (str "Unhandled match case for constructor " ++ cstr) | Some x -> x in - let const = Array.map map const in - let nonconst = Array.map map nonconst in + let const = Array.mapi (fun i o -> map i true o) const in + let nonconst = Array.mapi (fun i o -> map i false o) nonconst in let ce = GTacCse (e', kn, const, nonconst) in (ce, ret) | PKind_open kn -> diff --git a/src/tac2print.ml b/src/tac2print.ml index 939f44aeaf..75ad2082d4 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -125,6 +125,15 @@ let find_constructor n empty def = in find n def +let pr_internal_constructor tpe n is_const = + let data = match Tac2env.interp_type tpe with + | (_, GTydAlg data) -> data + | _ -> assert false + in + let id = find_constructor n is_const data.galg_constructors in + let kn = change_kn_label tpe id in + pr_constructor kn + let order_branches cbr nbr def = let rec order cidx nidx def = match def with | [] -> [] @@ -179,18 +188,17 @@ let pr_glbexpr_gen lvl c = paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) | GTacCst (Other tpe, n, cl) -> begin match Tac2env.interp_type tpe with - | _, GTydAlg { galg_constructors = def } -> + | _, GTydAlg def -> let paren = match lvl with | E0 -> paren | E1 | E2 | E3 | E4 | E5 -> fun x -> x in - let id = find_constructor n (List.is_empty cl) def in - let kn = change_kn_label tpe id in + let cstr = pr_internal_constructor tpe n (List.is_empty cl) in let cl = match cl with | [] -> mt () | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl in - paren (hov 2 (pr_constructor kn ++ cl)) + paren (hov 2 (cstr ++ cl)) | _, GTydRec def -> let args = List.combine def cl in let pr_arg ((id, _, _), arg) = diff --git a/src/tac2print.mli b/src/tac2print.mli index 0a04af2ff0..737e813ed3 100644 --- a/src/tac2print.mli +++ b/src/tac2print.mli @@ -24,6 +24,7 @@ val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t (** {5 Printing expressions} *) val pr_constructor : ltac_constructor -> Pp.t +val pr_internal_constructor : type_constant -> int -> bool -> Pp.t val pr_projection : ltac_projection -> Pp.t val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t val pr_glbexpr : glb_tacexpr -> Pp.t -- cgit v1.2.3 From 4d5e3f3f00cb1848861b938ba1a57c33800d71a6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 01:59:34 +0200 Subject: Fix coq/ltac2#16: Passing Ltac2 variables to Ltac1 via $ results in anomalies. --- src/tac2core.ml | 3 +++ src/tac2intern.ml | 3 +++ src/tac2intern.mli | 4 ++++ tests/compat.v | 4 ++++ 4 files changed, 14 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1f500352cf..81388af0ef 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -873,6 +873,9 @@ let () = let () = let intern ist tac = + (** Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in tac in diff --git a/src/tac2intern.ml b/src/tac2intern.ml index b9e77f3cf5..490436422d 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -169,6 +169,9 @@ let env_name env = let ltac2_env : environment Genintern.Store.field = Genintern.Store.field () +let drop_ltac2_env store = + Genintern.Store.remove store ltac2_env + let fresh_id env = UF.fresh env.env_cst let get_alias (loc, id) env = diff --git a/src/tac2intern.mli b/src/tac2intern.mli index 8c997b741e..95199d449d 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -43,3 +43,7 @@ val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr val error_nargs_mismatch : Loc.t -> ltac_constructor -> int -> int -> 'a val error_nparams_mismatch : Loc.t -> int -> int -> 'a + +(** Misc *) + +val drop_ltac2_env : Genintern.Store.t -> Genintern.Store.t diff --git a/tests/compat.v b/tests/compat.v index 44421349da..f4e849c5de 100644 --- a/tests/compat.v +++ b/tests/compat.v @@ -25,6 +25,9 @@ Abort. (** Variables do not cross the compatibility layer boundary. *) Fail Ltac2 bar nay := ltac1:(discriminate nay). +Fail Ltac2 pose1 (v : constr) := + ltac1:(pose $v). + (** Test calls to Ltac2 from Ltac1 *) Set Default Proof Mode "Classic". @@ -54,3 +57,4 @@ Fail mytac ltac2:(fail). let t := idtac; ltac2:(fail) in mytac t. constructor. Qed. + -- cgit v1.2.3 From 83a92df4e2e94bfc33354cf26627329d4a2e0610 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 17:39:16 +0200 Subject: Allowing complex types in ML objects. --- src/tac2core.ml | 29 +++++++++++++---------------- src/tac2env.ml | 5 +++-- src/tac2env.mli | 5 +++-- src/tac2intern.ml | 13 ++++++++++--- 4 files changed, 29 insertions(+), 23 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 81388af0ef..b8bec37d04 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -775,9 +775,11 @@ let to_lvar ist = let lfun = Tac2interp.set_env ist Id.Map.empty in { empty_lvar with Glob_term.ltac_genargs = lfun } -let intern_constr ist c = +let gtypref kn = GTypRef (Other kn, []) + +let intern_constr self ist c = let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in - c + (c, gtypref t_constr) let interp_constr flags ist c = let open Pretyping in @@ -796,7 +798,6 @@ let () = let interp ist c = interp_constr (constr_flags ()) ist c in let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in let obj = { - ml_type = t_constr; ml_intern = intern; ml_subst = Detyping.subst_glob_constr; ml_interp = interp; @@ -809,7 +810,6 @@ let () = let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in let obj = { - ml_type = t_constr; ml_intern = intern; ml_subst = Detyping.subst_glob_constr; ml_interp = interp; @@ -821,8 +821,7 @@ let () = let interp _ id = return (ValExt (Value.val_ident, id)) in let print _ id = str "ident:(" ++ Id.print id ++ str ")" in let obj = { - ml_type = t_ident; - ml_intern = (fun _ id -> id); + ml_intern = (fun _ _ id -> id, gtypref t_ident); ml_interp = interp; ml_subst = (fun _ id -> id); ml_print = print; @@ -830,14 +829,13 @@ let () = define_ml_object Tac2env.wit_ident obj let () = - let intern ist c = + let intern self ist c = let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in - pat + pat, gtypref t_pattern in let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in let interp _ c = return (ValExt (Value.val_pattern, c)) in let obj = { - ml_type = t_pattern; ml_intern = intern; ml_interp = interp; ml_subst = Patternops.subst_pattern; @@ -846,15 +844,16 @@ let () = define_ml_object Tac2env.wit_pattern obj let () = - let intern ist qid = match qid with - | Libnames.Ident (_, id) -> Globnames.VarRef id + let intern self ist qid = match qid with + | Libnames.Ident (_, id) -> + Globnames.VarRef id, gtypref t_reference | Libnames.Qualid (loc, qid) -> let gr = try Nametab.locate qid with Not_found -> Nametab.error_global_not_found ?loc qid in - gr + gr, gtypref t_reference in let subst s c = Globnames.subst_global_reference s c in let interp _ gr = return (Value.of_reference gr) in @@ -863,7 +862,6 @@ let () = | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" in let obj = { - ml_type = t_reference; ml_intern = intern; ml_subst = subst; ml_interp = interp; @@ -872,12 +870,12 @@ let () = define_ml_object Tac2env.wit_reference obj let () = - let intern ist tac = + let intern self ist tac = (** Prevent inner calls to Ltac2 values *) let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in let ist = { ist with Genintern.extra } in let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in - tac + tac, gtypref t_unit in let interp _ tac = (** FUCK YOU API *) @@ -889,7 +887,6 @@ let () = str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic (Obj.magic env) tac ++ str ")" in let obj = { - ml_type = t_unit; ml_intern = intern; ml_subst = subst; ml_interp = interp; diff --git a/src/tac2env.ml b/src/tac2env.ml index 489113c031..56fd55ee84 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -251,9 +251,10 @@ let shortest_qualid_of_projection kn = let sp = KNmap.find kn tab.tab_proj_rev in KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + type ('a, 'b) ml_object = { - ml_type : type_constant; - ml_intern : Genintern.glob_sign -> 'a -> 'b; + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; ml_print : Environ.env -> 'b -> Pp.t; diff --git a/src/tac2env.mli b/src/tac2env.mli index 0ef62d67ed..15664db756 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -105,9 +105,10 @@ val interp_primitive : ml_tactic_name -> ml_tactic (** {5 ML primitive types} *) +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + type ('a, 'b) ml_object = { - ml_type : type_constant; - ml_intern : Genintern.glob_sign -> 'a -> 'b; + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; ml_print : Environ.env -> 'b -> Pp.t; diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 490436422d..5d2fc2b47b 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -775,14 +775,21 @@ let rec intern_rec env = function (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) | CTacExt (loc, tag, arg) -> let open Genintern in - let tpe = interp_ml_object tag in + let self ist e = + let env = match Store.get ist.extra ltac2_env with + | None -> empty_env () + | Some env -> env + in + intern_rec env e + in + let obj = interp_ml_object tag in (** External objects do not have access to the named context because this is not stable by dynamic semantics. *) let genv = Global.env_of_context Environ.empty_named_context_val in let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let arg = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> tpe.ml_intern ist arg) () in - (GTacExt (tag, arg), GTypRef (Other tpe.ml_type, [])) + let arg, tpe = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> obj.ml_intern self ist arg) () in + (GTacExt (tag, arg), tpe) and intern_rec_with_constraint env e exp = let loc = loc_of_tacexpr e in -- cgit v1.2.3 From ba61b133772d76e6ff3f93da2ab136afd2f5a867 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 18:23:17 +0200 Subject: Allowing ML objects to return mere tactic expressions. --- src/tac2core.ml | 12 ++++++------ src/tac2env.ml | 6 +++++- src/tac2env.mli | 6 +++++- src/tac2intern.ml | 6 +++++- 4 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index b8bec37d04..e1aa6eb48c 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -779,7 +779,7 @@ let gtypref kn = GTypRef (Other kn, []) let intern_constr self ist c = let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in - (c, gtypref t_constr) + (GlbVal c, gtypref t_constr) let interp_constr flags ist c = let open Pretyping in @@ -821,7 +821,7 @@ let () = let interp _ id = return (ValExt (Value.val_ident, id)) in let print _ id = str "ident:(" ++ Id.print id ++ str ")" in let obj = { - ml_intern = (fun _ _ id -> id, gtypref t_ident); + ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); ml_interp = interp; ml_subst = (fun _ id -> id); ml_print = print; @@ -831,7 +831,7 @@ let () = let () = let intern self ist c = let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in - pat, gtypref t_pattern + GlbVal pat, gtypref t_pattern in let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in let interp _ c = return (ValExt (Value.val_pattern, c)) in @@ -846,14 +846,14 @@ let () = let () = let intern self ist qid = match qid with | Libnames.Ident (_, id) -> - Globnames.VarRef id, gtypref t_reference + GlbVal (Globnames.VarRef id), gtypref t_reference | Libnames.Qualid (loc, qid) -> let gr = try Nametab.locate qid with Not_found -> Nametab.error_global_not_found ?loc qid in - gr, gtypref t_reference + GlbVal gr, gtypref t_reference in let subst s c = Globnames.subst_global_reference s c in let interp _ gr = return (Value.of_reference gr) in @@ -875,7 +875,7 @@ let () = let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in let ist = { ist with Genintern.extra } in let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in - tac, gtypref t_unit + GlbVal tac, gtypref t_unit in let interp _ tac = (** FUCK YOU API *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 56fd55ee84..5a817df713 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -251,10 +251,14 @@ let shortest_qualid_of_projection kn = let sp = KNmap.find kn tab.tab_proj_rev in KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr type ('a, 'b) ml_object = { - ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b, 'r) intern_fun; + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; ml_print : Environ.env -> 'b -> Pp.t; diff --git a/src/tac2env.mli b/src/tac2env.mli index 15664db756..eb18dc8e39 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -105,10 +105,14 @@ val interp_primitive : ml_tactic_name -> ml_tactic (** {5 ML primitive types} *) +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr type ('a, 'b) ml_object = { - ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b, 'r) intern_fun; + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; ml_interp : environment -> 'b -> valexpr Proofview.tactic; ml_print : Environ.env -> 'b -> Pp.t; diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 5d2fc2b47b..2b234d7aec 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -789,7 +789,11 @@ let rec intern_rec env = function let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in let arg, tpe = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> obj.ml_intern self ist arg) () in - (GTacExt (tag, arg), tpe) + let e = match arg with + | GlbVal arg -> GTacExt (tag, arg) + | GlbTacexpr e -> e + in + (e, tpe) and intern_rec_with_constraint env e exp = let loc = loc_of_tacexpr e in -- cgit v1.2.3 From 0b21a350f27d723a8f55a448be5ffde4841d21ad Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 18:33:30 +0200 Subject: Uniform handling of locations in the various AST. --- src/g_ltac2.ml4 | 95 ++++++++++------- src/tac2core.ml | 14 ++- src/tac2entries.ml | 39 ++++--- src/tac2expr.mli | 46 ++++---- src/tac2intern.ml | 307 +++++++++++++++++++++++++---------------------------- src/tac2intern.mli | 8 +- src/tac2quote.ml | 76 ++++++------- 7 files changed, 288 insertions(+), 297 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index bfd2ab1a11..338711e79c 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -86,19 +86,19 @@ let tac2mode = Gram.entry_create "vernac:ltac2_command" (** FUCK YOU API *) let ltac1_expr = (Obj.magic Pltac.tactic_expr : Tacexpr.raw_tactic_expr Gram.entry) -let inj_wit wit loc x = CTacExt (loc, wit, x) +let inj_wit wit loc x = Loc.tag ~loc @@ CTacExt (wit, x) let inj_open_constr loc c = inj_wit Tac2env.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c let inj_reference loc c = inj_wit Tac2env.wit_reference loc c let inj_ltac1 loc e = inj_wit Tac2env.wit_ltac1 loc e -let pattern_of_qualid loc id = - if Tac2env.is_constructor (snd id) then CPatRef (loc, RelId id, []) +let pattern_of_qualid ?loc id = + if Tac2env.is_constructor (snd id) then Loc.tag ?loc @@ CPatRef (RelId id, []) else let (dp, id) = Libnames.repr_qualid (snd id) in - if DirPath.is_empty dp then CPatVar (Some loc, Name id) + if DirPath.is_empty dp then Loc.tag ?loc @@ CPatVar (Name id) else - CErrors.user_err ~loc (Pp.str "Syntax error") + CErrors.user_err ?loc (Pp.str "Syntax error") GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn @@ -107,53 +107,62 @@ GEXTEND Gram [ "1" LEFTA [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> if Tac2env.is_constructor (snd id) then - CPatRef (!@loc, RelId id, pl) + Loc.tag ~loc:!@loc @@ CPatRef (RelId id, pl) else CErrors.user_err ~loc:!@loc (Pp.str "Syntax error") - | id = Prim.qualid -> pattern_of_qualid !@loc id - | "["; "]" -> CPatRef (!@loc, AbsKn (Other Tac2core.Core.c_nil), []) + | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id + | "["; "]" -> Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) | p1 = tac2pat; "::"; p2 = tac2pat -> - CPatRef (!@loc, AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) + Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) ] | "0" - [ "_" -> CPatVar (Some !@loc, Anonymous) - | "()" -> CPatRef (!@loc, AbsKn (Tuple 0), []) - | id = Prim.qualid -> pattern_of_qualid !@loc id + [ "_" -> Loc.tag ~loc:!@loc @@ CPatVar Anonymous + | "()" -> Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) + | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> - CPatRef (!@loc, AbsKn (Tuple (List.length pl)), pl) ] + Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) ] ] ; tac2expr: [ "6" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> CTacSeq (!@loc, e1, e2) ] + [ e1 = SELF; ";"; e2 = SELF -> Loc.tag ~loc:!@loc @@ CTacSeq (e1, e2) ] | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> CTacFun (!@loc, it, body) + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + Loc.tag ~loc:!@loc @@ CTacFun (it, body) | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "6" -> CTacLet (!@loc, isrec, lc, e) + e = tac2expr LEVEL "6" -> + Loc.tag ~loc:!@loc @@ CTacLet (isrec, lc, e) | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> - CTacCse (!@loc, e, bl) + Loc.tag ~loc:!@loc @@ CTacCse (e, bl) ] | "4" LEFTA [ ] | "::" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> - CTacApp (!@loc, CTacCst (!@loc, AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) + Loc.tag ~loc:!@loc @@ CTacApp (Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) ] | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> let el = e0 :: el in - CTacApp (!@loc, CTacCst (!@loc, AbsKn (Tuple (List.length el))), el) ] + Loc.tag ~loc:!@loc @@ CTacApp (Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) ] | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> CTacApp (!@loc, e, el) - | e = SELF; ".("; qid = Prim.qualid; ")" -> CTacPrj (!@loc, e, RelId qid) - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> CTacSet (!@loc, e, RelId qid, r) ] + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + Loc.tag ~loc:!@loc @@ CTacApp (e, el) + | e = SELF; ".("; qid = Prim.qualid; ")" -> + Loc.tag ~loc:!@loc @@ CTacPrj (e, RelId qid) + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + Loc.tag ~loc:!@loc @@ CTacSet (e, RelId qid, r) ] | "0" [ "("; a = SELF; ")" -> a - | "("; a = SELF; ":"; t = tac2type; ")" -> CTacCnv (!@loc, a, t) - | "()" -> CTacCst (!@loc, AbsKn (Tuple 0)) - | "("; ")" -> CTacCst (!@loc, AbsKn (Tuple 0)) + | "("; a = SELF; ":"; t = tac2type; ")" -> + Loc.tag ~loc:!@loc @@ CTacCnv (a, t) + | "()" -> + Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) + | "("; ")" -> + Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> Tac2quote.of_list ~loc:!@loc (fun x -> x) a - | "{"; a = tac2rec_fieldexprs; "}" -> CTacRec (!@loc, a) + | "{"; a = tac2rec_fieldexprs; "}" -> + Loc.tag ~loc:!@loc @@ CTacRec a | a = tactic_atom -> a ] ] ; @@ -178,10 +187,13 @@ GEXTEND Gram [ [ "'"; id = Prim.ident -> id ] ] ; tactic_atom: - [ [ n = Prim.integer -> CTacAtm (Loc.tag ~loc:!@loc (AtmInt n)) - | s = Prim.string -> CTacAtm (Loc.tag ~loc:!@loc (AtmStr s)) + [ [ n = Prim.integer -> Loc.tag ~loc:!@loc @@ CTacAtm (AtmInt n) + | s = Prim.string -> Loc.tag ~loc:!@loc @@ CTacAtm (AtmStr s) | id = Prim.qualid -> - if Tac2env.is_constructor (snd id) then CTacCst (!@loc, RelId id) else CTacRef (RelId id) + if Tac2env.is_constructor (snd id) then + Loc.tag ~loc:!@loc @@ CTacCst (RelId id) + else + Loc.tag ~loc:!@loc @@ CTacRef (RelId id) | "@"; id = Prim.ident -> Tac2quote.of_ident (Loc.tag ~loc:!@loc id) | "&"; id = lident -> Tac2quote.of_hyp ~loc:!@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c @@ -196,35 +208,38 @@ GEXTEND Gram let_clause: [ [ binder = let_binder; ":="; te = tac2expr -> let (pat, fn) = binder in - let te = match fn with None -> te | Some args -> CTacFun (!@loc, args, te) in + let te = match fn with + | None -> te + | Some args -> Loc.tag ~loc:!@loc @@ CTacFun (args, te) + in (pat, None, te) ] ] ; let_binder: [ [ pats = LIST1 input_fun -> match pats with - | [CPatVar _ as pat, None] -> (pat, None) - | (CPatVar (_, Name id) as pat, None) :: args -> (pat, Some args) + | [(_, CPatVar _) as pat, None] -> (pat, None) + | ((_, CPatVar (Name id)) as pat, None) :: args -> (pat, Some args) | [pat, None] -> (pat, None) | _ -> CErrors.user_err ~loc:!@loc (str "Invalid pattern") ] ] ; tac2type: [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> CTypArrow (!@loc, t1, t2) ] + [ t1 = tac2type; "->"; t2 = tac2type -> Loc.tag ~loc:!@loc @@ CTypArrow (t1, t2) ] | "2" [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> let tl = t :: tl in - CTypRef (!@loc, AbsKn (Tuple (List.length tl)), tl) ] + Loc.tag ~loc:!@loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) ] | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> CTypRef (!@loc, RelId qid, [t]) ] + [ t = SELF; qid = Prim.qualid -> Loc.tag ~loc:!@loc @@ CTypRef (RelId qid, [t]) ] | "0" [ "("; t = tac2type LEVEL "5"; ")" -> t - | id = typ_param -> CTypVar (Loc.tag ~loc:!@loc (Name id)) - | "_" -> CTypVar (Loc.tag ~loc:!@loc Anonymous) - | qid = Prim.qualid -> CTypRef (!@loc, RelId qid, []) + | id = typ_param -> Loc.tag ~loc:!@loc @@ CTypVar (Name id) + | "_" -> Loc.tag ~loc:!@loc @@ CTypVar Anonymous + | qid = Prim.qualid -> Loc.tag ~loc:!@loc @@ CTypRef (RelId qid, []) | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - CTypRef (!@loc, RelId qid, p) ] + Loc.tag ~loc:!@loc @@ CTypRef (RelId qid, p) ] ]; locident: [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] @@ -239,7 +254,7 @@ GEXTEND Gram ; tac2def_body: [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> - let e = if List.is_empty it then e else CTacFun (!@loc, it, e) in + let e = if List.is_empty it then e else Loc.tag ~loc:!@loc @@ CTacFun (it, e) in (name, e) ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index e1aa6eb48c..db8f989768 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -938,20 +938,18 @@ let add_scope s f = let scope_fail () = CErrors.user_err (str "Invalid parsing token") -let dummy_loc = Loc.make_loc (-1, -1) - -let q_unit = CTacCst (dummy_loc, AbsKn (Tuple 0)) +let q_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) let rthunk e = let loc = Tac2intern.loc_of_tacexpr e in - let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other Core.t_unit), []))] in - CTacFun (loc, var, e) + let var = [Loc.tag ?loc @@ CPatVar Anonymous, Some (Loc.tag ?loc @@ CTypRef (AbsKn (Other Core.t_unit), []))] in + Loc.tag ?loc @@ CTacFun (var, e) let add_generic_scope s entry arg = let parse = function | [] -> let scope = Extend.Aentry entry in - let act x = CTacExt (dummy_loc, arg, x) in + let act x = Loc.tag @@ CTacExt (arg, x) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () in @@ -1007,9 +1005,9 @@ let () = add_scope "opt" begin function let scope = Extend.Aopt scope in let act opt = match opt with | None -> - CTacCst (dummy_loc, AbsKn (Other Core.c_none)) + Loc.tag @@ CTacCst (AbsKn (Other Core.c_none)) | Some x -> - CTacApp (dummy_loc, CTacCst (dummy_loc, AbsKn (Other Core.c_some)), [act x]) + Loc.tag @@ CTacApp (Loc.tag @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) in Tac2entries.ScopeRule (scope, act) | _ -> scope_fail () diff --git a/src/tac2entries.ml b/src/tac2entries.ml index a503a0ab4c..9c5d9a659b 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -263,8 +263,6 @@ let inTypExt : typext -> obj = (** Toplevel entries *) -let dummy_loc = Loc.make_loc (-1, -1) - let fresh_var avoid x = let bad id = Id.Set.mem id avoid || @@ -275,8 +273,8 @@ let fresh_var avoid x = (** Mangle recursive tactics *) let inline_rec_tactic tactics = let avoid = List.fold_left (fun accu ((_, id), _) -> Id.Set.add id accu) Id.Set.empty tactics in - let map (id, e) = match e with - | CTacFun (loc, pat, _) -> (id, pat, e) + let map (id, e) = match snd e with + | CTacFun (pat, _) -> (id, pat, e) | _ -> let loc, _ = id in user_err ?loc (str "Recursive tactic definitions must be functions") @@ -286,24 +284,24 @@ let inline_rec_tactic tactics = let fold_var (avoid, ans) (pat, _) = let id = fresh_var avoid "x" in let loc = loc_of_patexpr pat in - (Id.Set.add id avoid, Loc.tag ~loc id :: ans) + (Id.Set.add id avoid, Loc.tag ?loc id :: ans) in (** Fresh variables to abstract over the function patterns *) let _, vars = List.fold_left fold_var (avoid, []) pat in - let map_body ((loc, id), _, e) = CPatVar (loc, Name id), None, e in + let map_body ((loc, id), _, e) = (Loc.tag ?loc @@ CPatVar (Name id)), None, e in let bnd = List.map map_body tactics in let pat_of_id (loc, id) = - (CPatVar (loc, Name id), None) + ((Loc.tag ?loc @@ CPatVar (Name id)), None) in let var_of_id (loc, id) = let qid = (loc, qualid_of_ident id) in - CTacRef (RelId qid) + Loc.tag ?loc @@ CTacRef (RelId qid) in let loc0 = loc_of_tacexpr e in let vpat = List.map pat_of_id vars in let varg = List.map var_of_id vars in - let e = CTacLet (loc0, true, bnd, CTacApp (loc0, var_of_id id, varg)) in - (id, CTacFun (loc0, vpat, e)) + let e = Loc.tag ?loc:loc0 @@ CTacLet (true, bnd, Loc.tag ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in + (id, Loc.tag ?loc:loc0 @@ CTacFun (vpat, e)) in List.map map tactics @@ -459,9 +457,8 @@ let register_open ?(local = false) (loc, qid) (params, def) = user_err ?loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") in let () = - let loc = Option.default dummy_loc loc in if not (Int.equal (List.length params) tparams) then - Tac2intern.error_nparams_mismatch loc (List.length params) tparams + Tac2intern.error_nparams_mismatch ?loc (List.length params) tparams in match def with | CTydOpn -> () @@ -524,9 +521,9 @@ module ParseToken = struct let loc_of_token = function -| SexprStr (loc, _) -> Option.default dummy_loc loc -| SexprInt (loc, _) -> Option.default dummy_loc loc -| SexprRec (loc, _, _) -> loc +| SexprStr (loc, _) -> loc +| SexprInt (loc, _) -> loc +| SexprRec (loc, _, _) -> Some loc let parse_scope = function | SexprRec (_, (loc, Some id), toks) -> @@ -535,11 +532,11 @@ let parse_scope = function else CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Nameops.pr_id id) | SexprStr (_, str) -> - let v_unit = CTacCst (dummy_loc, AbsKn (Tuple 0)) in + let v_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) in ScopeRule (Extend.Atoken (Tok.IDENT str), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in - CErrors.user_err ~loc (str "Invalid parsing token") + CErrors.user_err ?loc (str "Invalid parsing token") let parse_token = function | SexprStr (_, s) -> TacTerm s @@ -549,7 +546,7 @@ let parse_token = function TacNonTerm (na, scope) | tok -> let loc = loc_of_token tok in - CErrors.user_err ~loc (str "Invalid parsing token") + CErrors.user_err ?loc (str "Invalid parsing token") end @@ -586,10 +583,10 @@ let perform_notation syn st = let mk loc args = let map (na, e) = let loc = loc_of_tacexpr e in - (CPatVar (Loc.tag ~loc na), None, e) + ((Loc.tag ?loc @@ CPatVar na), None, e) in let bnd = List.map map args in - CTacLet (loc, false, bnd, syn.synext_exp) + Loc.tag ~loc @@ CTacLet (false, bnd, syn.synext_exp) in let rule = Extend.Rule (rule, act mk) in let lev = match syn.synext_lev with @@ -793,7 +790,7 @@ let solve default tac = let call ~default e = let loc = loc_of_tacexpr e in let (e, t) = intern e in - let () = check_unit ~loc t in + let () = check_unit ?loc t in let tac = Tac2interp.interp Id.Map.empty e in solve default (Proofview.tclIGNORE tac) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index ccff8e7756..1045063cd2 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -44,10 +44,12 @@ type 'a or_tuple = (** {5 Type syntax} *) -type raw_typexpr = -| CTypVar of Name.t located -| CTypArrow of Loc.t * raw_typexpr * raw_typexpr -| CTypRef of Loc.t * type_constant or_tuple or_relid * raw_typexpr list +type raw_typexpr_r = +| CTypVar of Name.t +| CTypArrow of raw_typexpr * raw_typexpr +| CTypRef of type_constant or_tuple or_relid * raw_typexpr list + +and raw_typexpr = raw_typexpr_r located type raw_typedef = | CTydDef of raw_typexpr option @@ -87,24 +89,28 @@ type atom = | AtmStr of string (** Tactic expressions *) -type raw_patexpr = -| CPatVar of Name.t located -| CPatRef of Loc.t * ltac_constructor or_tuple or_relid * raw_patexpr list +type raw_patexpr_r = +| CPatVar of Name.t +| CPatRef of ltac_constructor or_tuple or_relid * raw_patexpr list + +and raw_patexpr = raw_patexpr_r located -type raw_tacexpr = -| CTacAtm of atom located +type raw_tacexpr_r = +| CTacAtm of atom | CTacRef of tacref or_relid -| CTacCst of Loc.t * ltac_constructor or_tuple or_relid -| CTacFun of Loc.t * (raw_patexpr * raw_typexpr option) list * raw_tacexpr -| CTacApp of Loc.t * raw_tacexpr * raw_tacexpr list -| CTacLet of Loc.t * rec_flag * (raw_patexpr * raw_typexpr option * raw_tacexpr) list * raw_tacexpr -| CTacCnv of Loc.t * raw_tacexpr * raw_typexpr -| CTacSeq of Loc.t * raw_tacexpr * raw_tacexpr -| CTacCse of Loc.t * raw_tacexpr * raw_taccase list -| CTacRec of Loc.t * raw_recexpr -| CTacPrj of Loc.t * raw_tacexpr * ltac_projection or_relid -| CTacSet of Loc.t * raw_tacexpr * ltac_projection or_relid * raw_tacexpr -| CTacExt : Loc.t * ('a, _) Tac2dyn.Arg.tag * 'a -> raw_tacexpr +| CTacCst of ltac_constructor or_tuple or_relid +| CTacFun of (raw_patexpr * raw_typexpr option) list * raw_tacexpr +| CTacApp of raw_tacexpr * raw_tacexpr list +| CTacLet of rec_flag * (raw_patexpr * raw_typexpr option * raw_tacexpr) list * raw_tacexpr +| CTacCnv of raw_tacexpr * raw_typexpr +| CTacSeq of raw_tacexpr * raw_tacexpr +| CTacCse of raw_tacexpr * raw_taccase list +| CTacRec of raw_recexpr +| CTacPrj of raw_tacexpr * ltac_projection or_relid +| CTacSet of raw_tacexpr * ltac_projection or_relid * raw_tacexpr +| CTacExt : ('a, _) Tac2dyn.Arg.tag * 'a -> raw_tacexpr_r + +and raw_tacexpr = raw_tacexpr_r located and raw_taccase = raw_patexpr * raw_tacexpr diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 2b234d7aec..c1fd281808 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -187,36 +187,18 @@ let push_name id t env = match id with | Anonymous -> env | Name id -> { env with env_var = Id.Map.add id t env.env_var } -let dummy_loc = Loc.make_loc (-1, -1) - -let loc_of_tacexpr = function -| CTacAtm (loc, _) -> Option.default dummy_loc loc -| CTacRef (RelId (loc, _)) -> Option.default dummy_loc loc -| CTacRef (AbsKn _) -> dummy_loc -| CTacCst (loc, _) -> loc -| CTacFun (loc, _, _) -> loc -| CTacApp (loc, _, _) -> loc -| CTacLet (loc, _, _, _) -> loc -| CTacCnv (loc, _, _) -> loc -| CTacSeq (loc, _, _) -> loc -| CTacCse (loc, _, _) -> loc -| CTacRec (loc, _) -> loc -| CTacPrj (loc, _, _) -> loc -| CTacSet (loc, _, _, _) -> loc -| CTacExt (loc, _, _) -> loc - -let loc_of_patexpr = function -| CPatVar (loc, _) -> Option.default dummy_loc loc -| CPatRef (loc, _, _) -> loc - -let error_nargs_mismatch loc kn nargs nfound = +let loc_of_tacexpr (loc, _) : Loc.t option = loc + +let loc_of_patexpr (loc, _) : Loc.t option = loc + +let error_nargs_mismatch ?loc kn nargs nfound = let cstr = Tac2env.shortest_qualid_of_constructor kn in - user_err ~loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ + user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ int nargs ++ str " arguments, but is applied to " ++ int nfound ++ str " arguments") -let error_nparams_mismatch loc nargs nfound = - user_err ~loc (str "Type expects " ++ int nargs ++ +let error_nparams_mismatch ?loc nargs nfound = + user_err ?loc (str "Type expects " ++ int nargs ++ str " arguments, but is applied to " ++ int nfound ++ str " arguments") @@ -226,10 +208,10 @@ let rec subst_type subst (t : 'a glb_typexpr) = match t with | GTypRef (qid, args) -> GTypRef (qid, List.map (fun t -> subst_type subst t) args) -let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with -| CTypVar (loc, Name id) -> GTypVar (get_alias (Loc.tag ?loc id) env) -| CTypVar (_, Anonymous) -> GTypVar (fresh_id env) -| CTypRef (loc, rel, args) -> +let rec intern_type env ((loc, t) : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (Name id) -> GTypVar (get_alias (Loc.tag ?loc id) env) +| CTypVar Anonymous -> GTypVar (fresh_id env) +| CTypRef (rel, args) -> let (kn, nparams) = match rel with | RelId (loc, qid) -> let (dp, id) = repr_qualid qid in @@ -255,7 +237,7 @@ let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with if not (Int.equal nparams nargs) then let loc, qid = match rel with | RelId lid -> lid - | AbsKn (Other kn) -> Some loc, shortest_qualid_of_type kn + | AbsKn (Other kn) -> loc, shortest_qualid_of_type kn | AbsKn (Tuple _) -> assert false in user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ @@ -263,7 +245,7 @@ let rec intern_type env (t : raw_typexpr) : UF.elt glb_typexpr = match t with applied to " ++ int nargs ++ strbrk "argument(s)") in GTypRef (kn, List.map (fun t -> intern_type env t) args) -| CTypArrow (loc, t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) +| CTypArrow (t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = let (n, t) = t in @@ -387,7 +369,7 @@ let unify_arrow ?loc env ft args = let rec iter ft args is_fun = match kind env ft, args with | t, [] -> t | GTypArrow (t1, ft), (loc, t2) :: args -> - let () = unify ~loc env t2 t1 in + let () = unify ?loc env t2 t1 in iter ft args true | GTypVar id, (_, t) :: args -> let ft = GTypVar (fresh_id env) in @@ -492,19 +474,19 @@ let check_elt_unit loc env t = | GTypRef (Tuple 0, []) -> true | GTypRef _ -> false in - if not maybe_unit then warn_not_unit ~loc () + if not maybe_unit then warn_not_unit ?loc () let check_elt_empty loc env t = match kind env t with | GTypVar _ -> - user_err ~loc (str "Cannot infer an empty type for this expression") + user_err ?loc (str "Cannot infer an empty type for this expression") | GTypArrow _ | GTypRef (Tuple _, _) -> - user_err ~loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") + user_err ?loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") | GTypRef (Other kn, _) -> let def = Tac2env.interp_type kn in match def with | _, GTydAlg { galg_constructors = [] } -> kn | _ -> - user_err ~loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") + user_err ?loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") let check_unit ?loc t = let env = empty_env () in @@ -520,7 +502,7 @@ let check_unit ?loc t = let check_redundant_clause = function | [] -> () -| (p, _) :: _ -> warn_redundant_clause ~loc:(loc_of_patexpr p) () +| (p, _) :: _ -> warn_redundant_clause ?loc:(loc_of_patexpr p) () let get_variable0 mem var = match var with | RelId (loc, qid) -> @@ -576,9 +558,9 @@ type glb_patexpr = | GPatVar of Name.t | GPatRef of ltac_constructor or_tuple * glb_patexpr list -let rec intern_patexpr env = function -| CPatVar (_, na) -> GPatVar na -| CPatRef (_, qid, pl) -> +let rec intern_patexpr env (_, pat) = match pat with +| CPatVar na -> GPatVar na +| CPatRef (qid, pl) -> let kn = get_constructor env qid in GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) @@ -619,27 +601,27 @@ let add_name accu = function | Name id -> Id.Set.add id accu | Anonymous -> accu -let rec ids_of_pattern accu = function -| CPatVar (_, Anonymous) -> accu -| CPatVar (_, Name id) -> Id.Set.add id accu -| CPatRef (_, _, pl) -> +let rec ids_of_pattern accu (_, pat) = match pat with +| CPatVar Anonymous -> accu +| CPatVar (Name id) -> Id.Set.add id accu +| CPatRef (_, pl) -> List.fold_left ids_of_pattern accu pl let loc_of_relid = function -| RelId (loc, _) -> Option.default dummy_loc loc -| AbsKn _ -> dummy_loc +| RelId (loc, _) -> loc +| AbsKn _ -> None (** Expand pattern: [p => t] becomes [x => match x with p => t end] *) let expand_pattern avoid bnd = let fold (avoid, bnd) (pat, t) = - let na, expand = match pat with - | CPatVar (_, na) -> + let na, expand = match snd pat with + | CPatVar na -> (** Don't expand variable patterns *) na, None | _ -> let loc = loc_of_patexpr pat in let id = fresh_var avoid in - let qid = RelId (Loc.tag ~loc (qualid_of_ident id)) in + let qid = RelId (Loc.tag ?loc (qualid_of_ident id)) in Name id, Some qid in let avoid = ids_of_pattern avoid pat in @@ -649,7 +631,9 @@ let expand_pattern avoid bnd = let (_, bnd) = List.fold_left fold (avoid, []) bnd in let fold e (na, pat, expand) = match expand with | None -> e - | Some qid -> CTacCse (loc_of_relid qid, CTacRef qid, [pat, e]) + | Some qid -> + let loc = loc_of_relid qid in + Loc.tag ?loc @@ CTacCse (Loc.tag ?loc @@ CTacRef qid, [pat, e]) in let expand e = List.fold_left fold e bnd in let nas = List.rev_map (fun (na, _, _) -> na) bnd in @@ -659,8 +643,8 @@ let is_alias env qid = match get_variable env qid with | ArgArg (TacAlias _) -> true | ArgVar _ | (ArgArg (TacConstant _)) -> false -let rec intern_rec env = function -| CTacAtm (_, atm) -> intern_atm env atm +let rec intern_rec env (loc, e) = match e with +| CTacAtm atm -> intern_atm env atm | CTacRef qid -> begin match get_variable env qid with | ArgVar (_, id) -> @@ -673,10 +657,10 @@ let rec intern_rec env = function let e = Tac2env.interp_alias kn in intern_rec env e end -| CTacCst (loc, qid) -> +| CTacCst qid -> let kn = get_constructor env qid in intern_constructor env loc kn [] -| CTacFun (loc, bnd, e) -> +| CTacFun (bnd, e) -> let map (_, t) = match t with | None -> GTypVar (fresh_id env) | Some t -> intern_type env t @@ -687,10 +671,10 @@ let rec intern_rec env = function let (e, t) = intern_rec env (exp e) in let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in (GTacFun (nas, e), t) -| CTacApp (loc, CTacCst (_, qid), args) -> +| CTacApp ((loc, CTacCst qid), args) -> let kn = get_constructor env qid in intern_constructor env loc kn args -| CTacApp (loc, CTacRef qid, args) when is_alias env qid -> +| CTacApp ((_, CTacRef qid), args) when is_alias env qid -> let kn = match get_variable env qid with | ArgArg (TacAlias kn) -> kn | ArgVar _ | (ArgArg (TacConstant _)) -> assert false @@ -699,12 +683,12 @@ let rec intern_rec env = function let map arg = (** Thunk alias arguments *) let loc = loc_of_tacexpr arg in - let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Tuple 0), []))] in - CTacFun (loc, var, arg) + let var = [Loc.tag ?loc @@ CPatVar Anonymous, Some (Loc.tag ?loc @@ CTypRef (AbsKn (Tuple 0), []))] in + Loc.tag ?loc @@ CTacFun (var, arg) in let args = List.map map args in - intern_rec env (CTacApp (loc, e, args)) -| CTacApp (loc, f, args) -> + intern_rec env (Loc.tag ?loc @@ CTacApp (e, args)) +| CTacApp (f, args) -> let loc = loc_of_tacexpr f in let (f, ft) = intern_rec env f in let fold arg (args, t) = @@ -713,9 +697,9 @@ let rec intern_rec env = function (arg :: args, (loc, argt) :: t) in let (args, t) = List.fold_right fold args ([], []) in - let ret = unify_arrow ~loc env ft t in + let ret = unify_arrow ?loc env ft t in (GTacApp (f, args), ret) -| CTacLet (loc, is_rec, el, e) -> +| CTacLet (is_rec, el, e) -> let fold accu (pat, _, e) = let ids = ids_of_pattern Id.Set.empty pat in let common = Id.Set.inter ids accu in @@ -723,39 +707,39 @@ let rec intern_rec env = function else let id = Id.Set.choose common in let loc = loc_of_patexpr pat in - user_err ~loc (str "Variable " ++ Id.print id ++ str " is bound several \ + user_err ?loc (str "Variable " ++ Id.print id ++ str " is bound several \ times in this matching") in let ids = List.fold_left fold Id.Set.empty el in if is_rec then intern_let_rec env loc ids el e else intern_let env loc ids el e -| CTacCnv (loc, e, tc) -> +| CTacCnv (e, tc) -> let (e, t) = intern_rec env e in let tc = intern_type env tc in - let () = unify ~loc env t tc in + let () = unify ?loc env t tc in (e, tc) -| CTacSeq (loc, e1, e2) -> +| CTacSeq (e1, e2) -> let loc1 = loc_of_tacexpr e1 in let (e1, t1) = intern_rec env e1 in let (e2, t2) = intern_rec env e2 in let () = check_elt_unit loc1 env t1 in (GTacLet (false, [Anonymous, e1], e2), t2) -| CTacCse (loc, e, pl) -> +| CTacCse (e, pl) -> intern_case env loc e pl -| CTacRec (loc, fs) -> +| CTacRec fs -> intern_record env loc fs -| CTacPrj (loc, e, proj) -> +| CTacPrj (e, proj) -> let pinfo = get_projection proj in let loc = loc_of_tacexpr e in let (e, t) = intern_rec env e in let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in let params = Array.map_to_list (fun i -> GTypVar i) subst in let exp = GTypRef (Other pinfo.pdata_type, params) in - let () = unify ~loc env t exp in + let () = unify ?loc env t exp in let substf i = GTypVar subst.(i) in let ret = subst_type substf pinfo.pdata_ptyp in (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) -| CTacSet (loc, e, proj, r) -> +| CTacSet (e, proj, r) -> let pinfo = get_projection proj in let () = if not pinfo.pdata_mutb then @@ -773,7 +757,7 @@ let rec intern_rec env = function let ret = subst_type substf pinfo.pdata_ptyp in let r = intern_rec_with_constraint env r ret in (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) -| CTacExt (loc, tag, arg) -> +| CTacExt (tag, arg) -> let open Genintern in let self ist e = let env = match Store.get ist.extra ltac2_env with @@ -798,7 +782,7 @@ let rec intern_rec env = function and intern_rec_with_constraint env e exp = let loc = loc_of_tacexpr e in let (e, t) = intern_rec env e in - let () = unify ~loc env t exp in + let () = unify ?loc env t exp in e and intern_let env loc ids el e = @@ -827,11 +811,11 @@ and intern_let env loc ids el e = and intern_let_rec env loc ids el e = let map env (pat, t, e) = - let loc, na = match pat with + let (loc, pat) = pat in + let na = match pat with | CPatVar na -> na | CPatRef _ -> - let loc = loc_of_patexpr pat in - user_err ~loc (str "This kind of pattern is forbidden in let-rec bindings") + user_err ?loc (str "This kind of pattern is forbidden in let-rec bindings") in let id = fresh_id env in let env = push_name na (monomorphic (GTypVar id)) env in @@ -843,7 +827,7 @@ and intern_let_rec env loc ids el e = let (e, t) = intern_rec env e in let () = if not (is_rec_rhs e) then - user_err ~loc:loc_e (str "This kind of expression is not allowed as \ + user_err ?loc:loc_e (str "This kind of expression is not allowed as \ right-hand side of a recursive binding") in let () = unify ?loc env t (GTypVar id) in @@ -881,7 +865,7 @@ and intern_case env loc e pl = (GTacCse (e', Other kn, [||], [||]), GTypVar r) | PKind_variant kn -> let subst, tc = fresh_reftype env kn in - let () = unify ~loc:(loc_of_tacexpr e) env t tc in + let () = unify ?loc:(loc_of_tacexpr e) env t tc in let (nconst, nnonconst, arities) = match kn with | Tuple 0 -> 1, 0, [0] | Tuple n -> 0, 1, [n] @@ -897,9 +881,11 @@ and intern_case env loc e pl = let rec intern_branch = function | [] -> () | (pat, br) :: rem -> - let tbr = match pat with - | CPatVar (loc, Name _) -> todo ?loc () - | CPatVar (_, Anonymous) -> + let tbr = match snd pat with + | CPatVar (Name _) -> + let loc = loc_of_patexpr pat in + todo ?loc () + | CPatVar Anonymous -> let () = check_redundant_clause rem in let (br', brT) = intern_rec env br in (** Fill all remaining branches *) @@ -919,7 +905,8 @@ and intern_case env loc e pl = in let _ = List.fold_left fill (0, 0) arities in brT - | CPatRef (loc, qid, args) -> + | CPatRef (qid, args) -> + let loc = loc_of_patexpr pat in let knc = get_constructor env qid in let kn', index, arity = match knc with | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) @@ -930,11 +917,11 @@ and intern_case env loc e pl = in let () = if not (eq_or_tuple KerName.equal kn kn') then - invalid_pattern ~loc kn kn' + invalid_pattern ?loc kn kn' in - let get_id = function - | CPatVar (_, na) -> na - | p -> todo ~loc:(loc_of_patexpr p) () + let get_id pat = match pat with + | _, CPatVar na -> na + | loc, _ -> todo ?loc () in let ids = List.map get_id args in let nids = List.length ids in @@ -942,7 +929,7 @@ and intern_case env loc e pl = let () = match knc with | Tuple n -> assert (n == nids) | Other knc -> - if not (Int.equal nids nargs) then error_nargs_mismatch loc knc nargs nids + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids in let fold env id tpe = (** Instantiate all arguments *) @@ -955,15 +942,15 @@ and intern_case env loc e pl = let () = if List.is_empty args then if Option.is_empty const.(index) then const.(index) <- Some br' - else warn_redundant_clause ~loc () + else warn_redundant_clause ?loc () else let ids = Array.of_list ids in if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') - else warn_redundant_clause ~loc () + else warn_redundant_clause ?loc () in brT in - let () = unify ~loc:(loc_of_tacexpr br) env tbr ret in + let () = unify ?loc:(loc_of_tacexpr br) env tbr ret in intern_branch rem in let () = intern_branch pl in @@ -971,7 +958,7 @@ and intern_case env loc e pl = | None -> let kn = match kn with Other kn -> kn | _ -> assert false in let cstr = pr_internal_constructor kn n is_const in - user_err ~loc (str "Unhandled match case for constructor " ++ cstr) + user_err ?loc (str "Unhandled match case for constructor " ++ cstr) | Some x -> x in let const = Array.mapi (fun i o -> map i true o) const in @@ -980,11 +967,11 @@ and intern_case env loc e pl = (ce, ret) | PKind_open kn -> let subst, tc = fresh_reftype env (Other kn) in - let () = unify ~loc:(loc_of_tacexpr e) env t tc in + let () = unify ?loc:(loc_of_tacexpr e) env t tc in let ret = GTypVar (fresh_id env) in let rec intern_branch map = function | [] -> - user_err ~loc (str "Missing default case") + user_err ?loc (str "Missing default case") | (pat, br) :: rem -> match intern_patexpr env pat with | GPatVar na -> @@ -997,23 +984,23 @@ and intern_case env loc e pl = let get = function | GPatVar na -> na | GPatRef _ -> - user_err ~loc (str "TODO: Unhandled match case") (** FIXME *) + user_err ?loc (str "TODO: Unhandled match case") (** FIXME *) in let loc = loc_of_patexpr pat in let knc = match knc with | Other knc -> knc - | Tuple n -> invalid_pattern ~loc (Other kn) (Tuple n) + | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) in let ids = List.map get args in let data = Tac2env.interp_constructor knc in let () = if not (KerName.equal kn data.cdata_type) then - invalid_pattern ~loc (Other kn) (Other data.cdata_type) + invalid_pattern ?loc (Other kn) (Other data.cdata_type) in let nids = List.length ids in let nargs = List.length data.cdata_args in let () = - if not (Int.equal nids nargs) then error_nargs_mismatch loc knc nargs nids + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids in let fold env id tpe = (** Instantiate all arguments *) @@ -1025,7 +1012,7 @@ and intern_case env loc e pl = let br' = intern_rec_with_constraint nenv br ret in let map = if KNmap.mem knc map then - let () = warn_redundant_clause ~loc () in + let () = warn_redundant_clause ?loc () in map else KNmap.add knc (Anonymous, Array.of_list ids, br') map @@ -1053,7 +1040,7 @@ and intern_constructor env loc kn args = match kn with | None -> (GTacOpn (kn, args), ans) else - error_nargs_mismatch loc kn nargs (List.length args) + error_nargs_mismatch ?loc kn nargs (List.length args) | Tuple n -> assert (Int.equal n (List.length args)); let types = List.init n (fun i -> GTypVar (fresh_id env)) in @@ -1073,7 +1060,7 @@ and intern_record env loc fs = in let fs = List.map map fs in let kn = match fs with - | [] -> user_err ~loc (str "Cannot infer the corresponding record type") + | [] -> user_err ?loc (str "Cannot infer the corresponding record type") | (_, proj, _) :: _ -> proj.pdata_type in let params, typdef = match Tac2env.interp_type kn with @@ -1104,7 +1091,7 @@ and intern_record env loc fs = | None -> () | Some i -> let (field, _, _) = List.nth typdef i in - user_err ~loc (str "Field " ++ Id.print field ++ str " is undefined") + user_err ?loc (str "Field " ++ Id.print field ++ str " is undefined") in let args = Array.map_to_list Option.get args in let tparam = List.init params (fun i -> GTypVar subst.(i)) in @@ -1204,18 +1191,18 @@ let get_projection0 var = match var with kn | AbsKn kn -> kn -let rec globalize ids e = match e with +let rec globalize ids (loc, er as e) = match er with | CTacAtm _ -> e | CTacRef ref -> let mem id = Id.Set.mem id ids in begin match get_variable0 mem ref with | ArgVar _ -> e - | ArgArg kn -> CTacRef (AbsKn kn) + | ArgArg kn -> Loc.tag ?loc @@ CTacRef (AbsKn kn) end -| CTacCst (loc, qid) -> +| CTacCst qid -> let knc = get_constructor () qid in - CTacCst (loc, AbsKn knc) -| CTacFun (loc, bnd, e) -> + Loc.tag ?loc @@ CTacCst (AbsKn knc) +| CTacFun (bnd, e) -> let fold (pats, accu) (pat, t) = let accu = ids_of_pattern accu pat in let pat = globalize_pattern ids pat in @@ -1224,12 +1211,12 @@ let rec globalize ids e = match e with let bnd, ids = List.fold_left fold ([], ids) bnd in let bnd = List.rev bnd in let e = globalize ids e in - CTacFun (loc, bnd, e) -| CTacApp (loc, e, el) -> + Loc.tag ?loc @@ CTacFun (bnd, e) +| CTacApp (e, el) -> let e = globalize ids e in let el = List.map (fun e -> globalize ids e) el in - CTacApp (loc, e, el) -| CTacLet (loc, isrec, bnd, e) -> + Loc.tag ?loc @@ CTacApp (e, el) +| CTacLet (isrec, bnd, e) -> let fold accu (pat, _, _) = ids_of_pattern accu pat in let ext = List.fold_left fold Id.Set.empty bnd in let eids = Id.Set.union ext ids in @@ -1239,48 +1226,48 @@ let rec globalize ids e = match e with (qid, t, globalize ids e) in let bnd = List.map map bnd in - CTacLet (loc, isrec, bnd, e) -| CTacCnv (loc, e, t) -> + Loc.tag ?loc @@ CTacLet (isrec, bnd, e) +| CTacCnv (e, t) -> let e = globalize ids e in - CTacCnv (loc, e, t) -| CTacSeq (loc, e1, e2) -> + Loc.tag ?loc @@ CTacCnv (e, t) +| CTacSeq (e1, e2) -> let e1 = globalize ids e1 in let e2 = globalize ids e2 in - CTacSeq (loc, e1, e2) -| CTacCse (loc, e, bl) -> + Loc.tag ?loc @@ CTacSeq (e1, e2) +| CTacCse (e, bl) -> let e = globalize ids e in let bl = List.map (fun b -> globalize_case ids b) bl in - CTacCse (loc, e, bl) -| CTacRec (loc, r) -> + Loc.tag ?loc @@ CTacCse (e, bl) +| CTacRec r -> let map (p, e) = let p = get_projection0 p in let e = globalize ids e in (AbsKn p, e) in - CTacRec (loc, List.map map r) -| CTacPrj (loc, e, p) -> + Loc.tag ?loc @@ CTacRec (List.map map r) +| CTacPrj (e, p) -> let e = globalize ids e in let p = get_projection0 p in - CTacPrj (loc, e, AbsKn p) -| CTacSet (loc, e, p, e') -> + Loc.tag ?loc @@ CTacPrj (e, AbsKn p) +| CTacSet (e, p, e') -> let e = globalize ids e in let p = get_projection0 p in let e' = globalize ids e' in - CTacSet (loc, e, AbsKn p, e') -| CTacExt (loc, tag, arg) -> + Loc.tag ?loc @@ CTacSet (e, AbsKn p, e') +| CTacExt (tag, arg) -> let arg = str (Tac2dyn.Arg.repr tag) in - CErrors.user_err ~loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) + CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) and globalize_case ids (p, e) = (globalize_pattern ids p, globalize ids e) -and globalize_pattern ids p = match p with +and globalize_pattern ids (loc, pr as p) = match pr with | CPatVar _ -> p -| CPatRef (loc, cst, pl) -> +| CPatRef (cst, pl) -> let knc = get_constructor () cst in let cst = AbsKn knc in let pl = List.map (fun p -> globalize_pattern ids p) pl in - CPatRef (loc, cst, pl) + Loc.tag ?loc @@ CPatRef (cst, pl) (** Kernel substitution *) @@ -1387,16 +1374,16 @@ let subst_or_relid subst ref = match ref with let kn' = subst_or_tuple subst_kn subst kn in if kn' == kn then ref else AbsKn kn' -let rec subst_rawtype subst t = match t with +let rec subst_rawtype subst (loc, tr as t) = match tr with | CTypVar _ -> t -| CTypArrow (loc, t1, t2) -> +| CTypArrow (t1, t2) -> let t1' = subst_rawtype subst t1 in let t2' = subst_rawtype subst t2 in - if t1' == t1 && t2' == t2 then t else CTypArrow (loc, t1', t2') -| CTypRef (loc, ref, tl) -> + if t1' == t1 && t2' == t2 then t else Loc.tag ?loc @@ CTypArrow (t1', t2') +| CTypRef (ref, tl) -> let ref' = subst_or_relid subst ref in let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in - if ref' == ref && tl' == tl then t else CTypRef (loc, ref', tl') + if ref' == ref && tl' == tl then t else Loc.tag ?loc @@ CTypRef (ref', tl') let subst_tacref subst ref = match ref with | RelId _ -> ref @@ -1413,35 +1400,35 @@ let subst_projection subst prj = match prj with let kn' = subst_kn subst kn in if kn' == kn then prj else AbsKn kn' -let rec subst_rawpattern subst p = match p with +let rec subst_rawpattern subst (loc, pr as p) = match pr with | CPatVar _ -> p -| CPatRef (loc, c, pl) -> +| CPatRef (c, pl) -> let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in let c' = subst_or_relid subst c in - if pl' == pl && c' == c then p else CPatRef (loc, c', pl') + if pl' == pl && c' == c then p else Loc.tag ?loc @@ CPatRef (c', pl') (** Used for notations *) -let rec subst_rawexpr subst t = match t with +let rec subst_rawexpr subst (loc, tr as t) = match tr with | CTacAtm _ -> t | CTacRef ref -> let ref' = subst_tacref subst ref in - if ref' == ref then t else CTacRef ref' -| CTacCst (loc, ref) -> + if ref' == ref then t else Loc.tag ?loc @@ CTacRef ref' +| CTacCst ref -> let ref' = subst_or_relid subst ref in - if ref' == ref then t else CTacCst (loc, ref') -| CTacFun (loc, bnd, e) -> + if ref' == ref then t else Loc.tag ?loc @@ CTacCst ref' +| CTacFun (bnd, e) -> let map (na, t as p) = let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in if t' == t then p else (na, t') in let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CTacFun (loc, bnd', e') -| CTacApp (loc, e, el) -> + if bnd' == bnd && e' == e then t else Loc.tag ?loc @@ CTacFun (bnd', e') +| CTacApp (e, el) -> let e' = subst_rawexpr subst e in let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if e' == e && el' == el then t else CTacApp (loc, e', el') -| CTacLet (loc, isrec, bnd, e) -> + if e' == e && el' == el then t else Loc.tag ?loc @@ CTacApp (e', el') +| CTacLet (isrec, bnd, e) -> let map (na, t, e as p) = let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in let e' = subst_rawexpr subst e in @@ -1449,16 +1436,16 @@ let rec subst_rawexpr subst t = match t with in let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CTacLet (loc, isrec, bnd', e') -| CTacCnv (loc, e, c) -> + if bnd' == bnd && e' == e then t else Loc.tag ?loc @@ CTacLet (isrec, bnd', e') +| CTacCnv (e, c) -> let e' = subst_rawexpr subst e in let c' = subst_rawtype subst c in - if c' == c && e' == e then t else CTacCnv (loc, e', c') -| CTacSeq (loc, e1, e2) -> + if c' == c && e' == e then t else Loc.tag ?loc @@ CTacCnv (e', c') +| CTacSeq (e1, e2) -> let e1' = subst_rawexpr subst e1 in let e2' = subst_rawexpr subst e2 in - if e1' == e1 && e2' == e2 then t else CTacSeq (loc, e1', e2') -| CTacCse (loc, e, bl) -> + if e1' == e1 && e2' == e2 then t else Loc.tag ?loc @@ CTacSeq (e1', e2') +| CTacCse (e, bl) -> let map (p, e as x) = let p' = subst_rawpattern subst p in let e' = subst_rawexpr subst e in @@ -1466,25 +1453,25 @@ let rec subst_rawexpr subst t = match t with in let e' = subst_rawexpr subst e in let bl' = List.smartmap map bl in - if e' == e && bl' == bl then t else CTacCse (loc, e', bl') -| CTacRec (loc, el) -> + if e' == e && bl' == bl then t else Loc.tag ?loc @@ CTacCse (e', bl') +| CTacRec el -> let map (prj, e as p) = let prj' = subst_projection subst prj in let e' = subst_rawexpr subst e in if prj' == prj && e' == e then p else (prj', e') in let el' = List.smartmap map el in - if el' == el then t else CTacRec (loc, el') -| CTacPrj (loc, e, prj) -> + if el' == el then t else Loc.tag ?loc @@ CTacRec el' +| CTacPrj (e, prj) -> let prj' = subst_projection subst prj in let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then t else CTacPrj (loc, e', prj') -| CTacSet (loc, e, prj, r) -> + if prj' == prj && e' == e then t else Loc.tag ?loc @@ CTacPrj (e', prj') +| CTacSet (e, prj, r) -> let prj' = subst_projection subst prj in let e' = subst_rawexpr subst e in let r' = subst_rawexpr subst r in - if prj' == prj && e' == e && r' == r then t else CTacSet (loc, e', prj', r') -| CTacExt _ -> assert false (** Should not be generated by gloabalization *) + if prj' == prj && e' == e && r' == r then t else Loc.tag ?loc @@ CTacSet (e', prj', r') +| CTacExt _ -> assert false (** Should not be generated by globalization *) (** Registering *) diff --git a/src/tac2intern.mli b/src/tac2intern.mli index 95199d449d..045e657460 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -10,8 +10,8 @@ open Names open Mod_subst open Tac2expr -val loc_of_tacexpr : raw_tacexpr -> Loc.t -val loc_of_patexpr : raw_patexpr -> Loc.t +val loc_of_tacexpr : raw_tacexpr -> Loc.t option +val loc_of_patexpr : raw_patexpr -> Loc.t option val intern : raw_tacexpr -> glb_tacexpr * type_scheme val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef @@ -41,8 +41,8 @@ val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr (** Errors *) -val error_nargs_mismatch : Loc.t -> ltac_constructor -> int -> int -> 'a -val error_nparams_mismatch : Loc.t -> int -> int -> 'a +val error_nargs_mismatch : ?loc:Loc.t -> ltac_constructor -> int -> int -> 'a +val error_nparams_mismatch : ?loc:Loc.t -> int -> int -> 'a (** Misc *) diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 279ab53b67..063a52c738 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -25,10 +25,9 @@ let control_core n = kername control_prefix n let dummy_loc = Loc.make_loc (-1, -1) let constructor ?loc kn args = - let loc = Option.default dummy_loc loc in - let cst = CTacCst (loc, AbsKn (Other kn)) in + let cst = Loc.tag ?loc @@ CTacCst (AbsKn (Other kn)) in if List.is_empty args then cst - else CTacApp (loc, cst, args) + else Loc.tag ?loc @@ CTacApp (cst, args) let std_constructor ?loc name args = constructor ?loc (std_core name) args @@ -39,39 +38,35 @@ let std_proj ?loc name = let thunk e = let t_unit = coq_core "unit" in let loc = Tac2intern.loc_of_tacexpr e in - let var = [CPatVar (Some loc, Anonymous), Some (CTypRef (loc, AbsKn (Other t_unit), []))] in - CTacFun (loc, var, e) + let var = [Loc.tag ?loc @@ CPatVar (Anonymous), Some (Loc.tag ?loc @@ CTypRef (AbsKn (Other t_unit), []))] in + Loc.tag ?loc @@ CTacFun (var, e) let of_pair f g (loc, (e1, e2)) = - let loc = Option.default dummy_loc loc in - CTacApp (loc, CTacCst (loc, AbsKn (Tuple 2)), [f e1; g e2]) + Loc.tag ?loc @@ CTacApp (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 2)), [f e1; g e2]) let of_tuple ?loc el = match el with | [] -> - let loc = Option.default dummy_loc loc in - CTacCst (loc, AbsKn (Tuple 0)) + Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 0)) | [e] -> e | el -> - let loc = Option.default dummy_loc loc in let len = List.length el in - CTacApp (loc, CTacCst (loc, AbsKn (Tuple len)), el) + Loc.tag ?loc @@ CTacApp (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple len)), el) let of_int (loc, n) = - CTacAtm (Loc.tag ?loc (AtmInt n)) + Loc.tag ?loc @@ CTacAtm (AtmInt n) let of_option ?loc f opt = match opt with | None -> constructor ?loc (coq_core "None") [] | Some e -> constructor ?loc (coq_core "Some") [f e] let inj_wit ?loc wit x = - let loc = Option.default dummy_loc loc in - CTacExt (loc, wit, x) + Loc.tag ?loc @@ CTacExt (wit, x) let of_variable (loc, id) = let qid = Libnames.qualid_of_ident id in if Tac2env.is_constructor qid then CErrors.user_err ?loc (str "Invalid identifier") - else CTacRef (RelId (Loc.tag ?loc qid)) + else Loc.tag ?loc @@ CTacRef (RelId (Loc.tag ?loc qid)) let of_anti f = function | QExpr x -> f x @@ -171,10 +166,9 @@ let of_hyp_location ?loc ((occs, id), flag) = ] let of_clause (loc, cl) = - let loc = Option.default dummy_loc loc in - let hyps = of_option ~loc (fun l -> of_list ~loc of_hyp_location l) cl.q_onhyps in + let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in let concl = of_occurrences cl.q_concl_occs in - CTacRec (loc, [ + Loc.tag ?loc @@ CTacRec ([ std_proj "on_hyps", hyps; std_proj "on_concl", concl; ]) @@ -191,8 +185,7 @@ let of_induction_clause (loc, cl) = let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in let in_ = of_option ?loc of_clause cl.indcl_in in - let loc = Option.default dummy_loc loc in - CTacRec (loc, [ + Loc.tag ?loc @@ CTacRec ([ std_proj "indcl_arg", arg; std_proj "indcl_eqn", eqn; std_proj "indcl_as", as_; @@ -216,36 +209,32 @@ let of_rewriting (loc, rew) = in let repeat = of_repeat rew.rew_repeat in let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in - let loc = Option.default dummy_loc loc in - CTacRec (loc, [ + Loc.tag ?loc @@ CTacRec ([ std_proj "rew_orient", orient; std_proj "rew_repeat", repeat; std_proj "rew_equatn", equatn; ]) let of_hyp ?loc id = - let loc = Option.default dummy_loc loc in - let hyp = CTacRef (AbsKn (TacConstant (control_core "hyp"))) in - CTacApp (loc, hyp, [of_ident id]) + let hyp = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant (control_core "hyp"))) in + Loc.tag ?loc @@ CTacApp (hyp, [of_ident id]) let of_exact_hyp ?loc id = - let loc = Option.default dummy_loc loc in - let refine = CTacRef (AbsKn (TacConstant (control_core "refine"))) in - CTacApp (loc, refine, [thunk (of_hyp ~loc id)]) + let refine = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant (control_core "refine"))) in + Loc.tag ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) let of_exact_var ?loc id = - let loc = Option.default dummy_loc loc in - let refine = CTacRef (AbsKn (TacConstant (control_core "refine"))) in - CTacApp (loc, refine, [thunk (of_variable id)]) + let refine = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant (control_core "refine"))) in + Loc.tag ?loc @@ CTacApp (refine, [thunk (of_variable id)]) let of_dispatch tacs = - let loc = Option.default dummy_loc (fst tacs) in + let (loc, _) = tacs in let default = function | Some e -> thunk e - | None -> thunk (CTacCst (loc, AbsKn (Tuple 0))) + | None -> thunk (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 0))) in - let map e = of_pair default (fun l -> of_list ~loc default l) (Loc.tag ~loc e) in - of_pair (fun l -> of_list ~loc default l) (fun r -> of_option ~loc map r) tacs + let map e = of_pair default (fun l -> of_list ?loc default l) (Loc.tag ?loc e) in + of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs let make_red_flag l = let open Genredexpr in @@ -287,14 +276,13 @@ let of_reference r = let of_strategy_flag (loc, flag) = let open Genredexpr in - let loc = Option.default dummy_loc loc in let flag = make_red_flag flag in - CTacRec (loc, [ - std_proj "rBeta", of_bool ~loc flag.rBeta; - std_proj "rMatch", of_bool ~loc flag.rMatch; - std_proj "rFix", of_bool ~loc flag.rFix; - std_proj "rCofix", of_bool ~loc flag.rCofix; - std_proj "rZeta", of_bool ~loc flag.rZeta; - std_proj "rDelta", of_bool ~loc flag.rDelta; - std_proj "rConst", of_list ~loc of_reference flag.rConst; + Loc.tag ?loc @@ CTacRec ([ + std_proj "rBeta", of_bool ?loc flag.rBeta; + std_proj "rMatch", of_bool ?loc flag.rMatch; + std_proj "rFix", of_bool ?loc flag.rFix; + std_proj "rCofix", of_bool ?loc flag.rCofix; + std_proj "rZeta", of_bool ?loc flag.rZeta; + std_proj "rDelta", of_bool ?loc flag.rDelta; + std_proj "rConst", of_list ?loc of_reference flag.rConst; ]) -- cgit v1.2.3 From a2302a48a96a6b635f5301f7cc6254acb58211bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 19:39:47 +0200 Subject: Moving generic arguments to Tac2quote. --- src/g_ltac2.ml4 | 8 ++++---- src/tac2core.ml | 18 +++++++++--------- src/tac2env.ml | 7 ------- src/tac2env.mli | 15 --------------- src/tac2quote.ml | 18 ++++++++++++++---- src/tac2quote.mli | 18 ++++++++++++++++++ 6 files changed, 45 insertions(+), 39 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 338711e79c..fce4c9e159 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -87,10 +87,10 @@ let tac2mode = Gram.entry_create "vernac:ltac2_command" let ltac1_expr = (Obj.magic Pltac.tactic_expr : Tacexpr.raw_tactic_expr Gram.entry) let inj_wit wit loc x = Loc.tag ~loc @@ CTacExt (wit, x) -let inj_open_constr loc c = inj_wit Tac2env.wit_open_constr loc c -let inj_pattern loc c = inj_wit Tac2env.wit_pattern loc c -let inj_reference loc c = inj_wit Tac2env.wit_reference loc c -let inj_ltac1 loc e = inj_wit Tac2env.wit_ltac1 loc e +let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c +let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c +let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c +let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e let pattern_of_qualid ?loc id = if Tac2env.is_constructor (snd id) then Loc.tag ?loc @@ CPatRef (RelId id, []) diff --git a/src/tac2core.ml b/src/tac2core.ml index db8f989768..f5dd74d642 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -803,7 +803,7 @@ let () = ml_interp = interp; ml_print = print; } in - define_ml_object Tac2env.wit_constr obj + define_ml_object Tac2quote.wit_constr obj let () = let intern = intern_constr in @@ -815,7 +815,7 @@ let () = ml_interp = interp; ml_print = print; } in - define_ml_object Tac2env.wit_open_constr obj + define_ml_object Tac2quote.wit_open_constr obj let () = let interp _ id = return (ValExt (Value.val_ident, id)) in @@ -826,7 +826,7 @@ let () = ml_subst = (fun _ id -> id); ml_print = print; } in - define_ml_object Tac2env.wit_ident obj + define_ml_object Tac2quote.wit_ident obj let () = let intern self ist c = @@ -841,7 +841,7 @@ let () = ml_subst = Patternops.subst_pattern; ml_print = print; } in - define_ml_object Tac2env.wit_pattern obj + define_ml_object Tac2quote.wit_pattern obj let () = let intern self ist qid = match qid with @@ -867,7 +867,7 @@ let () = ml_interp = interp; ml_print = print; } in - define_ml_object Tac2env.wit_reference obj + define_ml_object Tac2quote.wit_reference obj let () = let intern self ist tac = @@ -892,7 +892,7 @@ let () = ml_interp = interp; ml_print = print; } in - define_ml_object Tac2env.wit_ltac1 obj + define_ml_object Tac2quote.wit_ltac1 obj (** Ltac2 in terms *) @@ -1070,9 +1070,9 @@ let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference -let () = add_generic_scope "constr" Pcoq.Constr.constr wit_constr -let () = add_generic_scope "open_constr" Pcoq.Constr.constr wit_open_constr -let () = add_generic_scope "pattern" Pcoq.Constr.constr wit_pattern +let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr +let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr +let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern (** seq scope, a bit hairy *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 5a817df713..9aaaae0465 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -295,13 +295,6 @@ let std_prefix = let wit_ltac2 = Genarg.make0 "ltac2:value" -let wit_pattern = Arg.create "pattern" -let wit_reference = Arg.create "reference" -let wit_ident = Arg.create "ident" -let wit_constr = Arg.create "constr" -let wit_open_constr = Arg.create "open_constr" -let wit_ltac1 = Arg.create "ltac1" - let is_constructor qid = let (_, id) = repr_qualid qid in let id = Id.to_string id in diff --git a/src/tac2env.mli b/src/tac2env.mli index eb18dc8e39..e40958e1a0 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -133,21 +133,6 @@ val std_prefix : ModPath.t val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type -val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag - -val wit_ident : (Id.t, Id.t) Arg.tag - -val wit_reference : (reference, Globnames.global_reference) Arg.tag -(** Beware, at the raw level, [Qualid [id]] has not the same meaning as - [Ident id]. The first is an unqualified global reference, the second is - the dynamic reference to id. *) - -val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag - -val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag - -val wit_ltac1 : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr) Arg.tag - (** {5 Helper functions} *) val is_constructor : qualid -> bool diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 063a52c738..132716c37e 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -9,9 +9,19 @@ open Pp open Names open Util +open Tac2dyn open Tac2expr open Tac2qexpr +(** Generic arguments *) + +let wit_pattern = Arg.create "pattern" +let wit_reference = Arg.create "reference" +let wit_ident = Arg.create "ident" +let wit_constr = Arg.create "constr" +let wit_open_constr = Arg.create "open_constr" +let wit_ltac1 = Arg.create "ltac1" + (** Syntactic quoting of expressions. *) let control_prefix = @@ -72,15 +82,15 @@ let of_anti f = function | QExpr x -> f x | QAnti id -> of_variable id -let of_ident (loc, id) = inj_wit ?loc Tac2env.wit_ident id +let of_ident (loc, id) = inj_wit ?loc wit_ident id let of_constr c = let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc Tac2env.wit_constr c + inj_wit ?loc wit_constr c let of_open_constr c = let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc Tac2env.wit_open_constr c + inj_wit ?loc wit_open_constr c let of_bool ?loc b = let c = if b then coq_core "true" else coq_core "false" in @@ -270,7 +280,7 @@ let make_red_flag l = let of_reference r = let of_ref ref = let loc = Libnames.loc_of_reference ref in - inj_wit ?loc Tac2env.wit_reference ref + inj_wit ?loc wit_reference ref in of_anti of_ref r diff --git a/src/tac2quote.mli b/src/tac2quote.mli index b2687f01a3..440759ada7 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -8,6 +8,7 @@ open Loc open Names +open Tac2dyn open Tac2qexpr open Tac2expr @@ -64,3 +65,20 @@ val of_exact_var : ?loc:Loc.t -> Id.t located -> raw_tacexpr val of_dispatch : dispatch -> raw_tacexpr val of_strategy_flag : strategy_flag -> raw_tacexpr + +(** {5 Generic arguments} *) + +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag + +val wit_ident : (Id.t, Id.t) Arg.tag + +val wit_reference : (Libnames.reference, Globnames.global_reference) Arg.tag +(** Beware, at the raw level, [Qualid [id]] has not the same meaning as + [Ident id]. The first is an unqualified global reference, the second is + the dynamic reference to id. *) + +val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_ltac1 : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr) Arg.tag -- cgit v1.2.3 From 65daf8fca747d385b2985e4e5e91894738f6fcf1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 19:45:23 +0200 Subject: Introducing a macro for constr matching. --- src/g_ltac2.ml4 | 21 ++++++++++++++- src/tac2core.ml | 2 ++ src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 8 ++++++ src/tac2quote.ml | 74 +++++++++++++++++++++++++++++++++++++++++++++++++---- src/tac2quote.mli | 3 +++ theories/Pattern.v | 5 ++++ 8 files changed, 109 insertions(+), 6 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index fce4c9e159..5d5bc6b941 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -368,7 +368,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_reference q_with_bindings; + q_reference q_with_bindings q_constr_matching; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -661,6 +661,25 @@ GEXTEND Gram q_strategy_flag: [ [ flag = strategy_flag -> flag ] ] ; + match_pattern: + [ [ IDENT "context"; id = OPT Prim.ident; + "["; pat = Constr.lconstr_pattern; "]" -> (Some id, pat) + | pat = Constr.lconstr_pattern -> (None, pat) ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; tac = tac2expr -> + match mp with + | None, pat -> Loc.tag ~loc:!@loc @@ QConstrMatchPattern (pat, tac) + | Some oid, pat -> Loc.tag ~loc:!@loc @@ QConstrMatchContext (oid, pat, tac) + ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl ] ] + ; + q_constr_matching: + [ [ m = match_list -> m ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index f5dd74d642..39fcff0c73 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -7,6 +7,7 @@ (************************************************************************) open CSig +open Util open Pp open Names open Genarg @@ -1069,6 +1070,7 @@ let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference +let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 9c5d9a659b..34022b86c9 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -36,6 +36,7 @@ let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" let q_reference = Pcoq.Gram.entry_create "tactic:q_reference" let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" +let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 7ed45e62e5..dde877666a 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -71,6 +71,7 @@ val q_dispatch : dispatch Pcoq.Gram.entry val q_occurrences : occurrences Pcoq.Gram.entry val q_reference : Libnames.reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry +val q_constr_matching : constr_matching Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 7c774a5c80..a284c1e756 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -115,3 +115,11 @@ type red_flag_r = type red_flag = red_flag_r located type strategy_flag = red_flag list located + +type constr_match_branch_r = +| QConstrMatchPattern of Constrexpr.constr_expr * raw_tacexpr +| QConstrMatchContext of Id.t option * Constrexpr.constr_expr * raw_tacexpr + +type constr_match_branch = constr_match_branch_r located + +type constr_matching = constr_match_branch list located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 132716c37e..d38d7414fe 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -24,13 +24,21 @@ let wit_ltac1 = Arg.create "ltac1" (** Syntactic quoting of expressions. *) -let control_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Control"; "Ltac2"])) +let prefix_gen n = + MPfile (DirPath.make (List.map Id.of_string [n; "Ltac2"])) + +let control_prefix = prefix_gen "Control" +let pattern_prefix = prefix_gen "Pattern" +let array_prefix = prefix_gen "Array" let kername prefix n = KerName.make2 prefix (Label.of_id (Id.of_string_soft n)) let std_core n = kername Tac2env.std_prefix n let coq_core n = kername Tac2env.coq_prefix n let control_core n = kername control_prefix n +let pattern_core n = kername pattern_prefix n + +let global_ref ?loc kn = + Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant kn)) let dummy_loc = Loc.make_loc (-1, -1) @@ -226,15 +234,15 @@ let of_rewriting (loc, rew) = ]) let of_hyp ?loc id = - let hyp = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant (control_core "hyp"))) in + let hyp = global_ref ?loc (control_core "hyp") in Loc.tag ?loc @@ CTacApp (hyp, [of_ident id]) let of_exact_hyp ?loc id = - let refine = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant (control_core "refine"))) in + let refine = global_ref ?loc (control_core "refine") in Loc.tag ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) let of_exact_var ?loc id = - let refine = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant (control_core "refine"))) in + let refine = global_ref ?loc (control_core "refine") in Loc.tag ?loc @@ CTacApp (refine, [thunk (of_variable id)]) let of_dispatch tacs = @@ -296,3 +304,59 @@ let of_strategy_flag (loc, flag) = std_proj "rDelta", of_bool ?loc flag.rDelta; std_proj "rConst", of_list ?loc of_reference flag.rConst; ]) + +let pattern_vars pat = + let rec aux () accu pat = match pat.CAst.v with + | Constrexpr.CPatVar id -> Id.Set.add id accu + | Constrexpr.CEvar (id, []) -> Id.Set.add id accu + | _ -> + Topconstr.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat + in + aux () Id.Set.empty pat + +let of_constr_matching (loc, m) = + let check_id loc id = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) + in + let abstract_vars loc pat tac = + let vars = pattern_vars pat in + let na, tac = + if Id.Set.is_empty vars then (Anonymous, tac) + else + (** Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) + let id0 = Id.Set.choose vars in + let build_bindings id (n, accu) = + let () = check_id loc id in + let get = global_ref ?loc (kername array_prefix "get") in + let args = [of_variable (loc, id0); of_int (loc, n)] in + let e = Loc.tag ?loc @@ CTacApp (get, args) in + let accu = (Loc.tag ?loc @@ CPatVar (Name id), None, e) :: accu in + (n + 1, accu) + in + let (_, bnd) = Id.Set.fold build_bindings vars (0, []) in + let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in + (Name id0, tac) + in + Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], tac) + in + let map (loc, p) = match p with + | QConstrMatchPattern (pat, tac) -> + let e = abstract_vars loc pat tac in + let pat = inj_wit ?loc wit_pattern pat in + constructor ?loc (pattern_core "ConstrMatchPattern") [pat; e] + | QConstrMatchContext (id, pat, tac) -> + let e = abstract_vars loc pat tac in + let na = match id with + | None -> Anonymous + | Some id -> + let () = check_id loc id in + Name id + in + let e = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], e) in + let pat = inj_wit ?loc wit_pattern pat in + constructor ?loc (pattern_core "ConstrMatchContext") [pat; e] + in + of_list ?loc map m diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 440759ada7..c3374ac24e 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Loc open Names open Tac2dyn @@ -66,6 +67,8 @@ val of_dispatch : dispatch -> raw_tacexpr val of_strategy_flag : strategy_flag -> raw_tacexpr +val of_constr_matching : constr_matching -> raw_tacexpr + (** {5 Generic arguments} *) val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag diff --git a/theories/Pattern.v b/theories/Pattern.v index c2ba4162e8..ab3135f189 100644 --- a/theories/Pattern.v +++ b/theories/Pattern.v @@ -12,6 +12,11 @@ Ltac2 Type t := pattern. Ltac2 Type context. +Ltac2 Type 'a constr_match := [ +| ConstrMatchPattern (pattern, constr array -> 'a) +| ConstrMatchContext (pattern, constr -> constr array -> 'a) +]. + Ltac2 @ external matches : t -> constr -> (ident * constr) list := "ltac2" "pattern_matches". (** If the term matches the pattern, returns the bound variables. If it doesn't, -- cgit v1.2.3 From 34912844e18ef84d88af87e1dca05ab0426871c9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 00:02:06 +0200 Subject: Proper anomalies for missing registered primitives. --- src/tac2intern.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index c1fd281808..1dba57c4c1 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -651,10 +651,18 @@ let rec intern_rec env (loc, e) = match e with let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) | ArgArg (TacConstant kn) -> - let { Tac2env.gdata_type = sch }, _ = Tac2env.interp_global kn in + let { Tac2env.gdata_type = sch }, _ = + try Tac2env.interp_global kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) + in (GTacRef kn, fresh_type_scheme env sch) | ArgArg (TacAlias kn) -> - let e = Tac2env.interp_alias kn in + let e = + try Tac2env.interp_alias kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) + in intern_rec env e end | CTacCst qid -> -- cgit v1.2.3 From 102cfe76bc42d3139c79eca59eb782fcf644317b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 3 Sep 2017 23:52:12 +0200 Subject: Implementing lazy matching over terms. --- src/tac2core.ml | 36 ++++++++++++++++++++++++++++++++++++ tests/matching.v | 17 +++++++++++++++++ theories/Notations.v | 31 ++++++++++++++++++++++++++++++- theories/Pattern.v | 10 +++++++++- 4 files changed, 92 insertions(+), 2 deletions(-) create mode 100644 tests/matching.v diff --git a/src/tac2core.ml b/src/tac2core.ml index 39fcff0c73..bbf95c7056 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -544,6 +544,42 @@ let () = define2 "pattern_matches_subterm" begin fun pat c -> end end +let () = define2 "pattern_matches_vect" begin fun pat c -> + let pat = Value.to_pattern pat in + let c = Value.to_constr c in + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> Proofview.tclZERO err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let ans = Array.map_of_list snd ans in + return (Value.of_array Value.of_constr ans) + end + end +end + +let () = define2 "pattern_matches_subterm_vect" begin fun pat c -> + let pat = Value.to_pattern pat in + let c = Value.to_constr c in + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let ans = Array.map_of_list snd ans in + let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_array Value.of_constr ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_appsubterm env sigma pat c in + of_ans ans + end +end + let () = define2 "pattern_instantiate" begin fun ctx c -> let ctx = EConstr.Unsafe.to_constr (Value.to_constr ctx) in let c = EConstr.Unsafe.to_constr (Value.to_constr c) in diff --git a/tests/matching.v b/tests/matching.v new file mode 100644 index 0000000000..d21c505cdf --- /dev/null +++ b/tests/matching.v @@ -0,0 +1,17 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Goal True -> False. +Proof. +Fail +let b := { contents := true } in +let f c := + match b.(contents) with + | true => Message.print (Message.of_constr c); b.(contents) := false; fail + | false => () + end +in +(** This fails because the matching is not allowed to backtrack once + it commits to a branch*) +lazy_match! '(nat -> bool) with context [?a] => f a end. +lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. +Abort. diff --git a/theories/Notations.v b/theories/Notations.v index 411367eab1..93c9dd1798 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -7,7 +7,36 @@ (************************************************************************) Require Import Ltac2.Init. -Require Ltac2.Control Ltac2.Int Ltac2.Std. +Require Ltac2.Control Ltac2.Pattern Ltac2.Array Ltac2.Int Ltac2.Std. + +(** Constr matching *) + +Ltac2 lazy_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + match p with + | Pattern.ConstrMatchPattern pat f => + Control.plus + (fun _ => + let bind := Pattern.matches_vect pat t in + fun _ => f bind + ) + (fun _ => interp m) + | Pattern.ConstrMatchContext pat f => + Control.plus + (fun _ => + let ((context, bind)) := Pattern.matches_subterm_vect pat t in + fun _ => f context bind + ) + (fun _ => interp m) + end + end in + let ans := Control.once (fun () => interp pats) in + ans (). + +Ltac2 Notation "lazy_match!" t(tactic(6)) "with" m(constr_matching) "end" := + lazy_match0 t m. (** Tacticals *) diff --git a/theories/Pattern.v b/theories/Pattern.v index ab3135f189..a672ad0fe7 100644 --- a/theories/Pattern.v +++ b/theories/Pattern.v @@ -14,7 +14,7 @@ Ltac2 Type context. Ltac2 Type 'a constr_match := [ | ConstrMatchPattern (pattern, constr array -> 'a) -| ConstrMatchContext (pattern, constr -> constr array -> 'a) +| ConstrMatchContext (pattern, context -> constr array -> 'a) ]. Ltac2 @ external matches : t -> constr -> (ident * constr) list := @@ -30,6 +30,14 @@ Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) li value compared to [matches] is the context of the match, to be filled with the instantiate function. *) +Ltac2 @ external matches_vect : t -> constr -> constr array := + "ltac2" "pattern_matches_vect". +(** Internal version of [matches] that does not return the identifiers. *) + +Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := + "ltac2" "pattern_matches_subterm_vect". +(** Internal version of [matches_subterms] that does not return the identifiers. *) + Ltac2 @ external instantiate : context -> constr -> constr := "ltac2" "pattern_instantiate". (** Fill the hole of a context with the given term. *) -- cgit v1.2.3 From e634eb23010a3dee3fddcdd3d7d5588c3b40e1f6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 13:39:17 +0200 Subject: Implementing multi-match and simple match over constrs. --- tests/matching.v | 10 ++++++++++ theories/Notations.v | 31 +++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/tests/matching.v b/tests/matching.v index d21c505cdf..f43e0121ef 100644 --- a/tests/matching.v +++ b/tests/matching.v @@ -14,4 +14,14 @@ in it commits to a branch*) lazy_match! '(nat -> bool) with context [?a] => f a end. lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. + +(** This one works by taking the second match context, i.e. ?a := nat *) +let b := { contents := true } in +let f c := + match b.(contents) with + | true => b.(contents) := false; fail + | false => Message.print (Message.of_constr c) + end +in +match! '(nat -> bool) with context [?a] => f a end. Abort. diff --git a/theories/Notations.v b/theories/Notations.v index 93c9dd1798..5ed47336ad 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -38,6 +38,37 @@ Ltac2 lazy_match0 t pats := Ltac2 Notation "lazy_match!" t(tactic(6)) "with" m(constr_matching) "end" := lazy_match0 t m. +Ltac2 multi_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + match p with + | Pattern.ConstrMatchPattern pat f => + Control.plus + (fun _ => + let bind := Pattern.matches_vect pat t in + f bind + ) + (fun _ => interp m) + | Pattern.ConstrMatchContext pat f => + Control.plus + (fun _ => + let ((context, bind)) := Pattern.matches_subterm_vect pat t in + f context bind + ) + (fun _ => interp m) + end + end in + interp pats. + +Ltac2 Notation "multi_match!" t(tactic(6)) "with" m(constr_matching) "end" := + multi_match0 t m. + +Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). + +Ltac2 Notation "match!" t(tactic(6)) "with" m(constr_matching) "end" := + one_match0 t m. + (** Tacticals *) Ltac2 orelse t f := -- cgit v1.2.3 From 818c49240f2ee6fccd38a556c7e90126606e1837 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 14:45:32 +0200 Subject: Fix coq/ltac2#17: Assertion failed. on only shelved goals remaining. We check that the goal tactic is focussed before calling enter_one. --- src/tac2core.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index bbf95c7056..f4486bf0c8 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -116,6 +116,12 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit +let assert_focussed = + Proofview.Goal.goals >>= fun gls -> + match gls with + | [_] -> Proofview.tclUNIT () + | [] | _ :: _ :: _ -> throw err_notfocussed + let pf_apply f = Proofview.Goal.goals >>= function | [] -> @@ -682,6 +688,7 @@ end (** unit -> constr *) let () = define0 "goal" begin + assert_focussed >>= fun () -> Proofview.Goal.enter_one begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in return (Value.of_constr concl) -- cgit v1.2.3 From cd3819db675bd42510eac1bd616ca20e33e7d997 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 1 Sep 2017 00:57:33 +0200 Subject: Closures now wear the constant they originated from. --- src/tac2core.ml | 1 + src/tac2entries.ml | 2 +- src/tac2env.ml | 14 ++++++++------ src/tac2expr.mli | 2 ++ src/tac2interp.ml | 8 ++++---- 5 files changed, 16 insertions(+), 11 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index f4486bf0c8..793cb3e535 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -647,6 +647,7 @@ let () = define1 "case" begin fun f -> Proofview.tclCASE (thaw f) >>= begin function | Proofview.Next (x, k) -> let k = { + clos_ref = None; clos_env = Id.Map.singleton k_var (Value.of_ext Value.val_kont k); clos_var = [Name e_var]; clos_exp = GTacPrm (prm_apply_kont_h, [GTacVar k_var; GTacVar e_var]); diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 34022b86c9..0754108505 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -792,7 +792,7 @@ let call ~default e = let loc = loc_of_tacexpr e in let (e, t) = intern e in let () = check_unit ?loc t in - let tac = Tac2interp.interp Id.Map.empty e in + let tac = Tac2interp.interp Tac2interp.empty_environment e in solve default (Proofview.tclIGNORE tac) (** Primitive algebraic types than can't be defined Coq-side *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 9aaaae0465..c04eaf7b0c 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -53,30 +53,32 @@ let empty_state = { let ltac_state = Summary.ref empty_state ~name:"ltac2-state" (** Get a dynamic value from syntactical value *) -let rec eval_pure = function +let rec eval_pure kn = function | GTacAtm (AtmInt n) -> ValInt n | GTacRef kn -> let { gdata_expr = e } = try KNmap.find kn ltac_state.contents.ltac_tactics with Not_found -> assert false in - eval_pure e + eval_pure (Some kn) e | GTacFun (na, e) -> - ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e } + ValCls { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } | GTacCst (_, n, []) -> ValInt n -| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el) -| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_pure el) +| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_unnamed el) +| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_unnamed el) | GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ | GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> anomaly (Pp.str "Term is not a syntactical value") +and eval_unnamed e = eval_pure None e + let define_global kn e = let state = !ltac_state in ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } let interp_global kn = let data = KNmap.find kn ltac_state.contents.ltac_tactics in - (data, eval_pure data.gdata_expr) + (data, eval_pure (Some kn) data.gdata_expr) let define_constructor kn t = let state = !ltac_state in diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 1045063cd2..470323e7c7 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -201,6 +201,8 @@ and closure = { (** Bound variables *) clos_exp : glb_tacexpr; (** Body *) + clos_ref : ltac_constant option; + (** Global constant from which the closure originates *) } type ml_tactic = valexpr list -> valexpr Proofview.tactic diff --git a/src/tac2interp.ml b/src/tac2interp.ml index c15331571b..7bcfad1be1 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -47,7 +47,7 @@ let rec interp ist = function | GTacVar id -> return (get_var ist id) | GTacRef qid -> return (get_ref ist qid) | GTacFun (ids, e) -> - let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + let cls = { clos_ref = None; clos_env = ist; clos_var = ids; clos_exp = e } in return (ValCls cls) | GTacApp (f, args) -> interp ist f >>= fun f -> @@ -63,7 +63,7 @@ let rec interp ist = function | GTacLet (true, el, e) -> let map (na, e) = match e with | GTacFun (ids, e) -> - let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + let cls = { clos_ref = None; clos_env = ist; clos_var = ids; clos_exp = e } in na, cls | _ -> anomaly (str "Ill-formed recursive function") in @@ -102,12 +102,12 @@ let rec interp ist = function tpe.Tac2env.ml_interp ist e and interp_app f args = match f with -| ValCls { clos_env = ist; clos_var = ids; clos_exp = e } -> +| ValCls { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> let rec push ist ids args = match ids, args with | [], [] -> interp ist e | [], _ :: _ -> interp ist e >>= fun f -> interp_app f args | _ :: _, [] -> - let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in + let cls = { clos_ref = kn; clos_env = ist; clos_var = ids; clos_exp = e } in return (ValCls cls) | id :: ids, arg :: args -> push (push_name ist id arg) ids args in -- cgit v1.2.3 From dd2a9aa0fd0a8d725f131223a4e0a01de8a98e1e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 15:41:50 +0200 Subject: Updated gitignore. --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index ffdea1320c..50ed772be3 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,4 @@ Makefile.coq.conf *.o *.a *.aux +tests/*.log -- cgit v1.2.3 From d80e854d6827252676c2c504bb3108152a94d629 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 15:24:33 +0200 Subject: Quick-and-dirty backtrace mechanism for the interpreter. --- doc/ltac2.md | 5 ++ src/tac2core.ml | 254 +++++++++++++++++++++++++++------------------------- src/tac2core.mli | 2 +- src/tac2entries.ml | 35 ++++++++ src/tac2expr.mli | 14 ++- src/tac2ffi.ml | 5 +- src/tac2interp.ml | 43 ++++----- src/tac2interp.mli | 6 +- src/tac2stdlib.ml | 190 ++++++++++++++++++++------------------- src/tac2tactics.ml | 48 +++++----- src/tac2tactics.mli | 23 ++--- 11 files changed, 340 insertions(+), 285 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index dd0dc391c6..c1216d8f89 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -703,6 +703,11 @@ foo 0 ↦ (fun x => x ()) (fun _ => 0) Note that abbreviations are not typechecked at all, and may result in typing errors after expansion. +# Debug + +When the option `Ltac2 Backtrace` is set, toplevel failures will be printed with +a backtrace. + # Compatibility layer with Ltac1 ## Ltac1 from Ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml index 793cb3e535..17fa7c28f4 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -14,7 +14,6 @@ open Genarg open Tac2env open Tac2dyn open Tac2expr -open Tac2interp open Tac2entries.Pltac open Proofview.Notations @@ -90,22 +89,26 @@ let of_result f = function (** Stdlib exceptions *) -let err_notfocussed = - LtacError (coq_core "Not_focussed", [||]) +let err_notfocussed bt = + Tac2interp.LtacError (coq_core "Not_focussed", [||], bt) -let err_outofbounds = - LtacError (coq_core "Out_of_bounds", [||]) +let err_outofbounds bt = + Tac2interp.LtacError (coq_core "Out_of_bounds", [||], bt) -let err_notfound = - LtacError (coq_core "Not_found", [||]) +let err_notfound bt = + Tac2interp.LtacError (coq_core "Not_found", [||], bt) -let err_matchfailure = - LtacError (coq_core "Match_failure", [||]) +let err_matchfailure bt = + Tac2interp.LtacError (coq_core "Match_failure", [||], bt) (** Helper functions *) -let thaw f = interp_app f [v_unit] -let throw e = Proofview.tclLIFT (Proofview.NonLogical.raise e) +let thaw bt f = Tac2interp.interp_app bt f [v_unit] +let throw bt e = Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) + +let set_bt bt e = match e with +| Tac2interp.LtacError (kn, args, _) -> Tac2interp.LtacError (kn, args, bt) +| e -> e let return x = Proofview.tclUNIT x let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -116,13 +119,13 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit -let assert_focussed = +let assert_focussed bt = Proofview.Goal.goals >>= fun gls -> match gls with | [_] -> Proofview.tclUNIT () - | [] | _ :: _ :: _ -> throw err_notfocussed + | [] | _ :: _ :: _ -> throw bt err_notfocussed -let pf_apply f = +let pf_apply bt f = Proofview.Goal.goals >>= function | [] -> Proofview.tclENV >>= fun env -> @@ -132,61 +135,61 @@ let pf_apply f = gl >>= fun gl -> f (Proofview.Goal.env gl) (Tacmach.New.project gl) | _ :: _ :: _ -> - throw err_notfocussed + throw bt err_notfocussed (** Primitives *) -let define0 name f = Tac2env.define_primitive (pname name) begin function -| [_] -> f +let define0 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [_] -> f bt | _ -> assert false end -let define1 name f = Tac2env.define_primitive (pname name) begin function -| [x] -> f x +let define1 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [x] -> f bt x | _ -> assert false end -let define2 name f = Tac2env.define_primitive (pname name) begin function -| [x; y] -> f x y +let define2 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [x; y] -> f bt x y | _ -> assert false end -let define3 name f = Tac2env.define_primitive (pname name) begin function -| [x; y; z] -> f x y z +let define3 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [x; y; z] -> f bt x y z | _ -> assert false end (** Printing *) -let () = define1 "print" begin fun pp -> +let () = define1 "print" begin fun _ pp -> wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) end -let () = define1 "message_of_int" begin fun n -> +let () = define1 "message_of_int" begin fun _ n -> let n = Value.to_int n in return (Value.of_pp (int n)) end -let () = define1 "message_of_string" begin fun s -> +let () = define1 "message_of_string" begin fun _ s -> let s = Value.to_string s in return (Value.of_pp (str (Bytes.to_string s))) end -let () = define1 "message_of_constr" begin fun c -> - pf_apply begin fun env sigma -> +let () = define1 "message_of_constr" begin fun bt c -> + pf_apply bt begin fun env sigma -> let c = Value.to_constr c in let pp = Printer.pr_econstr_env env sigma c in return (Value.of_pp pp) end end -let () = define1 "message_of_ident" begin fun c -> +let () = define1 "message_of_ident" begin fun _ c -> let c = Value.to_ident c in let pp = Id.print c in return (Value.of_pp pp) end -let () = define2 "message_concat" begin fun m1 m2 -> +let () = define2 "message_concat" begin fun _ m1 m2 -> let m1 = Value.to_pp m1 in let m2 = Value.to_pp m2 in return (Value.of_pp (Pp.app m1 m2)) @@ -194,45 +197,45 @@ end (** Array *) -let () = define2 "array_make" begin fun n x -> +let () = define2 "array_make" begin fun bt n x -> let n = Value.to_int n in - if n < 0 || n > Sys.max_array_length then throw err_outofbounds + if n < 0 || n > Sys.max_array_length then throw bt err_outofbounds else wrap (fun () -> ValBlk (0, Array.make n x)) end -let () = define1 "array_length" begin fun v -> +let () = define1 "array_length" begin fun _ v -> let v = to_block v in return (ValInt (Array.length v)) end -let () = define3 "array_set" begin fun v n x -> +let () = define3 "array_set" begin fun bt v n x -> let v = to_block v in let n = Value.to_int n in - if n < 0 || n >= Array.length v then throw err_outofbounds + if n < 0 || n >= Array.length v then throw bt err_outofbounds else wrap_unit (fun () -> v.(n) <- x) end -let () = define2 "array_get" begin fun v n -> +let () = define2 "array_get" begin fun bt v n -> let v = to_block v in let n = Value.to_int n in - if n < 0 || n >= Array.length v then throw err_outofbounds + if n < 0 || n >= Array.length v then throw bt err_outofbounds else wrap (fun () -> v.(n)) end (** Ident *) -let () = define2 "ident_equal" begin fun id1 id2 -> +let () = define2 "ident_equal" begin fun _ id1 id2 -> let id1 = Value.to_ident id1 in let id2 = Value.to_ident id2 in return (Value.of_bool (Id.equal id1 id2)) end -let () = define1 "ident_to_string" begin fun id -> +let () = define1 "ident_to_string" begin fun _ id -> let id = Value.to_ident id in return (Value.of_string (Id.to_string id)) end -let () = define1 "ident_of_string" begin fun s -> +let () = define1 "ident_of_string" begin fun _ s -> let s = Value.to_string s in let id = try Some (Id.of_string s) with _ -> None in return (Value.of_option Value.of_ident id) @@ -240,11 +243,11 @@ end (** Int *) -let () = define2 "int_equal" begin fun m n -> +let () = define2 "int_equal" begin fun _ m n -> return (Value.of_bool (Value.to_int m == Value.to_int n)) end -let binop n f = define2 n begin fun m n -> +let binop n f = define2 n begin fun _ m n -> return (Value.of_int (f (Value.to_int m) (Value.to_int n))) end @@ -253,42 +256,42 @@ let () = binop "int_add" (+) let () = binop "int_sub" (-) let () = binop "int_mul" ( * ) -let () = define1 "int_neg" begin fun m -> +let () = define1 "int_neg" begin fun _ m -> return (Value.of_int (~- (Value.to_int m))) end (** String *) -let () = define2 "string_make" begin fun n c -> +let () = define2 "string_make" begin fun bt n c -> let n = Value.to_int n in let c = Value.to_char c in - if n < 0 || n > Sys.max_string_length then throw err_outofbounds + if n < 0 || n > Sys.max_string_length then throw bt err_outofbounds else wrap (fun () -> Value.of_string (Bytes.make n c)) end -let () = define1 "string_length" begin fun s -> +let () = define1 "string_length" begin fun _ s -> return (Value.of_int (Bytes.length (Value.to_string s))) end -let () = define3 "string_set" begin fun s n c -> +let () = define3 "string_set" begin fun bt s n c -> let s = Value.to_string s in let n = Value.to_int n in let c = Value.to_char c in - if n < 0 || n >= Bytes.length s then throw err_outofbounds + if n < 0 || n >= Bytes.length s then throw bt err_outofbounds else wrap_unit (fun () -> Bytes.set s n c) end -let () = define2 "string_get" begin fun s n -> +let () = define2 "string_get" begin fun bt s n -> let s = Value.to_string s in let n = Value.to_int n in - if n < 0 || n >= Bytes.length s then throw err_outofbounds + if n < 0 || n >= Bytes.length s then throw bt err_outofbounds else wrap (fun () -> Value.of_char (Bytes.get s n)) end (** Terms *) (** constr -> constr *) -let () = define1 "constr_type" begin fun c -> +let () = define1 "constr_type" begin fun bt c -> let c = Value.to_constr c in let get_type env sigma = Proofview.V82.wrap_exceptions begin fun () -> @@ -296,11 +299,11 @@ let () = define1 "constr_type" begin fun c -> let t = Value.of_constr t in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t end in - pf_apply get_type + pf_apply bt get_type end (** constr -> constr *) -let () = define2 "constr_equal" begin fun c1 c2 -> +let () = define2 "constr_equal" begin fun _ c1 c2 -> let c1 = Value.to_constr c1 in let c2 = Value.to_constr c2 in Proofview.tclEVARMAP >>= fun sigma -> @@ -308,7 +311,7 @@ let () = define2 "constr_equal" begin fun c1 c2 -> Proofview.tclUNIT (Value.of_bool b) end -let () = define1 "constr_kind" begin fun c -> +let () = define1 "constr_kind" begin fun _ c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> let c = Value.to_constr c in @@ -403,7 +406,7 @@ let () = define1 "constr_kind" begin fun c -> end end -let () = define1 "constr_make" begin fun knd -> +let () = define1 "constr_make" begin fun _ knd -> let open Constr in let c = match knd with | ValBlk (0, [|n|]) -> @@ -483,9 +486,9 @@ let () = define1 "constr_make" begin fun knd -> return (Value.of_constr c) end -let () = define1 "constr_check" begin fun c -> +let () = define1 "constr_check" begin fun bt c -> let c = Value.to_constr c in - pf_apply begin fun env sigma -> + pf_apply bt begin fun env sigma -> try let (sigma, _) = Typing.type_of env sigma c in Proofview.Unsafe.tclEVARS sigma >>= fun () -> @@ -496,7 +499,7 @@ let () = define1 "constr_check" begin fun c -> end end -let () = define3 "constr_substnl" begin fun subst k c -> +let () = define3 "constr_substnl" begin fun _ subst k c -> let subst = Value.to_list Value.to_constr subst in let k = Value.to_int k in let c = Value.to_constr c in @@ -504,7 +507,7 @@ let () = define3 "constr_substnl" begin fun subst k c -> return (Value.of_constr ans) end -let () = define3 "constr_closenl" begin fun ids k c -> +let () = define3 "constr_closenl" begin fun _ ids k c -> let ids = Value.to_list Value.to_ident ids in let k = Value.to_int k in let c = Value.to_constr c in @@ -514,16 +517,16 @@ end (** Patterns *) -let () = define2 "pattern_matches" begin fun pat c -> +let () = define2 "pattern_matches" begin fun bt pat c -> let pat = Value.to_pattern pat in let c = Value.to_constr c in - pf_apply begin fun env sigma -> + pf_apply bt begin fun env sigma -> let ans = try Some (Constr_matching.matches env sigma pat c) with Constr_matching.PatternMatchingFailure -> None in begin match ans with - | None -> Proofview.tclZERO err_matchfailure + | None -> Proofview.tclZERO (err_matchfailure bt) | Some ans -> let ans = Id.Map.bindings ans in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in @@ -532,34 +535,34 @@ let () = define2 "pattern_matches" begin fun pat c -> end end -let () = define2 "pattern_matches_subterm" begin fun pat c -> +let () = define2 "pattern_matches_subterm" begin fun bt pat c -> let pat = Value.to_pattern pat in let c = Value.to_constr c in let open Constr_matching in let rec of_ans s = match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO err_matchfailure + | IStream.Nil -> Proofview.tclZERO (err_matchfailure bt) | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_list of_pair ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in - pf_apply begin fun env sigma -> + pf_apply bt begin fun env sigma -> let ans = Constr_matching.match_appsubterm env sigma pat c in of_ans ans end end -let () = define2 "pattern_matches_vect" begin fun pat c -> +let () = define2 "pattern_matches_vect" begin fun bt pat c -> let pat = Value.to_pattern pat in let c = Value.to_constr c in - pf_apply begin fun env sigma -> + pf_apply bt begin fun env sigma -> let ans = try Some (Constr_matching.matches env sigma pat c) with Constr_matching.PatternMatchingFailure -> None in begin match ans with - | None -> Proofview.tclZERO err_matchfailure + | None -> Proofview.tclZERO (err_matchfailure bt) | Some ans -> let ans = Id.Map.bindings ans in let ans = Array.map_of_list snd ans in @@ -568,25 +571,25 @@ let () = define2 "pattern_matches_vect" begin fun pat c -> end end -let () = define2 "pattern_matches_subterm_vect" begin fun pat c -> +let () = define2 "pattern_matches_subterm_vect" begin fun bt pat c -> let pat = Value.to_pattern pat in let c = Value.to_constr c in let open Constr_matching in let rec of_ans s = match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO err_matchfailure + | IStream.Nil -> Proofview.tclZERO (err_matchfailure bt) | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let ans = Array.map_of_list snd ans in let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_array Value.of_constr ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in - pf_apply begin fun env sigma -> + pf_apply bt begin fun env sigma -> let ans = Constr_matching.match_appsubterm env sigma pat c in of_ans ans end end -let () = define2 "pattern_instantiate" begin fun ctx c -> +let () = define2 "pattern_instantiate" begin fun _ ctx c -> let ctx = EConstr.Unsafe.to_constr (Value.to_constr ctx) in let c = EConstr.Unsafe.to_constr (Value.to_constr c) in let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in @@ -595,46 +598,48 @@ end (** Error *) -let () = define1 "throw" begin fun e -> +let () = define1 "throw" begin fun bt e -> let (e, info) = Value.to_exn e in + let e = set_bt bt e in Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) end (** Control *) (** exn -> 'a *) -let () = define1 "zero" begin fun e -> +let () = define1 "zero" begin fun bt e -> let (e, info) = Value.to_exn e in + let e = set_bt bt e in Proofview.tclZERO ~info e end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) -let () = define2 "plus" begin fun x k -> - Proofview.tclOR (thaw x) (fun e -> interp_app k [Value.of_exn e]) +let () = define2 "plus" begin fun bt x k -> + Proofview.tclOR (thaw bt x) (fun e -> Tac2interp.interp_app bt k [Value.of_exn e]) end (** (unit -> 'a) -> 'a *) -let () = define1 "once" begin fun f -> - Proofview.tclONCE (thaw f) +let () = define1 "once" begin fun bt f -> + Proofview.tclONCE (thaw bt f) end (** (unit -> unit) list -> unit *) -let () = define1 "dispatch" begin fun l -> - let l = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) l in +let () = define1 "dispatch" begin fun bt l -> + let l = Value.to_list (fun f -> Proofview.tclIGNORE (thaw bt f)) l in Proofview.tclDISPATCH l >>= fun () -> return v_unit end (** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let () = define3 "extend" begin fun lft tac rgt -> - let lft = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) lft in - let tac = Proofview.tclIGNORE (thaw tac) in - let rgt = Value.to_list (fun f -> Proofview.tclIGNORE (thaw f)) rgt in +let () = define3 "extend" begin fun bt lft tac rgt -> + let lft = Value.to_list (fun f -> Proofview.tclIGNORE (thaw bt f)) lft in + let tac = Proofview.tclIGNORE (thaw bt tac) in + let rgt = Value.to_list (fun f -> Proofview.tclIGNORE (thaw bt f)) rgt in Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit end (** (unit -> unit) -> unit *) -let () = define1 "enter" begin fun f -> - let f = Proofview.tclIGNORE (thaw f) in +let () = define1 "enter" begin fun bt f -> + let f = Proofview.tclIGNORE (thaw bt f) in Proofview.tclINDEPENDENT f >>= fun () -> return v_unit end @@ -643,8 +648,8 @@ let e_var = Id.of_string "e" let prm_apply_kont_h = pname "apply_kont" (** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) -let () = define1 "case" begin fun f -> - Proofview.tclCASE (thaw f) >>= begin function +let () = define1 "case" begin fun bt f -> + Proofview.tclCASE (thaw bt f) >>= begin function | Proofview.Next (x, k) -> let k = { clos_ref = None; @@ -658,38 +663,40 @@ let () = define1 "case" begin fun f -> end (** 'a kont -> exn -> 'a *) -let () = define2 "apply_kont" begin fun k e -> - (Value.to_ext Value.val_kont k) (Value.to_exn e) +let () = define2 "apply_kont" begin fun bt k e -> + let (e, info) = Value.to_exn e in + let e = set_bt bt e in + (Value.to_ext Value.val_kont k) (e, info) end (** int -> int -> (unit -> 'a) -> 'a *) -let () = define3 "focus" begin fun i j tac -> +let () = define3 "focus" begin fun bt i j tac -> let i = Value.to_int i in let j = Value.to_int j in - Proofview.tclFOCUS i j (thaw tac) + Proofview.tclFOCUS i j (thaw bt tac) end (** unit -> unit *) -let () = define0 "shelve" begin +let () = define0 "shelve" begin fun _ -> Proofview.shelve >>= fun () -> return v_unit end (** unit -> unit *) -let () = define0 "shelve_unifiable" begin +let () = define0 "shelve_unifiable" begin fun _ -> Proofview.shelve_unifiable >>= fun () -> return v_unit end -let () = define1 "new_goal" begin fun ev -> +let () = define1 "new_goal" begin fun bt ev -> let ev = Evar.unsafe_of_int (Value.to_int ev) in Proofview.tclEVARMAP >>= fun sigma -> if Evd.mem sigma ev then Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit - else throw err_notfound + else throw bt err_notfound end (** unit -> constr *) -let () = define0 "goal" begin - assert_focussed >>= fun () -> +let () = define0 "goal" begin fun bt -> + assert_focussed bt >>= fun () -> Proofview.Goal.enter_one begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in return (Value.of_constr concl) @@ -697,9 +704,9 @@ let () = define0 "goal" begin end (** ident -> constr *) -let () = define1 "hyp" begin fun id -> +let () = define1 "hyp" begin fun bt id -> let id = Value.to_ident id in - pf_apply begin fun env _ -> + pf_apply bt begin fun env _ -> let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in if mem then return (Value.of_constr (EConstr.mkVar id)) else Tacticals.New.tclZEROMSG @@ -707,8 +714,8 @@ let () = define1 "hyp" begin fun id -> end end -let () = define0 "hyps" begin - pf_apply begin fun env _ -> +let () = define0 "hyps" begin fun bt -> + pf_apply bt begin fun env _ -> let open Context.Named.Declaration in let hyps = List.rev (Environ.named_context env) in let map = function @@ -725,56 +732,56 @@ let () = define0 "hyps" begin end (** (unit -> constr) -> unit *) -let () = define1 "refine" begin fun c -> - let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in +let () = define1 "refine" begin fun bt c -> + let c = thaw bt c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in Proofview.Goal.nf_enter begin fun gl -> Refine.generic_refine ~typecheck:true c gl end >>= fun () -> return v_unit end -let () = define2 "with_holes" begin fun x f -> +let () = define2 "with_holes" begin fun bt x f -> Proofview.tclEVARMAP >>= fun sigma0 -> - thaw x >>= fun ans -> + thaw bt x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> - Tacticals.New.tclWITHHOLES false (interp_app f [ans]) sigma + Tacticals.New.tclWITHHOLES false (Tac2interp.interp_app bt f [ans]) sigma end -let () = define1 "progress" begin fun f -> - Proofview.tclPROGRESS (thaw f) +let () = define1 "progress" begin fun bt f -> + Proofview.tclPROGRESS (thaw bt f) end -let () = define2 "abstract" begin fun id f -> +let () = define2 "abstract" begin fun bt id f -> let id = Value.to_option Value.to_ident id in - Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> + Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw bt f)) >>= fun () -> return v_unit end -let () = define2 "time" begin fun s f -> +let () = define2 "time" begin fun bt s f -> let s = Value.to_option Value.to_string s in - Proofview.tclTIME s (thaw f) + Proofview.tclTIME s (thaw bt f) end -let () = define0 "check_interrupt" begin +let () = define0 "check_interrupt" begin fun bt -> Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit end (** Fresh *) -let () = define2 "fresh_free_union" begin fun set1 set2 -> +let () = define2 "fresh_free_union" begin fun _ set1 set2 -> let set1 = Value.to_ext Value.val_free set1 in let set2 = Value.to_ext Value.val_free set2 in let ans = Id.Set.union set1 set2 in return (Value.of_ext Value.val_free ans) end -let () = define1 "fresh_free_of_ids" begin fun ids -> +let () = define1 "fresh_free_of_ids" begin fun _ ids -> let ids = Value.to_list Value.to_ident ids in let free = List.fold_right Id.Set.add ids Id.Set.empty in return (Value.of_ext Value.val_free free) end -let () = define1 "fresh_free_of_constr" begin fun c -> +let () = define1 "fresh_free_of_constr" begin fun _ c -> let c = Value.to_constr c in Proofview.tclEVARMAP >>= fun sigma -> let rec fold accu c = match EConstr.kind sigma c with @@ -785,7 +792,7 @@ let () = define1 "fresh_free_of_constr" begin fun c -> return (Value.of_ext Value.val_free ans) end -let () = define2 "fresh_fresh" begin fun avoid id -> +let () = define2 "fresh_fresh" begin fun _ avoid id -> let avoid = Value.to_ext Value.val_free avoid in let id = Value.to_ident id in let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in @@ -828,9 +835,10 @@ let intern_constr self ist c = let interp_constr flags ist c = let open Pretyping in - pf_apply begin fun env sigma -> + let bt = ist.env_bkt in + let ist = to_lvar ist in + pf_apply bt begin fun env sigma -> Proofview.V82.wrap_exceptions begin fun () -> - let ist = to_lvar ist in let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in let c = ValExt (Value.val_constr, c) in Proofview.Unsafe.tclEVARS sigma >>= fun () -> @@ -944,7 +952,7 @@ let () = let () = let interp ist env sigma concl tac = let ist = Tac2interp.get_env ist in - let tac = Proofview.tclIGNORE (interp ist tac) in + let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in (EConstr.of_constr c, sigma) in @@ -965,7 +973,9 @@ let () = (** FUCK YOU API *) let idtac = (Obj.magic idtac : Geninterp.Val.t) in let interp ist tac = - Tac2interp.interp Tac2interp.empty_environment tac >>= fun _ -> + let ist = Tac2interp.get_env ist.Geninterp.lfun in + let ist = { ist with env_ist = Id.Map.empty } in + Tac2interp.interp ist tac >>= fun _ -> Ftactic.return idtac in Geninterp.register_interp0 wit_ltac2 interp diff --git a/src/tac2core.mli b/src/tac2core.mli index 9fae65bb3e..b5800a7172 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -27,4 +27,4 @@ val c_false : ltac_constructor end -val pf_apply : (Environ.env -> Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic +val pf_apply : backtrace -> (Environ.env -> Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 0754108505..8d515577ec 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -743,6 +743,41 @@ let register_struct ?local str = match str with | StrSyn (tok, lev, e) -> register_notation ?local tok lev e | StrMut (qid, e) -> register_redefinition ?local qid e +(** Toplevel exception *) + +let print_ltac2_backtrace = ref false + +let _ = Goptions.declare_bool_option { + Goptions.optdepr = false; + Goptions.optname = "print Ltac2 backtrace"; + Goptions.optkey = ["Ltac2"; "Backtrace"]; + Goptions.optread = (fun () -> !print_ltac2_backtrace); + Goptions.optwrite = (fun b -> print_ltac2_backtrace := b); +} + +let pr_frame = function +| FrLtac None -> str "" +| FrLtac (Some kn) -> + Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) +| FrPrim ml -> + str "<" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" +| FrExtn (tag, arg) -> + let obj = Tac2env.interp_ml_object tag in + obj.Tac2env.ml_print (Global.env ()) arg + +let () = register_handler begin function +| Tac2interp.LtacError (kn, _, bt) -> + let c = Tac2print.pr_constructor kn in (** FIXME *) + let bt = + if !print_ltac2_backtrace then + fnl () ++ str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt + else + mt () + in + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) ++ bt +| _ -> raise Unhandled +end + (** Printing *) let print_ltac ref = diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 470323e7c7..36c3fbbe59 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -205,6 +205,16 @@ and closure = { (** Global constant from which the closure originates *) } -type ml_tactic = valexpr list -> valexpr Proofview.tactic +type frame = +| FrLtac of ltac_constant option +| FrPrim of ml_tactic_name +| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame -type environment = valexpr Id.Map.t +type backtrace = frame list + +type ml_tactic = backtrace -> valexpr list -> valexpr Proofview.tactic + +type environment = { + env_ist : valexpr Id.Map.t; + env_bkt : backtrace; +} diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index dd20de5ef5..4ed0096787 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -11,7 +11,6 @@ open Globnames open Genarg open Tac2dyn open Tac2expr -open Tac2interp (** Dynamic tags *) @@ -98,7 +97,7 @@ let internal_err = (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with -| LtacError (kn, c) -> ValOpn (kn, c) +| Tac2interp.LtacError (kn, c, _) -> ValOpn (kn, c) | _ -> ValOpn (internal_err, [|of_ext val_exn c|]) let to_exn c = match c with @@ -106,7 +105,7 @@ let to_exn c = match c with if Names.KerName.equal kn internal_err then to_ext val_exn c.(0) else - (LtacError (kn, c), Exninfo.null) + (Tac2interp.LtacError (kn, c, []), Exninfo.null) | _ -> assert false let of_option f = function diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 7bcfad1be1..b58ce6b851 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -14,25 +14,19 @@ open Names open Proofview.Notations open Tac2expr -exception LtacError of KerName.t * valexpr array +exception LtacError of KerName.t * valexpr array * backtrace -let () = register_handler begin function -| LtacError (kn, _) -> - let c = Tac2print.pr_constructor kn in - hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) -| _ -> raise Unhandled -end - -type environment = valexpr Id.Map.t - -let empty_environment = Id.Map.empty +let empty_environment = { + env_ist = Id.Map.empty; + env_bkt = []; +} let push_name ist id v = match id with | Anonymous -> ist -| Name id -> Id.Map.add id v ist +| Name id -> { ist with env_ist = Id.Map.add id v ist.env_ist } let get_var ist id = - try Id.Map.find id ist with Not_found -> + try Id.Map.find id ist.env_ist with Not_found -> anomaly (str "Unbound variable " ++ Id.print id) let get_ref ist kn = @@ -41,18 +35,18 @@ let get_ref ist kn = let return = Proofview.tclUNIT -let rec interp ist = function +let rec interp (ist : environment) = function | GTacAtm (AtmInt n) -> return (ValInt n) | GTacAtm (AtmStr s) -> return (ValStr (Bytes.of_string s)) | GTacVar id -> return (get_var ist id) | GTacRef qid -> return (get_ref ist qid) | GTacFun (ids, e) -> - let cls = { clos_ref = None; clos_env = ist; clos_var = ids; clos_exp = e } in + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in return (ValCls cls) | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - interp_app f args + interp_app ist.env_bkt f args | GTacLet (false, el, e) -> let fold accu (na, e) = interp ist e >>= fun e -> @@ -63,18 +57,18 @@ let rec interp ist = function | GTacLet (true, el, e) -> let map (na, e) = match e with | GTacFun (ids, e) -> - let cls = { clos_ref = None; clos_env = ist; clos_var = ids; clos_exp = e } in + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in na, cls | _ -> anomaly (str "Ill-formed recursive function") in let fixs = List.map map el in let fold accu (na, cls) = match na with | Anonymous -> accu - | Name id -> Id.Map.add id (ValCls cls) accu + | Name id -> { ist with env_ist = Id.Map.add id (ValCls cls) accu.env_ist } in let ist = List.fold_left fold ist fixs in (** Hack to make a cycle imperatively in the environment *) - let iter (_, e) = e.clos_env <- ist in + let iter (_, e) = e.clos_env <- ist.env_ist in let () = List.iter iter fixs in interp ist e | GTacCst (_, n, []) -> return (ValInt n) @@ -96,22 +90,23 @@ let rec interp ist = function return (ValOpn (kn, Array.of_list el)) | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - Tac2env.interp_primitive ml el + Tac2env.interp_primitive ml (FrPrim ml :: ist.env_bkt) el | GTacExt (tag, e) -> let tpe = Tac2env.interp_ml_object tag in + let ist = { ist with env_bkt = FrExtn (tag, e) :: ist.env_bkt } in tpe.Tac2env.ml_interp ist e -and interp_app f args = match f with +and interp_app bt f args = match f with | ValCls { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> let rec push ist ids args = match ids, args with | [], [] -> interp ist e - | [], _ :: _ -> interp ist e >>= fun f -> interp_app f args + | [], _ :: _ -> interp ist e >>= fun f -> interp_app bt f args | _ :: _, [] -> - let cls = { clos_ref = kn; clos_env = ist; clos_var = ids; clos_exp = e } in + let cls = { clos_ref = kn; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in return (ValCls cls) | id :: ids, arg :: args -> push (push_name ist id arg) ids args in - push ist ids args + push { env_ist = ist; env_bkt = FrLtac kn :: bt } ids args | ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> anomaly (str "Unexpected value shape") diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 1ac26b48db..ea7db33b60 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -9,13 +9,11 @@ open Names open Tac2expr -type environment = valexpr Id.Map.t - val empty_environment : environment val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic -val interp_app : valexpr -> valexpr list -> valexpr Proofview.tactic +val interp_app : backtrace -> valexpr -> valexpr list -> valexpr Proofview.tactic (** {5 Cross-boundary encodings} *) @@ -24,5 +22,5 @@ val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound (** {5 Exceptions} *) -exception LtacError of KerName.t * valexpr array +exception LtacError of KerName.t * valexpr array * backtrace (** Ltac2-defined exceptions seen from OCaml side *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 2a57fdc705..6dcb3f15fb 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -18,7 +18,7 @@ module Value = Tac2ffi let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () -let thaw f = Tac2interp.interp_app f [v_unit] +let thaw bt f = Tac2interp.interp_app bt f [v_unit] let to_pair f g = function | ValBlk (0, [| x; y |]) -> (f x, g y) @@ -126,7 +126,8 @@ and to_intro_patterns il = let to_destruction_arg = function | ValBlk (0, [| c |]) -> - let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + (** FIXME: lost backtrace *) + let c = thaw [] c >>= fun c -> return (to_constr_with_bindings c) in ElimOnConstr c | ValBlk (1, [| id |]) -> ElimOnIdent (Loc.tag (Value.to_ident id)) | ValBlk (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) @@ -153,7 +154,8 @@ let to_rewriting = function | ValBlk (0, [| orient; repeat; c |]) -> let orient = Value.to_option Value.to_bool orient in let repeat = to_multi repeat in - let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + (** FIXME: lost backtrace *) + let c = thaw [] c >>= fun c -> return (to_constr_with_bindings c) in (orient, repeat, c) | _ -> assert false @@ -164,52 +166,52 @@ let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } let lift tac = tac <*> return v_unit let define_prim0 name tac = - let tac = function + let tac bt arg = match arg with | [_] -> lift tac | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim1 name tac = - let tac = function - | [x] -> lift (tac x) + let tac bt arg = match arg with + | [x] -> lift (tac bt x) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim2 name tac = - let tac = function - | [x; y] -> lift (tac x y) + let tac bt arg = match arg with + | [x; y] -> lift (tac bt x y) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim3 name tac = - let tac = function - | [x; y; z] -> lift (tac x y z) + let tac bt arg = match arg with + | [x; y; z] -> lift (tac bt x y z) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim4 name tac = - let tac = function - | [x; y; z; u] -> lift (tac x y z u) + let tac bt arg = match arg with + | [x; y; z; u] -> lift (tac bt x y z u) | _ -> assert false in Tac2env.define_primitive (pname name) tac (** Tactics from Tacexpr *) -let () = define_prim2 "tac_intros" begin fun ev ipat -> +let () = define_prim2 "tac_intros" begin fun _ ev ipat -> let ev = Value.to_bool ev in let ipat = to_intro_patterns ipat in Tactics.intros_patterns ev ipat end -let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> +let () = define_prim4 "tac_apply" begin fun bt adv ev cb ipat -> let adv = Value.to_bool adv in let ev = Value.to_bool ev in - let map_cb c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + let map_cb c = thaw bt c >>= fun c -> return (to_constr_with_bindings c) in let cb = Value.to_list map_cb cb in let map p = Value.to_option (fun p -> Loc.tag (to_intro_pattern p)) p in let map_ipat p = to_pair Value.to_ident map p in @@ -217,20 +219,20 @@ let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> Tac2tactics.apply adv ev cb ipat end -let () = define_prim3 "tac_elim" begin fun ev c copt -> +let () = define_prim3 "tac_elim" begin fun _ ev c copt -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in let copt = Value.to_option to_constr_with_bindings copt in Tactics.elim ev None c copt end -let () = define_prim2 "tac_case" begin fun ev c -> +let () = define_prim2 "tac_case" begin fun _ ev c -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in Tactics.general_case_analysis ev None c end -let () = define_prim1 "tac_generalize" begin fun cl -> +let () = define_prim1 "tac_generalize" begin fun _ cl -> let cast = function | ValBlk (0, [| c; occs; na |]) -> ((to_occurrences Value.to_int occs, Value.to_constr c), to_name na) @@ -240,113 +242,113 @@ let () = define_prim1 "tac_generalize" begin fun cl -> Tactics.new_generalize_gen cl end -let () = define_prim3 "tac_assert" begin fun c tac ipat -> +let () = define_prim3 "tac_assert" begin fun bt c tac ipat -> let c = Value.to_constr c in - let of_tac t = Proofview.tclIGNORE (thaw t) in + let of_tac t = Proofview.tclIGNORE (thaw bt t) in let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in Tactics.forward true tac ipat c end -let () = define_prim3 "tac_enough" begin fun c tac ipat -> +let () = define_prim3 "tac_enough" begin fun bt c tac ipat -> let c = Value.to_constr c in - let of_tac t = Proofview.tclIGNORE (thaw t) in + let of_tac t = Proofview.tclIGNORE (thaw bt t) in let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in Tactics.forward false tac ipat c end -let () = define_prim2 "tac_pose" begin fun idopt c -> +let () = define_prim2 "tac_pose" begin fun _ idopt c -> let na = to_name idopt in let c = Value.to_constr c in Tactics.letin_tac None na c None Locusops.nowhere end -let () = define_prim4 "tac_set" begin fun ev idopt c cl -> +let () = define_prim4 "tac_set" begin fun bt ev idopt c cl -> let ev = Value.to_bool ev in let na = to_name idopt in let cl = to_clause cl in Proofview.tclEVARMAP >>= fun sigma -> - thaw c >>= fun c -> + thaw bt c >>= fun c -> let c = Value.to_constr c in Tactics.letin_pat_tac ev None na (sigma, c) cl end -let () = define_prim3 "tac_destruct" begin fun ev ic using -> +let () = define_prim3 "tac_destruct" begin fun _ ev ic using -> let ev = Value.to_bool ev in let ic = Value.to_list to_induction_clause ic in let using = Value.to_option to_constr_with_bindings using in Tac2tactics.induction_destruct false ev ic using end -let () = define_prim3 "tac_induction" begin fun ev ic using -> +let () = define_prim3 "tac_induction" begin fun _ ev ic using -> let ev = Value.to_bool ev in let ic = Value.to_list to_induction_clause ic in let using = Value.to_option to_constr_with_bindings using in Tac2tactics.induction_destruct true ev ic using end -let () = define_prim1 "tac_red" begin fun cl -> +let () = define_prim1 "tac_red" begin fun _ cl -> let cl = to_clause cl in Tactics.reduce (Red false) cl end -let () = define_prim1 "tac_hnf" begin fun cl -> +let () = define_prim1 "tac_hnf" begin fun _ cl -> let cl = to_clause cl in Tactics.reduce Hnf cl end -let () = define_prim3 "tac_simpl" begin fun flags where cl -> +let () = define_prim3 "tac_simpl" begin fun _ flags where cl -> let flags = to_red_flag flags in let where = Value.to_option to_pattern_with_occs where in let cl = to_clause cl in Tac2tactics.simpl flags where cl end -let () = define_prim2 "tac_cbv" begin fun flags cl -> +let () = define_prim2 "tac_cbv" begin fun _ flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in Tac2tactics.cbv flags cl end -let () = define_prim2 "tac_cbn" begin fun flags cl -> +let () = define_prim2 "tac_cbn" begin fun _ flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in Tac2tactics.cbn flags cl end -let () = define_prim2 "tac_lazy" begin fun flags cl -> +let () = define_prim2 "tac_lazy" begin fun _ flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in Tac2tactics.lazy_ flags cl end -let () = define_prim2 "tac_unfold" begin fun refs cl -> +let () = define_prim2 "tac_unfold" begin fun _ refs cl -> let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in let refs = Value.to_list map refs in let cl = to_clause cl in Tac2tactics.unfold refs cl end -let () = define_prim2 "tac_fold" begin fun args cl -> +let () = define_prim2 "tac_fold" begin fun _ args cl -> let args = Value.to_list Value.to_constr args in let cl = to_clause cl in Tactics.reduce (Fold args) cl end -let () = define_prim2 "tac_pattern" begin fun where cl -> +let () = define_prim2 "tac_pattern" begin fun _ where cl -> let where = Value.to_list to_constr_with_occs where in let cl = to_clause cl in Tactics.reduce (Pattern where) cl end -let () = define_prim2 "tac_vm" begin fun where cl -> +let () = define_prim2 "tac_vm" begin fun _ where cl -> let where = Value.to_option to_pattern_with_occs where in let cl = to_clause cl in Tac2tactics.vm where cl end -let () = define_prim2 "tac_native" begin fun where cl -> +let () = define_prim2 "tac_native" begin fun _ where cl -> let where = Value.to_option to_pattern_with_occs where in let cl = to_clause cl in Tac2tactics.native where cl @@ -355,97 +357,97 @@ end (** Reduction functions *) let define_red1 name tac = - let tac = function - | [x] -> tac x >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let tac bt arg = match arg with + | [x] -> tac bt x >>= fun c -> Proofview.tclUNIT (Value.of_constr c) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_red2 name tac = - let tac = function - | [x; y] -> tac x y >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let tac bt arg = match arg with + | [x; y] -> tac bt x y >>= fun c -> Proofview.tclUNIT (Value.of_constr c) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_red3 name tac = - let tac = function - | [x; y; z] -> tac x y z >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let tac bt arg = match arg with + | [x; y; z] -> tac bt x y z >>= fun c -> Proofview.tclUNIT (Value.of_constr c) | _ -> assert false in Tac2env.define_primitive (pname name) tac -let () = define_red1 "eval_red" begin fun c -> +let () = define_red1 "eval_red" begin fun bt c -> let c = Value.to_constr c in - Tac2tactics.eval_red c + Tac2tactics.eval_red bt c end -let () = define_red1 "eval_hnf" begin fun c -> +let () = define_red1 "eval_hnf" begin fun bt c -> let c = Value.to_constr c in - Tac2tactics.eval_hnf c + Tac2tactics.eval_hnf bt c end -let () = define_red3 "eval_simpl" begin fun flags where c -> +let () = define_red3 "eval_simpl" begin fun bt flags where c -> let flags = to_red_flag flags in let where = Value.to_option to_pattern_with_occs where in let c = Value.to_constr c in - Tac2tactics.eval_simpl flags where c + Tac2tactics.eval_simpl bt flags where c end -let () = define_red2 "eval_cbv" begin fun flags c -> +let () = define_red2 "eval_cbv" begin fun bt flags c -> let flags = to_red_flag flags in let c = Value.to_constr c in - Tac2tactics.eval_cbv flags c + Tac2tactics.eval_cbv bt flags c end -let () = define_red2 "eval_cbn" begin fun flags c -> +let () = define_red2 "eval_cbn" begin fun bt flags c -> let flags = to_red_flag flags in let c = Value.to_constr c in - Tac2tactics.eval_cbn flags c + Tac2tactics.eval_cbn bt flags c end -let () = define_red2 "eval_lazy" begin fun flags c -> +let () = define_red2 "eval_lazy" begin fun bt flags c -> let flags = to_red_flag flags in let c = Value.to_constr c in - Tac2tactics.eval_lazy flags c + Tac2tactics.eval_lazy bt flags c end -let () = define_red2 "eval_unfold" begin fun refs c -> +let () = define_red2 "eval_unfold" begin fun bt refs c -> let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in let refs = Value.to_list map refs in let c = Value.to_constr c in - Tac2tactics.eval_unfold refs c + Tac2tactics.eval_unfold bt refs c end -let () = define_red2 "eval_fold" begin fun args c -> +let () = define_red2 "eval_fold" begin fun bt args c -> let args = Value.to_list Value.to_constr args in let c = Value.to_constr c in - Tac2tactics.eval_fold args c + Tac2tactics.eval_fold bt args c end -let () = define_red2 "eval_pattern" begin fun where c -> +let () = define_red2 "eval_pattern" begin fun bt where c -> let where = Value.to_list (fun p -> to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) p) where in let c = Value.to_constr c in - Tac2tactics.eval_pattern where c + Tac2tactics.eval_pattern bt where c end -let () = define_red2 "eval_vm" begin fun where c -> +let () = define_red2 "eval_vm" begin fun bt where c -> let where = Value.to_option to_pattern_with_occs where in let c = Value.to_constr c in - Tac2tactics.eval_vm where c + Tac2tactics.eval_vm bt where c end -let () = define_red2 "eval_native" begin fun where c -> +let () = define_red2 "eval_native" begin fun bt where c -> let where = Value.to_option to_pattern_with_occs where in let c = Value.to_constr c in - Tac2tactics.eval_native where c + Tac2tactics.eval_native bt where c end -let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> +let () = define_prim4 "tac_rewrite" begin fun bt ev rw cl by -> let ev = Value.to_bool ev in let rw = Value.to_list to_rewriting rw in let cl = to_clause cl in - let to_tac t = Proofview.tclIGNORE (thaw t) in + let to_tac t = Proofview.tclIGNORE (thaw bt t) in let by = Value.to_option to_tac by in Tac2tactics.rewrite ev rw cl by end @@ -464,69 +466,69 @@ END let () = define_prim0 "tac_assumption" Tactics.assumption -let () = define_prim1 "tac_transitivity" begin fun c -> +let () = define_prim1 "tac_transitivity" begin fun _ c -> let c = Value.to_constr c in Tactics.intros_transitivity (Some c) end let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) -let () = define_prim1 "tac_cut" begin fun c -> +let () = define_prim1 "tac_cut" begin fun _ c -> let c = Value.to_constr c in Tactics.cut c end -let () = define_prim2 "tac_left" begin fun ev bnd -> +let () = define_prim2 "tac_left" begin fun _ ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in Tactics.left_with_bindings ev bnd end -let () = define_prim2 "tac_right" begin fun ev bnd -> +let () = define_prim2 "tac_right" begin fun _ ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in Tactics.right_with_bindings ev bnd end -let () = define_prim1 "tac_introsuntil" begin fun h -> +let () = define_prim1 "tac_introsuntil" begin fun _ h -> Tactics.intros_until (to_qhyp h) end -let () = define_prim1 "tac_exactnocheck" begin fun c -> +let () = define_prim1 "tac_exactnocheck" begin fun _ c -> Tactics.exact_no_check (Value.to_constr c) end -let () = define_prim1 "tac_vmcastnocheck" begin fun c -> +let () = define_prim1 "tac_vmcastnocheck" begin fun _ c -> Tactics.vm_cast_no_check (Value.to_constr c) end -let () = define_prim1 "tac_nativecastnocheck" begin fun c -> +let () = define_prim1 "tac_nativecastnocheck" begin fun _ c -> Tactics.native_cast_no_check (Value.to_constr c) end -let () = define_prim1 "tac_constructor" begin fun ev -> +let () = define_prim1 "tac_constructor" begin fun _ ev -> let ev = Value.to_bool ev in Tactics.any_constructor ev None end -let () = define_prim3 "tac_constructorn" begin fun ev n bnd -> +let () = define_prim3 "tac_constructorn" begin fun _ ev n bnd -> let ev = Value.to_bool ev in let n = Value.to_int n in let bnd = to_bindings bnd in Tactics.constructor_tac ev None n bnd end -let () = define_prim1 "tac_symmetry" begin fun cl -> +let () = define_prim1 "tac_symmetry" begin fun _ cl -> let cl = to_clause cl in Tactics.intros_symmetry cl end -let () = define_prim2 "tac_split" begin fun ev bnd -> +let () = define_prim2 "tac_split" begin fun _ ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in Tactics.split_with_bindings ev [bnd] end -let () = define_prim1 "tac_rename" begin fun ids -> +let () = define_prim1 "tac_rename" begin fun _ ids -> let map c = match Value.to_tuple c with | [|x; y|] -> (Value.to_ident x, Value.to_ident y) | _ -> assert false @@ -535,72 +537,72 @@ let () = define_prim1 "tac_rename" begin fun ids -> Tactics.rename_hyp ids end -let () = define_prim1 "tac_revert" begin fun ids -> +let () = define_prim1 "tac_revert" begin fun _ ids -> let ids = Value.to_list Value.to_ident ids in Tactics.revert ids end let () = define_prim0 "tac_admit" Proofview.give_up -let () = define_prim2 "tac_fix" begin fun idopt n -> +let () = define_prim2 "tac_fix" begin fun _ idopt n -> let idopt = Value.to_option Value.to_ident idopt in let n = Value.to_int n in Tactics.fix idopt n end -let () = define_prim1 "tac_cofix" begin fun idopt -> +let () = define_prim1 "tac_cofix" begin fun _ idopt -> let idopt = Value.to_option Value.to_ident idopt in Tactics.cofix idopt end -let () = define_prim1 "tac_clear" begin fun ids -> +let () = define_prim1 "tac_clear" begin fun _ ids -> let ids = Value.to_list Value.to_ident ids in Tactics.clear ids end -let () = define_prim1 "tac_keep" begin fun ids -> +let () = define_prim1 "tac_keep" begin fun _ ids -> let ids = Value.to_list Value.to_ident ids in Tactics.keep ids end -let () = define_prim1 "tac_clearbody" begin fun ids -> +let () = define_prim1 "tac_clearbody" begin fun _ ids -> let ids = Value.to_list Value.to_ident ids in Tactics.clear_body ids end (** Tactics from extratactics *) -let () = define_prim2 "tac_discriminate" begin fun ev arg -> +let () = define_prim2 "tac_discriminate" begin fun _ ev arg -> let ev = Value.to_bool ev in let arg = Value.to_option (fun arg -> None, to_destruction_arg arg) arg in Tac2tactics.discriminate ev arg end -let () = define_prim3 "tac_injection" begin fun ev ipat arg -> +let () = define_prim3 "tac_injection" begin fun _ ev ipat arg -> let ev = Value.to_bool ev in let ipat = Value.to_option to_intro_patterns ipat in let arg = Value.to_option (fun arg -> None, to_destruction_arg arg) arg in Tac2tactics.injection ev ipat arg end -let () = define_prim1 "tac_absurd" begin fun c -> +let () = define_prim1 "tac_absurd" begin fun _ c -> Contradiction.absurd (Value.to_constr c) end -let () = define_prim1 "tac_contradiction" begin fun c -> +let () = define_prim1 "tac_contradiction" begin fun _ c -> let c = Value.to_option to_constr_with_bindings c in Contradiction.contradiction c end -let () = define_prim4 "tac_autorewrite" begin fun all by ids cl -> +let () = define_prim4 "tac_autorewrite" begin fun bt all by ids cl -> let all = Value.to_bool all in - let by = Value.to_option (fun tac -> Proofview.tclIGNORE (thaw tac)) by in + let by = Value.to_option (fun tac -> Proofview.tclIGNORE (thaw bt tac)) by in let ids = Value.to_list Value.to_ident ids in let cl = to_clause cl in Tac2tactics.autorewrite ~all by ids cl end -let () = define_prim1 "tac_subst" begin fun ids -> +let () = define_prim1 "tac_subst" begin fun _ ids -> let ids = Value.to_list Value.to_ident ids in Equality.subst ids end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index a95e60bc97..5b35d53be4 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -122,62 +122,62 @@ let native where cl = let where = Option.map map_pattern_with_occs where in Tactics.reduce (CbvNative where) cl -let eval_fun red c = - Tac2core.pf_apply begin fun env sigma -> +let eval_fun bt red c = + Tac2core.pf_apply bt begin fun env sigma -> let (redfun, _) = Redexpr.reduction_of_red_expr env red in let (sigma, ans) = redfun env sigma c in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT ans end -let eval_red c = - eval_fun (Red false) c +let eval_red bt c = + eval_fun bt (Red false) c -let eval_hnf c = - eval_fun Hnf c +let eval_hnf bt c = + eval_fun bt Hnf c -let eval_simpl flags where c = +let eval_simpl bt flags where c = let where = Option.map map_pattern_with_occs where in Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun (Simpl (flags, where)) c + eval_fun bt (Simpl (flags, where)) c -let eval_cbv flags c = +let eval_cbv bt flags c = Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun (Cbv flags) c + eval_fun bt (Cbv flags) c -let eval_cbn flags c = +let eval_cbn bt flags c = Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun (Cbn flags) c + eval_fun bt (Cbn flags) c -let eval_lazy flags c = +let eval_lazy bt flags c = Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun (Lazy flags) c + eval_fun bt (Lazy flags) c -let eval_unfold occs c = +let eval_unfold bt occs c = let map (gr, occ) = get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) in Proofview.Monad.List.map map occs >>= fun occs -> - eval_fun (Unfold occs) c + eval_fun bt (Unfold occs) c -let eval_fold cl c = - eval_fun (Fold cl) c +let eval_fold bt cl c = + eval_fun bt (Fold cl) c -let eval_pattern where c = +let eval_pattern bt where c = let where = List.map (fun (pat, occ) -> (occ, pat)) where in - eval_fun (Pattern where) c + eval_fun bt (Pattern where) c -let eval_vm where c = +let eval_vm bt where c = let where = Option.map map_pattern_with_occs where in - eval_fun (CbvVm where) c + eval_fun bt (CbvVm where) c -let eval_native where c = +let eval_native bt where c = let where = Option.map map_pattern_with_occs where in - eval_fun (CbvNative where) c + eval_fun bt (CbvNative where) c let on_destruction_arg tac ev arg = Proofview.Goal.enter begin fun gl -> diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 87489bb248..1c76bd9648 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -9,6 +9,7 @@ open Names open Locus open Globnames +open Tac2expr open EConstr open Genredexpr open Misctypes @@ -55,28 +56,28 @@ val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit ta val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic -val eval_red : constr -> constr tactic +val eval_red : backtrace -> constr -> constr tactic -val eval_hnf : constr -> constr tactic +val eval_hnf : backtrace -> constr -> constr tactic -val eval_simpl : global_reference glob_red_flag -> +val eval_simpl : backtrace -> global_reference glob_red_flag -> (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic -val eval_cbv : global_reference glob_red_flag -> constr -> constr tactic +val eval_cbv : backtrace -> global_reference glob_red_flag -> constr -> constr tactic -val eval_cbn : global_reference glob_red_flag -> constr -> constr tactic +val eval_cbn : backtrace -> global_reference glob_red_flag -> constr -> constr tactic -val eval_lazy : global_reference glob_red_flag -> constr -> constr tactic +val eval_lazy : backtrace -> global_reference glob_red_flag -> constr -> constr tactic -val eval_unfold : (global_reference * occurrences_expr) list -> constr -> constr tactic +val eval_unfold : backtrace -> (global_reference * occurrences_expr) list -> constr -> constr tactic -val eval_fold : constr list -> constr -> constr tactic +val eval_fold : backtrace -> constr list -> constr -> constr tactic -val eval_pattern : (EConstr.t * occurrences_expr) list -> constr -> constr tactic +val eval_pattern : backtrace -> (EConstr.t * occurrences_expr) list -> constr -> constr tactic -val eval_vm : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic +val eval_vm : backtrace -> (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic -val eval_native : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic +val eval_native : backtrace -> (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic val discriminate : evars_flag -> destruction_arg option -> unit tactic -- cgit v1.2.3 From 567435828772e53327bacf7464291a5759c23831 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 19:14:30 +0200 Subject: Better backtraces for a few datatypes. --- src/tac2core.ml | 8 ++++++-- src/tac2entries.ml | 9 +++++---- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 17fa7c28f4..e4bd80adc8 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -930,9 +930,13 @@ let () = let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in GlbVal tac, gtypref t_unit in - let interp _ tac = + let interp ist tac = + let ist = { ist with env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in (** FUCK YOU API *) - (Obj.magic Ltac_plugin.Tacinterp.eval_tactic tac : unit Proofview.tactic) >>= fun () -> + let ist = { ist with API.Geninterp.lfun = (Obj.magic lfun) } in + (Obj.magic Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) >>= fun () -> return v_unit in let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 8d515577ec..197ec19b3a 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -756,14 +756,15 @@ let _ = Goptions.declare_bool_option { } let pr_frame = function -| FrLtac None -> str "" +| FrLtac None -> str "Call " | FrLtac (Some kn) -> - Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) + str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) | FrPrim ml -> - str "<" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" + str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" | FrExtn (tag, arg) -> let obj = Tac2env.interp_ml_object tag in - obj.Tac2env.ml_print (Global.env ()) arg + str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ + obj.Tac2env.ml_print (Global.env ()) arg let () = register_handler begin function | Tac2interp.LtacError (kn, _, bt) -> -- cgit v1.2.3 From dd5ad74b19530568159606828c8542ac298be29d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 20:49:00 +0200 Subject: Implementing the non-strict mode. --- doc/ltac2.md | 24 ++++++++++++++++++++++++ src/tac2entries.ml | 6 +++--- src/tac2intern.ml | 20 +++++++++++++++++--- src/tac2intern.mli | 2 +- tests/compat.v | 4 +--- 5 files changed, 46 insertions(+), 10 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index c1216d8f89..d7c8719a14 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -440,6 +440,8 @@ TERM ::= QUOTNAME := IDENT ``` +### Built-in quotations + The current implementation recognizes the following built-in quotations: - "ident", which parses identifiers (type `Init.ident`). - "constr", which parses Coq terms and produces an-evar free term at runtime @@ -457,6 +459,28 @@ The following syntactic sugar is provided for two common cases. - `@id` is the same as ident:(id) - `'t` is the same as open_constr:(t) +### Strict vs. non-strict mode + +Depending on the context, quotations producing terms (i.e. `constr` or +`open_constr`) are not internalized in the same way. There are two possible +modes, respectively called the *strict* and the *non-strict* mode. + +- In strict mode, all simple identifiers appearing in a term quotation are +required to be resolvable statically. That is, they must be the short name of +a declaration which is defined globally, excluding section variables and +hypotheses. If this doesn't hold, internalization will fail. To work around +this error, one has to specifically use the `&` notation. +- In non-strict mode, any simple identifier appearing in a term quotation which +is not bound in the global context is turned into a dynamic reference to a +hypothesis. That is to say, internalization will succeed, but the evaluation +of the term at runtime will fail if there is no such variable in the dynamic +context. + +Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +mode is only set when evaluating Ltac2 snippets in interactive proof mode. The +rationale is that it is cumbersome to explicitly add `&` interactively, while it +is expected that global tactics enforce more invariants on their code. + ## Term Antiquotations ### Syntax diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 197ec19b3a..7a900e8bf0 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -325,7 +325,7 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = if isrec then inline_rec_tactic tactics else tactics in let map ((loc, id), e) = - let (e, t) = intern e in + let (e, t) = intern ~strict:true e in let () = if not (is_value e) then user_err ?loc (str "Tactic definition must be a syntactical value") @@ -717,7 +717,7 @@ let register_redefinition ?(local = false) (loc, qid) e = if not (data.Tac2env.gdata_mutable) then user_err ?loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") in - let (e, t) = intern e in + let (e, t) = intern ~strict:true e in let () = if not (is_value e) then user_err ?loc (str "Tactic definition must be a syntactical value") @@ -826,7 +826,7 @@ let solve default tac = let call ~default e = let loc = loc_of_tacexpr e in - let (e, t) = intern e in + let (e, t) = intern ~strict:false e in let () = check_unit ?loc t in let tac = Tac2interp.interp Tac2interp.empty_environment e in solve default (Proofview.tclIGNORE tac) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 1dba57c4c1..d1a3e13cdb 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -131,6 +131,8 @@ type environment = { (** Accept unbound type variables *) env_rec : (KerName.t * int) Id.Map.t; (** Recursive type definitions *) + env_str : bool; + (** True iff in strict mode *) } let empty_env () = { @@ -139,6 +141,7 @@ let empty_env () = { env_als = ref Id.Map.empty; env_opn = true; env_rec = Id.Map.empty; + env_str = true; } let env_name env = @@ -780,7 +783,13 @@ let rec intern_rec env (loc, e) = match e with let genv = Global.env_of_context Environ.empty_named_context_val in let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let arg, tpe = Flags.with_option Ltac_plugin.Tacintern.strict_check (fun () -> obj.ml_intern self ist arg) () in + let arg, tpe = + if env.env_str then + let arg () = obj.ml_intern self ist arg in + Flags.with_option Ltac_plugin.Tacintern.strict_check arg () + else + obj.ml_intern self ist arg + in let e = match arg with | GlbVal arg -> GTacExt (tag, arg) | GlbTacexpr e -> e @@ -1121,8 +1130,9 @@ let normalize env (count, vars) (t : UF.elt glb_typexpr) = in subst_type subst t -let intern e = +let intern ~strict e = let env = empty_env () in + let env = if strict then env else { env with env_str = false } in let (e, t) = intern_rec env e in let count = ref 0 in let vars = ref UF.Map.empty in @@ -1487,7 +1497,11 @@ let () = let open Genintern in let intern ist tac = let env = match Genintern.Store.get ist.extra ltac2_env with - | None -> empty_env () + | None -> + (** Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } | Some env -> env in let loc = loc_of_tacexpr tac in diff --git a/src/tac2intern.mli b/src/tac2intern.mli index 045e657460..4b02f91caa 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -13,7 +13,7 @@ open Tac2expr val loc_of_tacexpr : raw_tacexpr -> Loc.t option val loc_of_patexpr : raw_patexpr -> Loc.t option -val intern : raw_tacexpr -> glb_tacexpr * type_scheme +val intern : strict:bool -> raw_tacexpr -> glb_tacexpr * type_scheme val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef val intern_open_type : raw_typexpr -> type_scheme diff --git a/tests/compat.v b/tests/compat.v index f4e849c5de..489fa638e4 100644 --- a/tests/compat.v +++ b/tests/compat.v @@ -18,8 +18,7 @@ Qed. Goal true = false -> false = true. Proof. -(** FIXME when the non-strict mode is implemented. *) -Fail intros H; ltac1:(rewrite H); reflexivity. +intros H; ltac1:(rewrite H); reflexivity. Abort. (** Variables do not cross the compatibility layer boundary. *) @@ -57,4 +56,3 @@ Fail mytac ltac2:(fail). let t := idtac; ltac2:(fail) in mytac t. constructor. Qed. - -- cgit v1.2.3 From 0012f73a1822b97dd8bc8963bc77490cde83e89f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 21:30:34 +0200 Subject: More precise error messages for scope failure. --- src/tac2core.ml | 40 ++++++++++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index e4bd80adc8..17fccf3ac7 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -995,7 +995,19 @@ let () = let add_scope s f = Tac2entries.register_scope (Id.of_string s) f -let scope_fail () = CErrors.user_err (str "Invalid parsing token") +let rec pr_scope = function +| SexprStr (_, s) -> qstring s +| SexprInt (_, n) -> int n +| SexprRec (_, (_, na), args) -> + let na = match na with + | None -> str "_" + | Some id -> Id.print id + in + na ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" + +let scope_fail s args = + let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in + CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) let q_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) @@ -1010,7 +1022,7 @@ let add_generic_scope s entry arg = let scope = Extend.Aentry entry in let act x = Loc.tag @@ CTacExt (arg, x) in Tac2entries.ScopeRule (scope, act) - | _ -> scope_fail () + | arg -> scope_fail s arg in add_scope s parse @@ -1018,14 +1030,14 @@ let () = add_scope "keyword" begin function | [SexprStr (loc, s)] -> let scope = Extend.Atoken (Tok.KEYWORD s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) -| _ -> scope_fail () +| arg -> scope_fail "keyword" arg end let () = add_scope "terminal" begin function | [SexprStr (loc, s)] -> let scope = Extend.Atoken (CLexer.terminal s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) -| _ -> scope_fail () +| arg -> scope_fail "terminal" arg end let () = add_scope "list0" begin function @@ -1040,7 +1052,7 @@ let () = add_scope "list0" begin function let scope = Extend.Alist0sep (scope, sep) in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "list0" arg end let () = add_scope "list1" begin function @@ -1055,7 +1067,7 @@ let () = add_scope "list1" begin function let scope = Extend.Alist1sep (scope, sep) in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "list1" arg end let () = add_scope "opt" begin function @@ -1069,7 +1081,7 @@ let () = add_scope "opt" begin function Loc.tag @@ CTacApp (Loc.tag @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "opt" arg end let () = add_scope "self" begin function @@ -1077,7 +1089,7 @@ let () = add_scope "self" begin function let scope = Extend.Aself in let act tac = tac in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "self" arg end let () = add_scope "next" begin function @@ -1085,7 +1097,7 @@ let () = add_scope "next" begin function let scope = Extend.Anext in let act tac = tac in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "next" arg end let () = add_scope "tactic" begin function @@ -1094,12 +1106,12 @@ let () = add_scope "tactic" begin function let scope = Extend.Aentryl (tac2expr, 5) in let act tac = tac in Tac2entries.ScopeRule (scope, act) -| [SexprInt (loc, n)] -> - let () = if n < 0 || n > 6 then scope_fail () in +| [SexprInt (loc, n)] as arg -> + let () = if n < 0 || n > 6 then scope_fail "tactic" arg in let scope = Extend.Aentryl (tac2expr, n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "tactic" arg end let () = add_scope "thunk" begin function @@ -1107,13 +1119,13 @@ let () = add_scope "thunk" begin function let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let act e = rthunk (act e) in Tac2entries.ScopeRule (scope, act) -| _ -> scope_fail () +| arg -> scope_fail "thunk" arg end let add_expr_scope name entry f = add_scope name begin function | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) - | _ -> scope_fail () + | arg -> scope_fail name arg end let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) -- cgit v1.2.3 From 01a3776cb801ed6cbeba895d04f75e62fd6f091a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 21:55:51 +0200 Subject: More notations for primitive tactics. --- src/g_ltac2.ml4 | 11 +++++++---- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 4 +++- src/tac2quote.ml | 4 ++-- src/tac2quote.mli | 2 ++ theories/Notations.v | 23 +++++++++++++++++++++++ 8 files changed, 40 insertions(+), 7 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 5d5bc6b941..be7f830605 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -368,7 +368,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_reference q_with_bindings q_constr_matching; + q_destruction_arg q_reference q_with_bindings q_constr_matching; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -500,11 +500,14 @@ GEXTEND Gram [ [ c = Constr.constr; l = with_bindings -> Loc.tag ~loc:!@loc @@ (c, l) ] ] ; destruction_arg: - [ [ n = lnatural -> QElimOnAnonHyp n - | id = lident -> QElimOnIdent id - | c = constr_with_bindings -> QElimOnConstr c + [ [ n = lnatural -> Loc.tag ~loc:!@loc @@ QElimOnAnonHyp n + | id = lident -> Loc.tag ~loc:!@loc @@ QElimOnIdent id + | c = constr_with_bindings -> Loc.tag ~loc:!@loc @@ QElimOnConstr c ] ] ; + q_destruction_arg: + [ [ arg = destruction_arg -> arg ] ] + ; as_or_and_ipat: [ [ "as"; ipat = or_and_intropattern -> Some ipat | -> None diff --git a/src/tac2core.ml b/src/tac2core.ml index 17fccf3ac7..867c9ae806 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1133,6 +1133,7 @@ let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns +let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting let () = add_expr_scope "clause" q_clause Tac2quote.of_clause diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 7a900e8bf0..afbbcfc15e 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -29,6 +29,7 @@ let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" let q_with_bindings = Pcoq.Gram.entry_create "tactic:q_with_bindings" let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" +let q_destruction_arg = Pcoq.Gram.entry_create "tactic:q_destruction_arg" let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" diff --git a/src/tac2entries.mli b/src/tac2entries.mli index dde877666a..581d04d8cc 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -64,6 +64,7 @@ val q_bindings : bindings Pcoq.Gram.entry val q_with_bindings : bindings Pcoq.Gram.entry val q_intropattern : intro_pattern Pcoq.Gram.entry val q_intropatterns : intro_pattern list located Pcoq.Gram.entry +val q_destruction_arg : destruction_arg Pcoq.Gram.entry val q_induction_clause : induction_clause Pcoq.Gram.entry val q_rewriting : rewriting Pcoq.Gram.entry val q_clause : clause Pcoq.Gram.entry diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index a284c1e756..577fe8edfe 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -68,11 +68,13 @@ type clause = clause_r located type constr_with_bindings = (Constrexpr.constr_expr * bindings) located -type destruction_arg = +type destruction_arg_r = | QElimOnConstr of constr_with_bindings | QElimOnIdent of Id.t located | QElimOnAnonHyp of int located +type destruction_arg = destruction_arg_r located + type induction_clause_r = { indcl_arg : destruction_arg; indcl_eqn : intro_pattern_naming option; diff --git a/src/tac2quote.ml b/src/tac2quote.ml index d38d7414fe..ed4cef2e2a 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -191,7 +191,7 @@ let of_clause (loc, cl) = std_proj "on_concl", concl; ]) -let of_destruction_arg ?loc = function +let of_destruction_arg (loc, arg) = match arg with | QElimOnConstr c -> let arg = thunk (of_constr_with_bindings c) in std_constructor ?loc "ElimOnConstr" [arg] @@ -199,7 +199,7 @@ let of_destruction_arg ?loc = function | QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] let of_induction_clause (loc, cl) = - let arg = of_destruction_arg ?loc cl.indcl_arg in + let arg = of_destruction_arg cl.indcl_arg in let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in let in_ = of_option ?loc of_clause cl.indcl_in in diff --git a/src/tac2quote.mli b/src/tac2quote.mli index c3374ac24e..875230b7e3 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -46,6 +46,8 @@ val of_intro_patterns : intro_pattern list located -> raw_tacexpr val of_clause : clause -> raw_tacexpr +val of_destruction_arg : destruction_arg -> raw_tacexpr + val of_induction_clause : induction_clause -> raw_tacexpr val of_rewriting : rewriting -> raw_tacexpr diff --git a/theories/Notations.v b/theories/Notations.v index 5ed47336ad..ad89bc5cfc 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -383,6 +383,12 @@ Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. Ltac2 Notation reflexivity := Std.reflexivity (). +Ltac2 symmetry0 cl := + Std.symmetry (default_on_concl cl). + +Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. +Ltac2 Notation symmetry := symmetry. + Ltac2 Notation assumption := Std.assumption (). Ltac2 Notation etransitivity := Std.etransitivity (). @@ -412,3 +418,20 @@ end. Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. Ltac2 Notation subst := subst. + +Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := + Std.discriminate false arg. + +Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := + Std.discriminate true arg. + +Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection false ipat arg. + +Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection true ipat arg. + +(** Congruence *) + +Ltac2 f_equal0 () := ltac1:(f_equal). +Ltac2 Notation f_equal := f_equal0 (). -- cgit v1.2.3 From ac3bb720d4ec04aa670845352df1d8b8885f865e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 22:42:33 +0200 Subject: Notation for "clear - ids". --- theories/Notations.v | 1 + 1 file changed, 1 insertion(+) diff --git a/theories/Notations.v b/theories/Notations.v index ad89bc5cfc..136ca871c2 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -401,6 +401,7 @@ Ltac2 clear0 ids := match ids with end. Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. +Ltac2 Notation "clear" "-" ids(list1(ident)) := Std.keep ids. Ltac2 Notation clear := clear. Ltac2 Notation refine := Control.refine. -- cgit v1.2.3 From ada4c3aadb5c6b1870c2bf962ef9e1b07cc4bb05 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Sep 2017 23:54:30 +0200 Subject: ML bindings of auto-related tactics. --- src/tac2stdlib.ml | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2tactics.ml | 30 +++++++++++++++++++++++++ src/tac2tactics.mli | 15 +++++++++++++ theories/Std.v | 16 ++++++++++++++ 4 files changed, 125 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 6dcb3f15fb..ed0e6aafd3 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -159,6 +159,17 @@ let to_rewriting = function (orient, repeat, c) | _ -> assert false +let to_debug = function +| ValInt 0 -> Hints.Off +| ValInt 1 -> Hints.Info +| ValInt 2 -> Hints.Debug +| _ -> assert false + +let to_strategy = function +| ValInt 0 -> Class_tactics.Bfs +| ValInt 1 -> Class_tactics.Dfs +| _ -> assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -200,6 +211,13 @@ let define_prim4 name tac = in Tac2env.define_primitive (pname name) tac +let define_prim5 name tac = + let tac bt arg = match arg with + | [x; y; z; u; v] -> lift (tac bt x y z u v) + | _ -> assert false + in + Tac2env.define_primitive (pname name) tac + (** Tactics from Tacexpr *) let () = define_prim2 "tac_intros" begin fun _ ev ipat -> @@ -608,3 +626,49 @@ let () = define_prim1 "tac_subst" begin fun _ ids -> end let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) + +(** Auto *) + +let () = define_prim3 "tac_trivial" begin fun bt dbg lems dbs -> + let dbg = to_debug dbg in + let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let lems = Value.to_list map lems in + let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in + Tac2tactics.trivial dbg lems dbs +end + +let () = define_prim5 "tac_eauto" begin fun bt dbg n p lems dbs -> + let dbg = to_debug dbg in + let n = Value.to_option Value.to_int n in + let p = Value.to_option Value.to_int p in + let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let lems = Value.to_list map lems in + let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in + Tac2tactics.eauto dbg n p lems dbs +end + +let () = define_prim4 "tac_auto" begin fun bt dbg n lems dbs -> + let dbg = to_debug dbg in + let n = Value.to_option Value.to_int n in + let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let lems = Value.to_list map lems in + let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in + Tac2tactics.auto dbg n lems dbs +end + +let () = define_prim4 "tac_newauto" begin fun bt dbg n lems dbs -> + let dbg = to_debug dbg in + let n = Value.to_option Value.to_int n in + let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let lems = Value.to_list map lems in + let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in + Tac2tactics.new_auto dbg n lems dbs +end + +let () = define_prim4 "tac_typeclasses_eauto" begin fun bt b str n dbs -> + let b = Value.to_bool b in + let str = to_strategy str in + let n = Value.to_option Value.to_int n in + let dbs = Value.to_list Value.to_ident dbs in + Tac2tactics.typeclasses_eauto b str n dbs +end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 5b35d53be4..b35e26c89e 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -216,3 +216,33 @@ let autorewrite ~all by ids cl = match by with | None -> Autorewrite.auto_multi_rewrite ?conds ids cl | Some by -> Autorewrite.auto_multi_rewrite_with ?conds by ids cl + +(** Auto *) + +let trivial debug lems dbs = + let lems = List.map delayed_of_tactic lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_trivial ~debug lems dbs + +let auto debug n lems dbs = + let lems = List.map delayed_of_tactic lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_auto ~debug n lems dbs + +let new_auto debug n lems dbs = + let make_depth n = snd (Eauto.make_dimension n None) in + let lems = List.map delayed_of_tactic lems in + match dbs with + | None -> Auto.new_full_auto ~debug (make_depth n) lems + | Some dbs -> + let dbs = List.map Id.to_string dbs in + Auto.new_auto ~debug (make_depth n) lems dbs + +let eauto debug n p lems dbs = + let lems = List.map delayed_of_tactic lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs + +let typeclasses_eauto only_classes strategy depth dbs = + let dbs = List.map Id.to_string dbs in + Class_tactics.typeclasses_eauto ~only_classes ~strategy ~depth dbs diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 1c76bd9648..4369919d31 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -84,3 +84,18 @@ val discriminate : evars_flag -> destruction_arg option -> unit tactic val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic val autorewrite : all:bool -> unit tactic option -> Id.t list -> clause -> unit tactic + +val trivial : Hints.debug -> constr tactic list -> Id.t list option -> + unit Proofview.tactic + +val auto : Hints.debug -> int option -> constr tactic list -> + Id.t list option -> unit Proofview.tactic + +val new_auto : Hints.debug -> int option -> constr tactic list -> + Id.t list option -> unit Proofview.tactic + +val eauto : Hints.debug -> int option -> int option -> constr tactic list -> + Id.t list option -> unit Proofview.tactic + +val typeclasses_eauto : bool -> Class_tactics.search_strategy -> int option -> + Id.t list -> unit Proofview.tactic diff --git a/theories/Std.v b/theories/Std.v index 2fa2c34da6..b667258aa2 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -211,3 +211,19 @@ Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> cl Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". + +(** auto *) + +Ltac2 Type debug := [ Off | Info | Debug ]. + +Ltac2 Type strategy := [ BFS | DFS ]. + +Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". + +Ltac2 @ external auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_auto". + +Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_newauto". + +Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". + +Ltac2 @ external typeclasses_eauto : bool -> strategy -> int option -> ident list -> unit := "ltac2" "tac_typeclasses_eauto". -- cgit v1.2.3 From ebe95a28cf012aff33eb5ce167be6520e6643cfd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 00:35:49 +0200 Subject: More static invariants for typeclass_eauto. --- src/tac2stdlib.ml | 7 +++---- src/tac2tactics.ml | 10 ++++++++-- src/tac2tactics.mli | 4 ++-- theories/Std.v | 2 +- 4 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index ed0e6aafd3..b64aac3559 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -665,10 +665,9 @@ let () = define_prim4 "tac_newauto" begin fun bt dbg n lems dbs -> Tac2tactics.new_auto dbg n lems dbs end -let () = define_prim4 "tac_typeclasses_eauto" begin fun bt b str n dbs -> - let b = Value.to_bool b in +let () = define_prim3 "tac_typeclasses_eauto" begin fun bt str n dbs -> let str = to_strategy str in let n = Value.to_option Value.to_int n in - let dbs = Value.to_list Value.to_ident dbs in - Tac2tactics.typeclasses_eauto b str n dbs + let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in + Tac2tactics.typeclasses_eauto str n dbs end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index b35e26c89e..6cf8f24f27 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -243,6 +243,12 @@ let eauto debug n p lems dbs = let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs -let typeclasses_eauto only_classes strategy depth dbs = - let dbs = List.map Id.to_string dbs in +let typeclasses_eauto strategy depth dbs = + let only_classes, dbs = match dbs with + | None -> + true, [Hints.typeclasses_db] + | Some dbs -> + let dbs = List.map Id.to_string dbs in + false, dbs + in Class_tactics.typeclasses_eauto ~only_classes ~strategy ~depth dbs diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 4369919d31..e0cd77096b 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -97,5 +97,5 @@ val new_auto : Hints.debug -> int option -> constr tactic list -> val eauto : Hints.debug -> int option -> int option -> constr tactic list -> Id.t list option -> unit Proofview.tactic -val typeclasses_eauto : bool -> Class_tactics.search_strategy -> int option -> - Id.t list -> unit Proofview.tactic +val typeclasses_eauto : Class_tactics.search_strategy -> int option -> + Id.t list option -> unit Proofview.tactic diff --git a/theories/Std.v b/theories/Std.v index b667258aa2..5201fa819d 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -226,4 +226,4 @@ Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> iden Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". -Ltac2 @ external typeclasses_eauto : bool -> strategy -> int option -> ident list -> unit := "ltac2" "tac_typeclasses_eauto". +Ltac2 @ external typeclasses_eauto : strategy -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". -- cgit v1.2.3 From da28b6e65d9b9a74c277cb15055131c8a151bb72 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 00:42:22 +0200 Subject: Quotations for auto-related tactics. --- src/g_ltac2.ml4 | 11 ++++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 6 +++++ src/tac2quote.ml | 4 ++++ src/tac2quote.mli | 2 ++ theories/Notations.v | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++ theories/Std.v | 2 +- 9 files changed, 92 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index be7f830605..67254d0781 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -368,7 +368,8 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_destruction_arg q_reference q_with_bindings q_constr_matching; + q_destruction_arg q_reference q_with_bindings q_constr_matching + q_hintdb; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -664,6 +665,14 @@ GEXTEND Gram q_strategy_flag: [ [ flag = strategy_flag -> flag ] ] ; + hintdb: + [ [ "*" -> Loc.tag ~loc:!@loc @@ QHintAll + | l = LIST1 ident_or_anti -> Loc.tag ~loc:!@loc @@ QHintDbs l + ] ] + ; + q_hintdb: + [ [ db = hintdb -> db ] ] + ; match_pattern: [ [ IDENT "context"; id = OPT Prim.ident; "["; pat = Constr.lconstr_pattern; "]" -> (Some id, pat) diff --git a/src/tac2core.ml b/src/tac2core.ml index 867c9ae806..a735dd19d9 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1137,6 +1137,7 @@ let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruc let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting let () = add_expr_scope "clause" q_clause Tac2quote.of_clause +let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag diff --git a/src/tac2entries.ml b/src/tac2entries.ml index afbbcfc15e..121841e8dc 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -38,6 +38,7 @@ let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" let q_reference = Pcoq.Gram.entry_create "tactic:q_reference" let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" +let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 581d04d8cc..91e2a683d8 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -73,6 +73,7 @@ val q_occurrences : occurrences Pcoq.Gram.entry val q_reference : Libnames.reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry +val q_hintdb : hintdb Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 577fe8edfe..4bbaf43d8d 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -125,3 +125,9 @@ type constr_match_branch_r = type constr_match_branch = constr_match_branch_r located type constr_matching = constr_match_branch list located + +type hintdb_r = +| QHintAll +| QHintDbs of Id.t located or_anti list + +type hintdb = hintdb_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index ed4cef2e2a..f87985435c 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -305,6 +305,10 @@ let of_strategy_flag (loc, flag) = std_proj "rConst", of_list ?loc of_reference flag.rConst; ]) +let of_hintdb (loc, hdb) = match hdb with +| QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None +| QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) + let pattern_vars pat = let rec aux () accu pat = match pat.CAst.v with | Constrexpr.CPatVar id -> Id.Set.add id accu diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 875230b7e3..b85f3438a3 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -54,6 +54,8 @@ val of_rewriting : rewriting -> raw_tacexpr val of_occurrences : occurrences -> raw_tacexpr +val of_hintdb : hintdb -> raw_tacexpr + val of_reference : Libnames.reference or_anti -> raw_tacexpr val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr diff --git a/theories/Notations.v b/theories/Notations.v index 136ca871c2..4cb4f32682 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -432,6 +432,72 @@ Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropat Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= Std.injection true ipat arg. +(** Auto *) + +Ltac2 default_db dbs := match dbs with +| None => Some [] +| Some dbs => + match dbs with + | None => None + | Some l => Some l + end +end. + +Ltac2 default_using use := match use with +| None => [] +| Some use => use +end. + +Ltac2 trivial0 use dbs := + let dbs := default_db dbs in + let use := default_using use in + Std.trivial Std.Off use dbs. + +Ltac2 Notation "trivial" + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := trivial0 use dbs. + +Ltac2 Notation trivial := trivial. + +Ltac2 auto0 n use dbs := + let dbs := default_db dbs in + let use := default_using use in + Std.auto Std.Off n use dbs. + +Ltac2 Notation "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := auto0 n use dbs. + +Ltac2 Notation auto := auto. + +Ltac2 new_eauto0 n use dbs := + let dbs := default_db dbs in + let use := default_using use in + Std.new_auto Std.Off n use dbs. + +Ltac2 Notation "new" "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := new_eauto0 n use dbs. + +Ltac2 eauto0 n p use dbs := + let dbs := default_db dbs in + let use := default_using use in + Std.eauto Std.Off n p use dbs. + +Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := eauto0 n p use dbs. + +Ltac2 Notation eauto := eauto. + +Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) p(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto Std.DFS n dbs. + +Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) p(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto Std.BFS n dbs. + +Ltac2 Notation typeclasses_eauto := typeclasses_eauto. + (** Congruence *) Ltac2 f_equal0 () := ltac1:(f_equal). diff --git a/theories/Std.v b/theories/Std.v index 5201fa819d..79a7be1d63 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -216,7 +216,7 @@ Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". Ltac2 Type debug := [ Off | Info | Debug ]. -Ltac2 Type strategy := [ BFS | DFS ]. +Ltac2 Type strategy := [ BFS | DFS ]. Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". -- cgit v1.2.3 From 9a3853fe872e200ed1b34319f6ff0f85a171a434 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 01:07:04 +0200 Subject: Fixup grammar of typeclasses_eauto. --- theories/Notations.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/theories/Notations.v b/theories/Notations.v index 4cb4f32682..e7fc43c0ee 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -490,10 +490,10 @@ Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) Ltac2 Notation eauto := eauto. -Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) p(opt(tactic(0))) +Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto Std.DFS n dbs. -Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) p(opt(tactic(0))) +Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto Std.BFS n dbs. Ltac2 Notation typeclasses_eauto := typeclasses_eauto. -- cgit v1.2.3 From 4a8399e62dd4bdf5876e714910dd2c7cb433dfda Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 01:29:21 +0200 Subject: Typeclasses_eauto strategy is now optional. --- src/tac2stdlib.ml | 2 +- src/tac2tactics.ml | 2 +- src/tac2tactics.mli | 2 +- theories/Notations.v | 4 ++-- theories/Std.v | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index b64aac3559..a0eb0d60e5 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -666,7 +666,7 @@ let () = define_prim4 "tac_newauto" begin fun bt dbg n lems dbs -> end let () = define_prim3 "tac_typeclasses_eauto" begin fun bt str n dbs -> - let str = to_strategy str in + let str = Value.to_option to_strategy str in let n = Value.to_option Value.to_int n in let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in Tac2tactics.typeclasses_eauto str n dbs diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 6cf8f24f27..447f602f7a 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -251,4 +251,4 @@ let typeclasses_eauto strategy depth dbs = let dbs = List.map Id.to_string dbs in false, dbs in - Class_tactics.typeclasses_eauto ~only_classes ~strategy ~depth dbs + Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index e0cd77096b..78d421303a 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -97,5 +97,5 @@ val new_auto : Hints.debug -> int option -> constr tactic list -> val eauto : Hints.debug -> int option -> int option -> constr tactic list -> Id.t list option -> unit Proofview.tactic -val typeclasses_eauto : Class_tactics.search_strategy -> int option -> +val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> Id.t list option -> unit Proofview.tactic diff --git a/theories/Notations.v b/theories/Notations.v index e7fc43c0ee..5fdb4ec8af 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -491,10 +491,10 @@ Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) Ltac2 Notation eauto := eauto. Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) - dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto Std.DFS n dbs. + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto None n dbs. Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) - dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto Std.BFS n dbs. + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto (Some Std.BFS) n dbs. Ltac2 Notation typeclasses_eauto := typeclasses_eauto. diff --git a/theories/Std.v b/theories/Std.v index 79a7be1d63..b63c2eaa41 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -226,4 +226,4 @@ Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> iden Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". -Ltac2 @ external typeclasses_eauto : strategy -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". +Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". -- cgit v1.2.3 From ca40f89c7be05253ea04585ac9ce068aa4744ae9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 01:39:51 +0200 Subject: A few more notations. --- theories/Notations.v | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/theories/Notations.v b/theories/Notations.v index 5fdb4ec8af..75abb2f1cd 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -389,6 +389,8 @@ Ltac2 symmetry0 cl := Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. Ltac2 Notation symmetry := symmetry. +Ltac2 Notation "revert" ids(list1(ident)) := Std.revert ids. + Ltac2 Notation assumption := Std.assumption (). Ltac2 Notation etransitivity := Std.etransitivity (). @@ -422,9 +424,11 @@ Ltac2 Notation subst := subst. Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := Std.discriminate false arg. +Ltac2 Notation discriminate := discriminate. Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := Std.discriminate true arg. +Ltac2 Notation ediscriminate := ediscriminate. Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= Std.injection false ipat arg. -- cgit v1.2.3 From 3e71c616fdafd86652bf9e14505ae1379a6f37bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 12:23:29 +0200 Subject: Binding the inversion family of tactics. --- src/tac2stdlib.ml | 26 ++++++++++++++++++++------ src/tac2tactics.ml | 29 +++++++++++++++++++++++++++++ src/tac2tactics.mli | 2 ++ theories/Notations.v | 18 ++++++++++++++++++ theories/Std.v | 8 ++++++++ 5 files changed, 77 insertions(+), 6 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index a0eb0d60e5..03141805ef 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -128,9 +128,9 @@ let to_destruction_arg = function | ValBlk (0, [| c |]) -> (** FIXME: lost backtrace *) let c = thaw [] c >>= fun c -> return (to_constr_with_bindings c) in - ElimOnConstr c -| ValBlk (1, [| id |]) -> ElimOnIdent (Loc.tag (Value.to_ident id)) -| ValBlk (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) + None, ElimOnConstr c +| ValBlk (1, [| id |]) -> None, ElimOnIdent (Loc.tag (Value.to_ident id)) +| ValBlk (2, [| n |]) -> None, ElimOnAnonHyp (Value.to_int n) | _ -> assert false let to_induction_clause = function @@ -139,7 +139,7 @@ let to_induction_clause = function let eqn = Value.to_option (fun p -> Loc.tag (to_intro_pattern_naming p)) eqn in let as_ = Value.to_option (fun p -> Loc.tag (to_or_and_intro_pattern p)) as_ in let in_ = Value.to_option to_clause in_ in - ((None, arg), eqn, as_, in_) + (arg, eqn, as_, in_) | _ -> assert false @@ -170,6 +170,12 @@ let to_strategy = function | ValInt 1 -> Class_tactics.Dfs | _ -> assert false +let to_inversion_kind = function +| ValInt 0 -> Misctypes.SimpleInversion +| ValInt 1 -> Misctypes.FullInversion +| ValInt 2 -> Misctypes.FullInversionClear +| _ -> assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -470,6 +476,14 @@ let () = define_prim4 "tac_rewrite" begin fun bt ev rw cl by -> Tac2tactics.rewrite ev rw cl by end +let () = define_prim4 "tac_inversion" begin fun bt knd arg pat ids -> + let knd = to_inversion_kind knd in + let arg = to_destruction_arg arg in + let pat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) pat in + let ids = Value.to_option (fun l -> Value.to_list Value.to_ident l) ids in + Tac2tactics.inversion knd arg pat ids +end + (** Tactics from coretactics *) let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity @@ -592,14 +606,14 @@ end let () = define_prim2 "tac_discriminate" begin fun _ ev arg -> let ev = Value.to_bool ev in - let arg = Value.to_option (fun arg -> None, to_destruction_arg arg) arg in + let arg = Value.to_option to_destruction_arg arg in Tac2tactics.discriminate ev arg end let () = define_prim3 "tac_injection" begin fun _ ev ipat arg -> let ev = Value.to_bool ev in let ipat = Value.to_option to_intro_patterns ipat in - let arg = Value.to_option (fun arg -> None, to_destruction_arg arg) arg in + let arg = Value.to_option to_destruction_arg arg in Tac2tactics.injection ev ipat arg end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 447f602f7a..b069e57235 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -252,3 +252,32 @@ let typeclasses_eauto strategy depth dbs = false, dbs in Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs + +(** Inversion *) + +let inversion knd arg pat ids = + let ids = match ids with + | None -> [] + | Some l -> l + in + begin match pat with + | None -> Proofview.tclUNIT None + | Some (_, IntroAction (IntroOrAndPattern p)) -> + Proofview.tclUNIT (Some (Loc.tag p)) + | Some _ -> + Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") + end >>= fun pat -> + let inversion _ arg = + begin match arg with + | None -> assert false + | Some (_, ElimOnAnonHyp n) -> + Inv.inv_clause knd pat ids (AnonHyp n) + | Some (_, ElimOnIdent (_, id)) -> + Inv.inv_clause knd pat ids (NamedHyp id) + | Some (_, ElimOnConstr c) -> + let anon = Loc.tag @@ IntroNaming IntroAnonymous in + Tactics.specialize c (Some anon) >>= fun () -> + Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) + end + in + on_destruction_arg inversion true (Some arg) diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 78d421303a..8b466cd529 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -99,3 +99,5 @@ val eauto : Hints.debug -> int option -> int option -> constr tactic list -> val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> Id.t list option -> unit Proofview.tactic + +val inversion : inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic diff --git a/theories/Notations.v b/theories/Notations.v index 75abb2f1cd..8a3e769d12 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -298,6 +298,24 @@ Ltac2 Notation "edestruct" use(thunk(opt(seq("using", constr, with_bindings)))) := destruct0 true ic use. +Ltac2 Notation "simple" "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.SimpleInversion arg pat ids. + +Ltac2 Notation "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversion arg pat ids. + +Ltac2 Notation "inversion_clear" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversionClear arg pat ids. + Ltac2 default_on_concl cl := match cl with | None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } diff --git a/theories/Std.v b/theories/Std.v index b63c2eaa41..02bc4ff450 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -106,6 +106,12 @@ Ltac2 Type rewriting := { Ltac2 Type evar_flag := bool. Ltac2 Type advanced_flag := bool. +Ltac2 Type inversion_kind := [ +| SimpleInversion +| FullInversion +| FullInversionClear +]. + (** Standard, built-in tactics. See Ltac1 for documentation. *) Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". @@ -197,6 +203,8 @@ Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". +Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern option -> ident list option -> unit := "ltac2" "tac_inversion". + (** coretactics *) (** extratactics *) -- cgit v1.2.3 From 2b0e0ad1062ad49c8bd7d4a7d183fe0119f81803 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 15:39:04 +0200 Subject: Introducing quotations for move locations. --- src/g_ltac2.ml4 | 12 +++++++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 8 ++++++++ src/tac2quote.ml | 6 ++++++ src/tac2quote.mli | 2 ++ theories/Std.v | 7 +++++++ 8 files changed, 37 insertions(+), 1 deletion(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 67254d0781..5c285010e9 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -369,7 +369,7 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching - q_hintdb; + q_hintdb q_move_location; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -692,6 +692,16 @@ GEXTEND Gram q_constr_matching: [ [ m = match_list -> m ] ] ; + move_location: + [ [ "at"; IDENT "top" -> Loc.tag ~loc:!@loc @@ QMoveFirst + | "at"; IDENT "bottom" -> Loc.tag ~loc:!@loc @@ QMoveLast + | IDENT "after"; id = ident_or_anti -> Loc.tag ~loc:!@loc @@ QMoveAfter id + | IDENT "before"; id = ident_or_anti -> Loc.tag ~loc:!@loc @@ QMoveBefore id + ] ] + ; + q_move_location: + [ [ mv = move_location -> mv ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index a735dd19d9..37f1c99b15 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1142,6 +1142,7 @@ let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference +let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 121841e8dc..9fd03ff5aa 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -39,6 +39,7 @@ let q_reference = Pcoq.Gram.entry_create "tactic:q_reference" let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" +let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 91e2a683d8..dda1653593 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -74,6 +74,7 @@ val q_reference : Libnames.reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry val q_hintdb : hintdb Pcoq.Gram.entry +val q_move_location : move_location Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 4bbaf43d8d..7d02022e07 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -131,3 +131,11 @@ type hintdb_r = | QHintDbs of Id.t located or_anti list type hintdb = hintdb_r located + +type move_location_r = +| QMoveAfter of Id.t located or_anti +| QMoveBefore of Id.t located or_anti +| QMoveFirst +| QMoveLast + +type move_location = move_location_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index f87985435c..f14612d58f 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -364,3 +364,9 @@ let of_constr_matching (loc, m) = constructor ?loc (pattern_core "ConstrMatchContext") [pat; e] in of_list ?loc map m + +let of_move_location (loc, mv) = match mv with +| QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] +| QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] +| QMoveFirst -> std_constructor ?loc "MoveFirst" [] +| QMoveLast -> std_constructor ?loc "MoveLast" [] diff --git a/src/tac2quote.mli b/src/tac2quote.mli index b85f3438a3..db2fda3831 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -56,6 +56,8 @@ val of_occurrences : occurrences -> raw_tacexpr val of_hintdb : hintdb -> raw_tacexpr +val of_move_location : move_location -> raw_tacexpr + val of_reference : Libnames.reference or_anti -> raw_tacexpr val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr diff --git a/theories/Std.v b/theories/Std.v index 02bc4ff450..3f98bdbaab 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -106,6 +106,13 @@ Ltac2 Type rewriting := { Ltac2 Type evar_flag := bool. Ltac2 Type advanced_flag := bool. +Ltac2 Type move_location := [ +| MoveAfter (ident) +| MoveBefore (ident) +| MoveFirst +| MoveLast +]. + Ltac2 Type inversion_kind := [ | SimpleInversion | FullInversion -- cgit v1.2.3 From c38e196fc175aaca2268f73107c9658c7af7d9fc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 15:59:42 +0200 Subject: Binding move and intro. --- src/tac2stdlib.ml | 20 ++++++++++++++++++++ theories/Notations.v | 5 +++++ theories/Std.v | 4 ++++ 3 files changed, 29 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 03141805ef..1762952e55 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -176,6 +176,13 @@ let to_inversion_kind = function | ValInt 2 -> Misctypes.FullInversionClear | _ -> assert false +let to_move_location = function +| ValInt 0 -> MoveFirst +| ValInt 1 -> MoveLast +| ValBlk (0, [|id|]) -> MoveAfter (Value.to_ident id) +| ValBlk (1, [|id|]) -> MoveBefore (Value.to_ident id) +| _ -> assert false + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -488,6 +495,19 @@ end let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity +let () = define_prim2 "tac_move" begin fun _ id mv -> + let id = Value.to_ident id in + let mv = to_move_location mv in + Tactics.move_hyp id mv +end + +let () = define_prim2 "tac_intro" begin fun _ id mv -> + let id = Value.to_option Value.to_ident id in + let mv = Value.to_option to_move_location mv in + let mv = Option.default MoveLast mv in + Tactics.intro_move id mv +end + (* TACTIC EXTEND exact diff --git a/theories/Notations.v b/theories/Notations.v index 8a3e769d12..9ecca018af 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -399,6 +399,11 @@ Ltac2 exact0 ev c := Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. +Ltac2 Notation "intro" id(opt(ident)) mv(opt(move_location)) := Std.intro id mv. +Ltac2 Notation intro := intro. + +Ltac2 Notation "move" id(ident) mv(move_location) := Std.move id mv. + Ltac2 Notation reflexivity := Std.reflexivity (). Ltac2 symmetry0 cl := diff --git a/theories/Std.v b/theories/Std.v index 3f98bdbaab..a937560b10 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -214,6 +214,10 @@ Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern (** coretactics *) +Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". + +Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". + (** extratactics *) Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". -- cgit v1.2.3 From 68e803063818235acdc6ade35767ee618f88fe89 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 16:27:44 +0200 Subject: The absurd tactic now parses a constr. --- theories/Notations.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Notations.v b/theories/Notations.v index 9ecca018af..743210ae8d 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -435,7 +435,7 @@ Ltac2 Notation refine := Control.refine. Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). -Ltac2 Notation absurd := absurd0. +Ltac2 Notation "absurd" c(thunk(open_constr)) := absurd0 c. Ltac2 subst0 ids := match ids with | [] => Std.subst_all () -- cgit v1.2.3 From fb8142bb2fd84b10f4536fa63c972286365413f8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 16:31:16 +0200 Subject: Export Ltac2.Notations in the Ltac2 entry module. --- theories/Ltac2.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 996236325c..7b2f592ac6 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -18,4 +18,4 @@ Require Ltac2.Control. Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. -Require Ltac2.Notations. +Require Export Ltac2.Notations. -- cgit v1.2.3 From 53c63e43a3daf99cf8bd44498b1c53798a8ba876 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 17:19:41 +0200 Subject: Binding the firstorder tactic. --- src/tac2stdlib.ml | 9 +++++++++ src/tac2tactics.ml | 11 +++++++++++ src/tac2tactics.mli | 2 ++ theories/Notations.v | 22 +++++++++++++++++----- theories/Std.v | 4 ++++ 5 files changed, 43 insertions(+), 5 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 1762952e55..713a5f1b1c 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -705,3 +705,12 @@ let () = define_prim3 "tac_typeclasses_eauto" begin fun bt str n dbs -> let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in Tac2tactics.typeclasses_eauto str n dbs end + +(** Firstorder *) + +let () = define_prim3 "tac_firstorder" begin fun bt tac refs ids -> + let tac = Value.to_option (fun t -> Proofview.tclIGNORE (thaw bt t)) tac in + let refs = Value.to_list Value.to_reference refs in + let ids = Value.to_list Value.to_ident ids in + Tac2tactics.firstorder tac refs ids +end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index b069e57235..dacbb898d3 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -281,3 +281,14 @@ let inversion knd arg pat ids = end in on_destruction_arg inversion true (Some arg) + +(** Firstorder *) + +let firstorder tac refs ids = + let open Ground_plugin in + (** FUCK YOU API *) + let ids = List.map Id.to_string ids in + let tac : unit API.Proofview.tactic option = Obj.magic (tac : unit Proofview.tactic option) in + let refs : API.Globnames.global_reference list = Obj.magic (refs : Globnames.global_reference list) in + let ids : API.Hints.hint_db_name list = Obj.magic (ids : Hints.hint_db_name list) in + (Obj.magic (G_ground.gen_ground_tac true tac refs ids : unit API.Proofview.tactic) : unit Proofview.tactic) diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 8b466cd529..841e8fe762 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -101,3 +101,5 @@ val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> Id.t list option -> unit Proofview.tactic val inversion : inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic + +val firstorder : unit Proofview.tactic option -> global_reference list -> Id.t list -> unit tactic diff --git a/theories/Notations.v b/theories/Notations.v index 743210ae8d..9b39942ca5 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -470,14 +470,14 @@ Ltac2 default_db dbs := match dbs with end end. -Ltac2 default_using use := match use with +Ltac2 default_list use := match use with | None => [] | Some use => use end. Ltac2 trivial0 use dbs := let dbs := default_db dbs in - let use := default_using use in + let use := default_list use in Std.trivial Std.Off use dbs. Ltac2 Notation "trivial" @@ -488,7 +488,7 @@ Ltac2 Notation trivial := trivial. Ltac2 auto0 n use dbs := let dbs := default_db dbs in - let use := default_using use in + let use := default_list use in Std.auto Std.Off n use dbs. Ltac2 Notation "auto" n(opt(tactic(0))) @@ -499,7 +499,7 @@ Ltac2 Notation auto := auto. Ltac2 new_eauto0 n use dbs := let dbs := default_db dbs in - let use := default_using use in + let use := default_list use in Std.new_auto Std.Off n use dbs. Ltac2 Notation "new" "auto" n(opt(tactic(0))) @@ -508,7 +508,7 @@ Ltac2 Notation "new" "auto" n(opt(tactic(0))) Ltac2 eauto0 n p use dbs := let dbs := default_db dbs in - let use := default_using use in + let use := default_list use in Std.eauto Std.Off n p use dbs. Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) @@ -529,3 +529,15 @@ Ltac2 Notation typeclasses_eauto := typeclasses_eauto. Ltac2 f_equal0 () := ltac1:(f_equal). Ltac2 Notation f_equal := f_equal0 (). + +(** Firstorder *) + +Ltac2 firstorder0 tac refs ids := + let refs := default_list refs in + let ids := default_list ids in + Std.firstorder tac refs ids. + +Ltac2 Notation "firstorder" + tac(opt(thunk(tactic))) + refs(opt(seq("using", list1(reference, ",")))) + ids(opt(seq("with", list1(ident)))) := firstorder0 tac refs ids. diff --git a/theories/Std.v b/theories/Std.v index a937560b10..f8b269dce6 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -246,3 +246,7 @@ Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> iden Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". + +(** firstorder *) + +Ltac2 @ external firstorder : (unit -> unit) option -> reference list -> ident list -> unit := "ltac2" "tac_firstorder". -- cgit v1.2.3 From 217bd80b651d2d12b05f74cf21485eb0fea8e3e3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Sep 2017 21:51:59 +0200 Subject: Refine does not evar-normalizes the goal preemptively. --- src/tac2core.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 37f1c99b15..cd39cb6f27 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -734,7 +734,8 @@ end (** (unit -> constr) -> unit *) let () = define1 "refine" begin fun bt c -> let c = thaw bt c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> + let gl = Proofview.Goal.assume gl in Refine.generic_refine ~typecheck:true c gl end >>= fun () -> return v_unit end -- cgit v1.2.3 From e4db6e726b5307c35e99a02cacbd96290e80dd24 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 14:11:00 +0200 Subject: Code factorization. --- src/tac2core.ml | 7 +------ src/tac2quote.mli | 2 ++ 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index cd39cb6f27..2c9226adae 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1012,11 +1012,6 @@ let scope_fail s args = let q_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) -let rthunk e = - let loc = Tac2intern.loc_of_tacexpr e in - let var = [Loc.tag ?loc @@ CPatVar Anonymous, Some (Loc.tag ?loc @@ CTypRef (AbsKn (Other Core.t_unit), []))] in - Loc.tag ?loc @@ CTacFun (var, e) - let add_generic_scope s entry arg = let parse = function | [] -> @@ -1118,7 +1113,7 @@ end let () = add_scope "thunk" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let act e = rthunk (act e) in + let act e = Tac2quote.thunk (act e) in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "thunk" arg end diff --git a/src/tac2quote.mli b/src/tac2quote.mli index db2fda3831..9f42c60042 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -20,6 +20,8 @@ open Tac2expr val constructor : ?loc:Loc.t -> ltac_constructor -> raw_tacexpr list -> raw_tacexpr +val thunk : raw_tacexpr -> raw_tacexpr + val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr val of_int : int located -> raw_tacexpr -- cgit v1.2.3 From a36ec5034231b2f879538bcb5c8401d03f2ad04f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 18:23:54 +0200 Subject: Introducing abstract data representations. --- src/tac2ffi.ml | 76 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2ffi.mli | 23 +++++++++++++++++ 2 files changed, 99 insertions(+) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 4ed0096787..6a60562d1a 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -12,6 +12,12 @@ open Genarg open Tac2dyn open Tac2expr +type 'a repr = { + r_of : 'a -> valexpr; + r_to : valexpr -> 'a; + r_id : bool; +} + (** Dynamic tags *) let val_exn = Val.create "exn" @@ -44,11 +50,23 @@ let to_unit = function | ValInt 0 -> () | _ -> assert false +let unit = { + r_of = of_unit; + r_to = to_unit; + r_id = false; +} + let of_int n = ValInt n let to_int = function | ValInt n -> n | _ -> assert false +let int = { + r_of = of_int; + r_to = to_int; + r_id = false; +} + let of_bool b = if b then ValInt 0 else ValInt 1 let to_bool = function @@ -56,16 +74,34 @@ let to_bool = function | ValInt 1 -> false | _ -> assert false +let bool = { + r_of = of_bool; + r_to = to_bool; + r_id = false; +} + let of_char n = ValInt (Char.code n) let to_char = function | ValInt n -> Char.chr n | _ -> assert false +let char = { + r_of = of_char; + r_to = to_char; + r_id = false; +} + let of_string s = ValStr s let to_string = function | ValStr s -> s | _ -> assert false +let string = { + r_of = of_string; + r_to = to_string; + r_id = false; +} + let rec of_list f = function | [] -> ValInt 0 | x :: l -> ValBlk (0, [| f x; of_list f l |]) @@ -75,6 +111,12 @@ let rec to_list f = function | ValBlk (0, [|v; vl|]) -> f v :: to_list f vl | _ -> assert false +let list r = { + r_of = (fun l -> of_list r.r_of l); + r_to = (fun l -> to_list r.r_to l); + r_id = false; +} + let of_ext tag c = ValExt (tag, c) @@ -82,14 +124,23 @@ let to_ext tag = function | ValExt (tag', e) -> extract_val tag tag' e | _ -> assert false +let repr_ext tag = { + r_of = (fun e -> of_ext tag e); + r_to = (fun e -> to_ext tag e); + r_id = false; +} + let of_constr c = of_ext val_constr c let to_constr c = to_ext val_constr c +let constr = repr_ext val_constr let of_ident c = of_ext val_ident c let to_ident c = to_ext val_ident c +let ident = repr_ext val_ident let of_pattern c = of_ext val_pattern c let to_pattern c = to_ext val_pattern c +let pattern = repr_ext val_pattern let internal_err = let open Names in @@ -108,6 +159,12 @@ let to_exn c = match c with (Tac2interp.LtacError (kn, c, []), Exninfo.null) | _ -> assert false +let exn = { + r_of = of_exn; + r_to = to_exn; + r_id = false; +} + let of_option f = function | None -> ValInt 0 | Some c -> ValBlk (0, [|f c|]) @@ -117,8 +174,15 @@ let to_option f = function | ValBlk (0, [|c|]) -> Some (f c) | _ -> assert false +let option r = { + r_of = (fun l -> of_option r.r_of l); + r_to = (fun l -> to_option r.r_to l); + r_id = false; +} + let of_pp c = of_ext val_pp c let to_pp c = to_ext val_pp c +let pp = repr_ext val_pp let of_tuple cl = ValBlk (0, cl) let to_tuple = function @@ -129,9 +193,15 @@ let of_array f vl = ValBlk (0, Array.map f vl) let to_array f = function | ValBlk (0, vl) -> Array.map f vl | _ -> assert false +let array r = { + r_of = (fun l -> of_array r.r_of l); + r_to = (fun l -> to_array r.r_to l); + r_id = false; +} let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c +let constant = repr_ext val_constant let of_reference = function | VarRef id -> ValBlk (0, [| of_ident id |]) @@ -145,3 +215,9 @@ let to_reference = function | ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) | ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) | _ -> assert false + +let reference = { + r_of = of_reference; + r_to = to_reference; + r_id = false; +} diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index e836319349..db3087534b 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -13,60 +13,83 @@ open Tac2expr (** {5 Ltac2 FFI} *) +type 'a repr = { + r_of : 'a -> valexpr; + r_to : valexpr -> 'a; + r_id : bool; + (** True if the functions above are physical identities. *) +} + (** These functions allow to convert back and forth between OCaml and Ltac2 data representation. The [to_*] functions raise an anomaly whenever the data has not expected shape. *) val of_unit : unit -> valexpr val to_unit : valexpr -> unit +val unit : unit repr val of_int : int -> valexpr val to_int : valexpr -> int +val int : int repr val of_bool : bool -> valexpr val to_bool : valexpr -> bool +val bool : bool repr val of_char : char -> valexpr val to_char : valexpr -> char +val char : char repr val of_string : string -> valexpr val to_string : valexpr -> string +val string : string repr val of_list : ('a -> valexpr) -> 'a list -> valexpr val to_list : (valexpr -> 'a) -> valexpr -> 'a list +val list : 'a repr -> 'a list repr val of_constr : EConstr.t -> valexpr val to_constr : valexpr -> EConstr.t +val constr : EConstr.t repr val of_exn : Exninfo.iexn -> valexpr val to_exn : valexpr -> Exninfo.iexn +val exn : Exninfo.iexn repr val of_ident : Id.t -> valexpr val to_ident : valexpr -> Id.t +val ident : Id.t repr val of_array : ('a -> valexpr) -> 'a array -> valexpr val to_array : (valexpr -> 'a) -> valexpr -> 'a array +val array : 'a repr -> 'a array repr val of_tuple : valexpr array -> valexpr val to_tuple : valexpr -> valexpr array val of_option : ('a -> valexpr) -> 'a option -> valexpr val to_option : (valexpr -> 'a) -> valexpr -> 'a option +val option : 'a repr -> 'a option repr val of_pattern : Pattern.constr_pattern -> valexpr val to_pattern : valexpr -> Pattern.constr_pattern +val pattern : Pattern.constr_pattern repr val of_pp : Pp.t -> valexpr val to_pp : valexpr -> Pp.t +val pp : Pp.t repr val of_constant : Constant.t -> valexpr val to_constant : valexpr -> Constant.t +val constant : Constant.t repr val of_reference : Globnames.global_reference -> valexpr val to_reference : valexpr -> Globnames.global_reference +val reference : Globnames.global_reference repr val of_ext : 'a Val.tag -> 'a -> valexpr val to_ext : 'a Val.tag -> valexpr -> 'a +val repr_ext : 'a Val.tag -> 'a repr (** {5 Dynamic tags} *) -- cgit v1.2.3 From 6985a2001d28ff0850198d8219d7b791a226bdac Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 18:53:07 +0200 Subject: Moving Tac2ffi before Tac2interp. --- src/ltac2_plugin.mlpack | 2 +- src/tac2ffi.ml | 9 +++++++-- src/tac2ffi.mli | 5 +++++ src/tac2interp.ml | 2 +- 4 files changed, 14 insertions(+), 4 deletions(-) diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 92f391a085..00ba5bc58e 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -2,9 +2,9 @@ Tac2dyn Tac2env Tac2print Tac2intern +Tac2ffi Tac2interp Tac2entries -Tac2ffi Tac2quote Tac2core Tac2tactics diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 6a60562d1a..a0c51783ed 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -7,6 +7,7 @@ (************************************************************************) open Util +open Names open Globnames open Genarg open Tac2dyn @@ -42,6 +43,10 @@ match Val.eq tag tag' with | None -> assert false | Some Refl -> v +(** Exception *) + +exception LtacError of KerName.t * valexpr array * backtrace + (** Conversion functions *) let of_unit () = ValInt 0 @@ -148,7 +153,7 @@ let internal_err = (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with -| Tac2interp.LtacError (kn, c, _) -> ValOpn (kn, c) +| LtacError (kn, c, _) -> ValOpn (kn, c) | _ -> ValOpn (internal_err, [|of_ext val_exn c|]) let to_exn c = match c with @@ -156,7 +161,7 @@ let to_exn c = match c with if Names.KerName.equal kn internal_err then to_ext val_exn c.(0) else - (Tac2interp.LtacError (kn, c, []), Exninfo.null) + (LtacError (kn, c, []), Exninfo.null) | _ -> assert false let exn = { diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index db3087534b..2282d34b3a 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -111,3 +111,8 @@ val val_free : Id.Set.t Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] should be put into a value with tag [val_exn]. *) + +(** Exception *) + +exception LtacError of KerName.t * valexpr array * backtrace +(** Ltac2-defined exceptions seen from OCaml side *) diff --git a/src/tac2interp.ml b/src/tac2interp.ml index b58ce6b851..e79ce87268 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -14,7 +14,7 @@ open Names open Proofview.Notations open Tac2expr -exception LtacError of KerName.t * valexpr array * backtrace +exception LtacError = Tac2ffi.LtacError let empty_environment = { env_ist = Id.Map.empty; -- cgit v1.2.3 From 841c4a028b5cf7e3cfff6b91a33db38a4b8d54df Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 18:55:27 +0200 Subject: The interp_app function now takes a closure as an argument. --- src/tac2core.ml | 5 +++-- src/tac2ffi.ml | 12 ++++++++++++ src/tac2ffi.mli | 4 ++++ src/tac2interp.ml | 9 ++++----- src/tac2interp.mli | 2 +- src/tac2stdlib.ml | 2 +- 6 files changed, 25 insertions(+), 9 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 2c9226adae..5e475e1d4a 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -103,7 +103,7 @@ let err_matchfailure bt = (** Helper functions *) -let thaw bt f = Tac2interp.interp_app bt f [v_unit] +let thaw bt f = Tac2interp.interp_app bt (Value.to_closure f) [v_unit] let throw bt e = Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) let set_bt bt e = match e with @@ -615,7 +615,7 @@ end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) let () = define2 "plus" begin fun bt x k -> - Proofview.tclOR (thaw bt x) (fun e -> Tac2interp.interp_app bt k [Value.of_exn e]) + Proofview.tclOR (thaw bt x) (fun e -> Tac2interp.interp_app bt (Value.to_closure k) [Value.of_exn e]) end (** (unit -> 'a) -> 'a *) @@ -741,6 +741,7 @@ let () = define1 "refine" begin fun bt c -> end let () = define2 "with_holes" begin fun bt x f -> + let f = Value.to_closure f in Proofview.tclEVARMAP >>= fun sigma0 -> thaw bt x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index a0c51783ed..c3f535c1bc 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -122,6 +122,18 @@ let list r = { r_id = false; } +let of_closure cls = ValCls cls + +let to_closure = function +| ValCls cls -> cls +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false + +let closure = { + r_of = of_closure; + r_to = to_closure; + r_id = false; +} + let of_ext tag c = ValExt (tag, c) diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 2282d34b3a..fe813b0e35 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -60,6 +60,10 @@ val of_ident : Id.t -> valexpr val to_ident : valexpr -> Id.t val ident : Id.t repr +val of_closure : closure -> valexpr +val to_closure : valexpr -> closure +val closure : closure repr + val of_array : ('a -> valexpr) -> 'a array -> valexpr val to_array : (valexpr -> 'a) -> valexpr -> 'a array val array : 'a repr -> 'a array repr diff --git a/src/tac2interp.ml b/src/tac2interp.ml index e79ce87268..6bee5a0794 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -46,7 +46,7 @@ let rec interp (ist : environment) = function | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - interp_app ist.env_bkt f args + interp_app ist.env_bkt (Tac2ffi.to_closure f) args | GTacLet (false, el, e) -> let fold accu (na, e) = interp ist e >>= fun e -> @@ -97,18 +97,17 @@ let rec interp (ist : environment) = function tpe.Tac2env.ml_interp ist e and interp_app bt f args = match f with -| ValCls { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> +| { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> let rec push ist ids args = match ids, args with | [], [] -> interp ist e - | [], _ :: _ -> interp ist e >>= fun f -> interp_app bt f args + | [], _ :: _ -> + interp ist e >>= fun f -> interp_app bt (Tac2ffi.to_closure f) args | _ :: _, [] -> let cls = { clos_ref = kn; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in return (ValCls cls) | id :: ids, arg :: args -> push (push_name ist id arg) ids args in push { env_ist = ist; env_bkt = FrLtac kn :: bt } ids args -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> - anomaly (str "Unexpected value shape") and interp_case ist e cse0 cse1 = match e with | ValInt n -> interp ist cse0.(n) diff --git a/src/tac2interp.mli b/src/tac2interp.mli index ea7db33b60..ca263b2c4b 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -13,7 +13,7 @@ val empty_environment : environment val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic -val interp_app : backtrace -> valexpr -> valexpr list -> valexpr Proofview.tactic +val interp_app : backtrace -> closure -> valexpr list -> valexpr Proofview.tactic (** {5 Cross-boundary encodings} *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 713a5f1b1c..79af41b7d0 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -18,7 +18,7 @@ module Value = Tac2ffi let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () -let thaw bt f = Tac2interp.interp_app bt f [v_unit] +let thaw bt f = Tac2interp.interp_app bt (Value.to_closure f) [v_unit] let to_pair f g = function | ValBlk (0, [| x; y |]) -> (f x, g y) -- cgit v1.2.3 From f5ed96350ecc947ad4e55be9439cd0d30c68bde0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 19:03:32 +0200 Subject: Parameterizing over parameters in ML functions from Tac2core. --- src/tac2core.ml | 213 ++++++++++++++++++++------------------------------------ src/tac2ffi.ml | 12 ++++ src/tac2ffi.mli | 4 ++ 3 files changed, 93 insertions(+), 136 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 5e475e1d4a..2f349e32af 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -20,6 +20,7 @@ open Proofview.Notations (** Standard values *) module Value = Tac2ffi +open Value let std_core n = KerName.make2 Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) @@ -53,10 +54,6 @@ open Core let v_unit = ValInt 0 -let to_block = function -| ValBlk (_, v) -> v -| _ -> assert false - let of_name c = match c with | Anonymous -> Value.of_option Value.of_ident None | Name id -> Value.of_option Value.of_ident (Some id) @@ -103,7 +100,8 @@ let err_matchfailure bt = (** Helper functions *) -let thaw bt f = Tac2interp.interp_app bt (Value.to_closure f) [v_unit] +let thaw bt f = Tac2interp.interp_app bt f [v_unit] + let throw bt e = Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) let set_bt bt e = match e with @@ -144,111 +142,95 @@ let define0 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> m | _ -> assert false end -let define1 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [x] -> f bt x +let define1 name r0 f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [x] -> f bt (r0.Value.r_to x) | _ -> assert false end -let define2 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [x; y] -> f bt x y +let define2 name r0 r1 f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [x; y] -> f bt (r0.Value.r_to x) (r1.Value.r_to y) | _ -> assert false end -let define3 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [x; y; z] -> f bt x y z +let define3 name r0 r1 r2 f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with +| [x; y; z] -> f bt (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) | _ -> assert false end (** Printing *) -let () = define1 "print" begin fun _ pp -> - wrap_unit (fun () -> Feedback.msg_notice (Value.to_pp pp)) +let () = define1 "print" pp begin fun _ pp -> + wrap_unit (fun () -> Feedback.msg_notice pp) end -let () = define1 "message_of_int" begin fun _ n -> - let n = Value.to_int n in - return (Value.of_pp (int n)) +let () = define1 "message_of_int" int begin fun _ n -> + return (Value.of_pp (Pp.int n)) end -let () = define1 "message_of_string" begin fun _ s -> - let s = Value.to_string s in +let () = define1 "message_of_string" string begin fun _ s -> return (Value.of_pp (str (Bytes.to_string s))) end -let () = define1 "message_of_constr" begin fun bt c -> +let () = define1 "message_of_constr" constr begin fun bt c -> pf_apply bt begin fun env sigma -> - let c = Value.to_constr c in let pp = Printer.pr_econstr_env env sigma c in return (Value.of_pp pp) end end -let () = define1 "message_of_ident" begin fun _ c -> - let c = Value.to_ident c in +let () = define1 "message_of_ident" ident begin fun _ c -> let pp = Id.print c in return (Value.of_pp pp) end -let () = define2 "message_concat" begin fun _ m1 m2 -> - let m1 = Value.to_pp m1 in - let m2 = Value.to_pp m2 in +let () = define2 "message_concat" pp pp begin fun _ m1 m2 -> return (Value.of_pp (Pp.app m1 m2)) end (** Array *) -let () = define2 "array_make" begin fun bt n x -> - let n = Value.to_int n in +let () = define2 "array_make" int valexpr begin fun bt n x -> if n < 0 || n > Sys.max_array_length then throw bt err_outofbounds else wrap (fun () -> ValBlk (0, Array.make n x)) end -let () = define1 "array_length" begin fun _ v -> - let v = to_block v in +let () = define1 "array_length" block begin fun _ v -> return (ValInt (Array.length v)) end -let () = define3 "array_set" begin fun bt v n x -> - let v = to_block v in - let n = Value.to_int n in +let () = define3 "array_set" block int valexpr begin fun bt v n x -> if n < 0 || n >= Array.length v then throw bt err_outofbounds else wrap_unit (fun () -> v.(n) <- x) end -let () = define2 "array_get" begin fun bt v n -> - let v = to_block v in - let n = Value.to_int n in +let () = define2 "array_get" block int begin fun bt v n -> if n < 0 || n >= Array.length v then throw bt err_outofbounds else wrap (fun () -> v.(n)) end (** Ident *) -let () = define2 "ident_equal" begin fun _ id1 id2 -> - let id1 = Value.to_ident id1 in - let id2 = Value.to_ident id2 in +let () = define2 "ident_equal" ident ident begin fun _ id1 id2 -> return (Value.of_bool (Id.equal id1 id2)) end -let () = define1 "ident_to_string" begin fun _ id -> - let id = Value.to_ident id in +let () = define1 "ident_to_string" ident begin fun _ id -> return (Value.of_string (Id.to_string id)) end -let () = define1 "ident_of_string" begin fun _ s -> - let s = Value.to_string s in +let () = define1 "ident_of_string" string begin fun _ s -> let id = try Some (Id.of_string s) with _ -> None in return (Value.of_option Value.of_ident id) end (** Int *) -let () = define2 "int_equal" begin fun _ m n -> - return (Value.of_bool (Value.to_int m == Value.to_int n)) +let () = define2 "int_equal" int int begin fun _ m n -> + return (Value.of_bool (m == n)) end -let binop n f = define2 n begin fun _ m n -> - return (Value.of_int (f (Value.to_int m) (Value.to_int n))) +let binop n f = define2 n int int begin fun _ m n -> + return (Value.of_int (f m m)) end let () = binop "int_compare" Int.compare @@ -256,34 +238,27 @@ let () = binop "int_add" (+) let () = binop "int_sub" (-) let () = binop "int_mul" ( * ) -let () = define1 "int_neg" begin fun _ m -> - return (Value.of_int (~- (Value.to_int m))) +let () = define1 "int_neg" int begin fun _ m -> + return (Value.of_int (~- m)) end (** String *) -let () = define2 "string_make" begin fun bt n c -> - let n = Value.to_int n in - let c = Value.to_char c in +let () = define2 "string_make" int char begin fun bt n c -> if n < 0 || n > Sys.max_string_length then throw bt err_outofbounds else wrap (fun () -> Value.of_string (Bytes.make n c)) end -let () = define1 "string_length" begin fun _ s -> - return (Value.of_int (Bytes.length (Value.to_string s))) +let () = define1 "string_length" string begin fun _ s -> + return (Value.of_int (Bytes.length s)) end -let () = define3 "string_set" begin fun bt s n c -> - let s = Value.to_string s in - let n = Value.to_int n in - let c = Value.to_char c in +let () = define3 "string_set" string int char begin fun bt s n c -> if n < 0 || n >= Bytes.length s then throw bt err_outofbounds else wrap_unit (fun () -> Bytes.set s n c) end -let () = define2 "string_get" begin fun bt s n -> - let s = Value.to_string s in - let n = Value.to_int n in +let () = define2 "string_get" string int begin fun bt s n -> if n < 0 || n >= Bytes.length s then throw bt err_outofbounds else wrap (fun () -> Value.of_char (Bytes.get s n)) end @@ -291,8 +266,7 @@ end (** Terms *) (** constr -> constr *) -let () = define1 "constr_type" begin fun bt c -> - let c = Value.to_constr c in +let () = define1 "constr_type" constr begin fun bt c -> let get_type env sigma = Proofview.V82.wrap_exceptions begin fun () -> let (sigma, t) = Typing.type_of env sigma c in @@ -303,18 +277,15 @@ let () = define1 "constr_type" begin fun bt c -> end (** constr -> constr *) -let () = define2 "constr_equal" begin fun _ c1 c2 -> - let c1 = Value.to_constr c1 in - let c2 = Value.to_constr c2 in +let () = define2 "constr_equal" constr constr begin fun _ c1 c2 -> Proofview.tclEVARMAP >>= fun sigma -> let b = EConstr.eq_constr sigma c1 c2 in Proofview.tclUNIT (Value.of_bool b) end -let () = define1 "constr_kind" begin fun _ c -> +let () = define1 "constr_kind" constr begin fun _ c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> - let c = Value.to_constr c in return begin match EConstr.kind sigma c with | Rel n -> ValBlk (0, [|Value.of_int n|]) @@ -406,7 +377,7 @@ let () = define1 "constr_kind" begin fun _ c -> end end -let () = define1 "constr_make" begin fun _ knd -> +let () = define1 "constr_make" valexpr begin fun _ knd -> let open Constr in let c = match knd with | ValBlk (0, [|n|]) -> @@ -486,8 +457,7 @@ let () = define1 "constr_make" begin fun _ knd -> return (Value.of_constr c) end -let () = define1 "constr_check" begin fun bt c -> - let c = Value.to_constr c in +let () = define1 "constr_check" constr begin fun bt c -> pf_apply bt begin fun env sigma -> try let (sigma, _) = Typing.type_of env sigma c in @@ -499,27 +469,19 @@ let () = define1 "constr_check" begin fun bt c -> end end -let () = define3 "constr_substnl" begin fun _ subst k c -> - let subst = Value.to_list Value.to_constr subst in - let k = Value.to_int k in - let c = Value.to_constr c in +let () = define3 "constr_substnl" (list constr) int constr begin fun _ subst k c -> let ans = EConstr.Vars.substnl subst k c in return (Value.of_constr ans) end -let () = define3 "constr_closenl" begin fun _ ids k c -> - let ids = Value.to_list Value.to_ident ids in - let k = Value.to_int k in - let c = Value.to_constr c in +let () = define3 "constr_closenl" (list ident) int constr begin fun _ ids k c -> let ans = EConstr.Vars.substn_vars k ids c in return (Value.of_constr ans) end (** Patterns *) -let () = define2 "pattern_matches" begin fun bt pat c -> - let pat = Value.to_pattern pat in - let c = Value.to_constr c in +let () = define2 "pattern_matches" pattern constr begin fun bt pat c -> pf_apply bt begin fun env sigma -> let ans = try Some (Constr_matching.matches env sigma pat c) @@ -535,9 +497,7 @@ let () = define2 "pattern_matches" begin fun bt pat c -> end end -let () = define2 "pattern_matches_subterm" begin fun bt pat c -> - let pat = Value.to_pattern pat in - let c = Value.to_constr c in +let () = define2 "pattern_matches_subterm" pattern constr begin fun bt pat c -> let open Constr_matching in let rec of_ans s = match IStream.peek s with | IStream.Nil -> Proofview.tclZERO (err_matchfailure bt) @@ -553,9 +513,7 @@ let () = define2 "pattern_matches_subterm" begin fun bt pat c -> end end -let () = define2 "pattern_matches_vect" begin fun bt pat c -> - let pat = Value.to_pattern pat in - let c = Value.to_constr c in +let () = define2 "pattern_matches_vect" pattern constr begin fun bt pat c -> pf_apply bt begin fun env sigma -> let ans = try Some (Constr_matching.matches env sigma pat c) @@ -571,9 +529,7 @@ let () = define2 "pattern_matches_vect" begin fun bt pat c -> end end -let () = define2 "pattern_matches_subterm_vect" begin fun bt pat c -> - let pat = Value.to_pattern pat in - let c = Value.to_constr c in +let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun bt pat c -> let open Constr_matching in let rec of_ans s = match IStream.peek s with | IStream.Nil -> Proofview.tclZERO (err_matchfailure bt) @@ -589,17 +545,16 @@ let () = define2 "pattern_matches_subterm_vect" begin fun bt pat c -> end end -let () = define2 "pattern_instantiate" begin fun _ ctx c -> - let ctx = EConstr.Unsafe.to_constr (Value.to_constr ctx) in - let c = EConstr.Unsafe.to_constr (Value.to_constr c) in +let () = define2 "pattern_instantiate" constr constr begin fun _ ctx c -> + let ctx = EConstr.Unsafe.to_constr ctx in + let c = EConstr.Unsafe.to_constr c in let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in return (Value.of_constr (EConstr.of_constr ans)) end (** Error *) -let () = define1 "throw" begin fun bt e -> - let (e, info) = Value.to_exn e in +let () = define1 "throw" exn begin fun bt (e, info) -> let e = set_bt bt e in Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) end @@ -607,38 +562,37 @@ end (** Control *) (** exn -> 'a *) -let () = define1 "zero" begin fun bt e -> - let (e, info) = Value.to_exn e in +let () = define1 "zero" exn begin fun bt (e, info) -> let e = set_bt bt e in Proofview.tclZERO ~info e end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) -let () = define2 "plus" begin fun bt x k -> - Proofview.tclOR (thaw bt x) (fun e -> Tac2interp.interp_app bt (Value.to_closure k) [Value.of_exn e]) +let () = define2 "plus" closure closure begin fun bt x k -> + Proofview.tclOR (thaw bt x) (fun e -> Tac2interp.interp_app bt k [Value.of_exn e]) end (** (unit -> 'a) -> 'a *) -let () = define1 "once" begin fun bt f -> +let () = define1 "once" closure begin fun bt f -> Proofview.tclONCE (thaw bt f) end (** (unit -> unit) list -> unit *) -let () = define1 "dispatch" begin fun bt l -> - let l = Value.to_list (fun f -> Proofview.tclIGNORE (thaw bt f)) l in +let () = define1 "dispatch" (list closure) begin fun bt l -> + let l = List.map (fun f -> Proofview.tclIGNORE (thaw bt f)) l in Proofview.tclDISPATCH l >>= fun () -> return v_unit end (** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let () = define3 "extend" begin fun bt lft tac rgt -> - let lft = Value.to_list (fun f -> Proofview.tclIGNORE (thaw bt f)) lft in +let () = define3 "extend" (list closure) closure (list closure) begin fun bt lft tac rgt -> + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw bt f)) lft in let tac = Proofview.tclIGNORE (thaw bt tac) in - let rgt = Value.to_list (fun f -> Proofview.tclIGNORE (thaw bt f)) rgt in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw bt f)) rgt in Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit end (** (unit -> unit) -> unit *) -let () = define1 "enter" begin fun bt f -> +let () = define1 "enter" closure begin fun bt f -> let f = Proofview.tclIGNORE (thaw bt f) in Proofview.tclINDEPENDENT f >>= fun () -> return v_unit end @@ -648,7 +602,7 @@ let e_var = Id.of_string "e" let prm_apply_kont_h = pname "apply_kont" (** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) -let () = define1 "case" begin fun bt f -> +let () = define1 "case" closure begin fun bt f -> Proofview.tclCASE (thaw bt f) >>= begin function | Proofview.Next (x, k) -> let k = { @@ -663,16 +617,13 @@ let () = define1 "case" begin fun bt f -> end (** 'a kont -> exn -> 'a *) -let () = define2 "apply_kont" begin fun bt k e -> - let (e, info) = Value.to_exn e in +let () = define2 "apply_kont" (repr_ext val_kont) exn begin fun bt k (e, info) -> let e = set_bt bt e in - (Value.to_ext Value.val_kont k) (e, info) + k (e, info) end (** int -> int -> (unit -> 'a) -> 'a *) -let () = define3 "focus" begin fun bt i j tac -> - let i = Value.to_int i in - let j = Value.to_int j in +let () = define3 "focus" int int closure begin fun bt i j tac -> Proofview.tclFOCUS i j (thaw bt tac) end @@ -686,8 +637,8 @@ let () = define0 "shelve_unifiable" begin fun _ -> Proofview.shelve_unifiable >>= fun () -> return v_unit end -let () = define1 "new_goal" begin fun bt ev -> - let ev = Evar.unsafe_of_int (Value.to_int ev) in +let () = define1 "new_goal" int begin fun bt ev -> + let ev = Evar.unsafe_of_int ev in Proofview.tclEVARMAP >>= fun sigma -> if Evd.mem sigma ev then Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit @@ -704,8 +655,7 @@ let () = define0 "goal" begin fun bt -> end (** ident -> constr *) -let () = define1 "hyp" begin fun bt id -> - let id = Value.to_ident id in +let () = define1 "hyp" ident begin fun bt id -> pf_apply bt begin fun env _ -> let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in if mem then return (Value.of_constr (EConstr.mkVar id)) @@ -732,7 +682,7 @@ let () = define0 "hyps" begin fun bt -> end (** (unit -> constr) -> unit *) -let () = define1 "refine" begin fun bt c -> +let () = define1 "refine" closure begin fun bt c -> let c = thaw bt c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in @@ -740,8 +690,7 @@ let () = define1 "refine" begin fun bt c -> end >>= fun () -> return v_unit end -let () = define2 "with_holes" begin fun bt x f -> - let f = Value.to_closure f in +let () = define2 "with_holes" closure closure begin fun bt x f -> Proofview.tclEVARMAP >>= fun sigma0 -> thaw bt x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> @@ -749,18 +698,16 @@ let () = define2 "with_holes" begin fun bt x f -> Tacticals.New.tclWITHHOLES false (Tac2interp.interp_app bt f [ans]) sigma end -let () = define1 "progress" begin fun bt f -> +let () = define1 "progress" closure begin fun bt f -> Proofview.tclPROGRESS (thaw bt f) end -let () = define2 "abstract" begin fun bt id f -> - let id = Value.to_option Value.to_ident id in +let () = define2 "abstract" (option ident) closure begin fun bt id f -> Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw bt f)) >>= fun () -> return v_unit end -let () = define2 "time" begin fun bt s f -> - let s = Value.to_option Value.to_string s in +let () = define2 "time" (option string) closure begin fun bt s f -> Proofview.tclTIME s (thaw bt f) end @@ -770,21 +717,17 @@ end (** Fresh *) -let () = define2 "fresh_free_union" begin fun _ set1 set2 -> - let set1 = Value.to_ext Value.val_free set1 in - let set2 = Value.to_ext Value.val_free set2 in +let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun _ set1 set2 -> let ans = Id.Set.union set1 set2 in return (Value.of_ext Value.val_free ans) end -let () = define1 "fresh_free_of_ids" begin fun _ ids -> - let ids = Value.to_list Value.to_ident ids in +let () = define1 "fresh_free_of_ids" (list ident) begin fun _ ids -> let free = List.fold_right Id.Set.add ids Id.Set.empty in return (Value.of_ext Value.val_free free) end -let () = define1 "fresh_free_of_constr" begin fun _ c -> - let c = Value.to_constr c in +let () = define1 "fresh_free_of_constr" constr begin fun _ c -> Proofview.tclEVARMAP >>= fun sigma -> let rec fold accu c = match EConstr.kind sigma c with | Constr.Var id -> Id.Set.add id accu @@ -794,9 +737,7 @@ let () = define1 "fresh_free_of_constr" begin fun _ c -> return (Value.of_ext Value.val_free ans) end -let () = define2 "fresh_fresh" begin fun _ avoid id -> - let avoid = Value.to_ext Value.val_free avoid in - let id = Value.to_ident id in +let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun _ avoid id -> let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in return (Value.of_ident nid) end @@ -999,7 +940,7 @@ let add_scope s f = let rec pr_scope = function | SexprStr (_, s) -> qstring s -| SexprInt (_, n) -> int n +| SexprInt (_, n) -> Pp.int n | SexprRec (_, (_, na), args) -> let na = match na with | None -> str "_" diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index c3f535c1bc..3e3dd362f7 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -49,6 +49,12 @@ exception LtacError of KerName.t * valexpr array * backtrace (** Conversion functions *) +let valexpr = { + r_of = (fun obj -> obj); + r_to = (fun obj -> obj); + r_id = true; +} + let of_unit () = ValInt 0 let to_unit = function @@ -216,6 +222,12 @@ let array r = { r_id = false; } +let block = { + r_of = of_tuple; + r_to = to_tuple; + r_id = false; +} + let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c let constant = repr_ext val_constant diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index fe813b0e35..1789a8932f 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -64,6 +64,8 @@ val of_closure : closure -> valexpr val to_closure : valexpr -> closure val closure : closure repr +val block : valexpr array repr + val of_array : ('a -> valexpr) -> 'a array -> valexpr val to_array : (valexpr -> 'a) -> valexpr -> 'a array val array : 'a repr -> 'a array repr @@ -95,6 +97,8 @@ val of_ext : 'a Val.tag -> 'a -> valexpr val to_ext : 'a Val.tag -> valexpr -> 'a val repr_ext : 'a Val.tag -> 'a repr +val valexpr : valexpr repr + (** {5 Dynamic tags} *) val val_constr : EConstr.t Val.tag -- cgit v1.2.3 From 64a6ac3759b5d0ea635ff284606541b05c696996 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 22:47:44 +0200 Subject: Using higher-order representation for closures. --- src/tac2core.ml | 31 ++++++++++----------------- src/tac2entries.ml | 6 +++--- src/tac2env.ml | 22 +------------------ src/tac2env.mli | 2 +- src/tac2expr.mli | 29 ++++++++----------------- src/tac2ffi.ml | 2 -- src/tac2ffi.mli | 7 +++--- src/tac2intern.ml | 2 +- src/tac2interp.ml | 63 ++++++++++++++++++++++++++++++++++++++++++++---------- src/tac2interp.mli | 2 +- src/tac2stdlib.ml | 2 +- 11 files changed, 83 insertions(+), 85 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 2f349e32af..603ddeecfd 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -100,7 +100,7 @@ let err_matchfailure bt = (** Helper functions *) -let thaw bt f = Tac2interp.interp_app bt f [v_unit] +let thaw bt f = f bt [v_unit] let throw bt e = Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) @@ -569,7 +569,7 @@ end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) let () = define2 "plus" closure closure begin fun bt x k -> - Proofview.tclOR (thaw bt x) (fun e -> Tac2interp.interp_app bt k [Value.of_exn e]) + Proofview.tclOR (thaw bt x) (fun e -> k bt [Value.of_exn e]) end (** (unit -> 'a) -> 'a *) @@ -597,31 +597,22 @@ let () = define1 "enter" closure begin fun bt f -> Proofview.tclINDEPENDENT f >>= fun () -> return v_unit end -let k_var = Id.of_string "k" -let e_var = Id.of_string "e" -let prm_apply_kont_h = pname "apply_kont" - (** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) let () = define1 "case" closure begin fun bt f -> Proofview.tclCASE (thaw bt f) >>= begin function | Proofview.Next (x, k) -> - let k = { - clos_ref = None; - clos_env = Id.Map.singleton k_var (Value.of_ext Value.val_kont k); - clos_var = [Name e_var]; - clos_exp = GTacPrm (prm_apply_kont_h, [GTacVar k_var; GTacVar e_var]); - } in - return (ValBlk (0, [| Value.of_tuple [| x; ValCls k |] |])) + let k bt = function + | [e] -> + let (e, info) = Value.to_exn e in + let e = set_bt bt e in + k (e, info) + | _ -> assert false + in + return (ValBlk (0, [| Value.of_tuple [| x; Value.of_closure k |] |])) | Proofview.Fail e -> return (ValBlk (1, [| Value.of_exn e |])) end end -(** 'a kont -> exn -> 'a *) -let () = define2 "apply_kont" (repr_ext val_kont) exn begin fun bt k (e, info) -> - let e = set_bt bt e in - k (e, info) -end - (** int -> int -> (unit -> 'a) -> 'a *) let () = define3 "focus" int int closure begin fun bt i j tac -> Proofview.tclFOCUS i j (thaw bt tac) @@ -695,7 +686,7 @@ let () = define2 "with_holes" closure closure begin fun bt x f -> thaw bt x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> - Tacticals.New.tclWITHHOLES false (Tac2interp.interp_app bt f [ans]) sigma + Tacticals.New.tclWITHHOLES false (f bt [ans]) sigma end let () = define1 "progress" closure begin fun bt f -> diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 9fd03ff5aa..97e1fe8e8e 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -686,7 +686,7 @@ type redefinition = { let perform_redefinition (_, redef) = let kn = redef.redef_kn in - let data, _ = Tac2env.interp_global kn in + let data = Tac2env.interp_global kn in let data = { data with Tac2env.gdata_expr = redef.redef_body } in Tac2env.define_global kn data @@ -715,7 +715,7 @@ let register_redefinition ?(local = false) (loc, qid) e = | TacAlias _ -> user_err ?loc (str "Cannot redefine syntactic abbreviations") in - let (data, _) = Tac2env.interp_global kn in + let data = Tac2env.interp_global kn in let () = if not (data.Tac2env.gdata_mutable) then user_err ?loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") @@ -800,7 +800,7 @@ let print_ltac ref = in match kn with | TacConstant kn -> - let data, _ = Tac2env.interp_global kn in + let data = Tac2env.interp_global kn in let e = data.Tac2env.gdata_expr in let (_, t) = data.Tac2env.gdata_type in let name = int_name () in diff --git a/src/tac2env.ml b/src/tac2env.ml index c04eaf7b0c..ef2b44afb9 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -52,33 +52,13 @@ let empty_state = { let ltac_state = Summary.ref empty_state ~name:"ltac2-state" -(** Get a dynamic value from syntactical value *) -let rec eval_pure kn = function -| GTacAtm (AtmInt n) -> ValInt n -| GTacRef kn -> - let { gdata_expr = e } = - try KNmap.find kn ltac_state.contents.ltac_tactics - with Not_found -> assert false - in - eval_pure (Some kn) e -| GTacFun (na, e) -> - ValCls { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } -| GTacCst (_, n, []) -> ValInt n -| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_unnamed el) -| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_unnamed el) -| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ -| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> - anomaly (Pp.str "Term is not a syntactical value") - -and eval_unnamed e = eval_pure None e - let define_global kn e = let state = !ltac_state in ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } let interp_global kn = let data = KNmap.find kn ltac_state.contents.ltac_tactics in - (data, eval_pure (Some kn) data.gdata_expr) + data let define_constructor kn t = let state = !ltac_state in diff --git a/src/tac2env.mli b/src/tac2env.mli index e40958e1a0..49c9910a44 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -24,7 +24,7 @@ type global_data = { } val define_global : ltac_constant -> global_data -> unit -val interp_global : ltac_constant -> global_data * valexpr +val interp_global : ltac_constant -> global_data (** {5 Toplevel definition of types} *) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 36c3fbbe59..1b4a704b11 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -180,6 +180,13 @@ type strexpr = type tag = int +type frame = +| FrLtac of ltac_constant option +| FrPrim of ml_tactic_name +| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame + +type backtrace = frame list + type valexpr = | ValInt of int (** Immediate integers *) @@ -187,32 +194,14 @@ type valexpr = (** Structured blocks *) | ValStr of Bytes.t (** Strings *) -| ValCls of closure +| ValCls of ml_tactic (** Closures *) | ValOpn of KerName.t * valexpr array (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) -and closure = { - mutable clos_env : valexpr Id.Map.t; - (** Mutable so that we can implement recursive functions imperatively *) - clos_var : Name.t list; - (** Bound variables *) - clos_exp : glb_tacexpr; - (** Body *) - clos_ref : ltac_constant option; - (** Global constant from which the closure originates *) -} - -type frame = -| FrLtac of ltac_constant option -| FrPrim of ml_tactic_name -| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame - -type backtrace = frame list - -type ml_tactic = backtrace -> valexpr list -> valexpr Proofview.tactic +and ml_tactic = backtrace -> valexpr list -> valexpr Proofview.tactic type environment = { env_ist : valexpr Id.Map.t; diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 3e3dd362f7..fb97177c4d 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -34,8 +34,6 @@ let val_constructor = Val.create "constructor" let val_projection = Val.create "projection" let val_case = Val.create "case" let val_univ = Val.create "universe" -let val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag = - Val.create "kont" let val_free : Names.Id.Set.t Val.tag = Val.create "free" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 1789a8932f..dfc87f7db3 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -60,9 +60,9 @@ val of_ident : Id.t -> valexpr val to_ident : valexpr -> Id.t val ident : Id.t repr -val of_closure : closure -> valexpr -val to_closure : valexpr -> closure -val closure : closure repr +val of_closure : ml_tactic -> valexpr +val to_closure : valexpr -> ml_tactic +val closure : ml_tactic repr val block : valexpr array repr @@ -113,7 +113,6 @@ val val_constructor : constructor Val.tag val val_projection : Projection.t Val.tag val val_case : Constr.case_info Val.tag val val_univ : Univ.universe_level Val.tag -val val_kont : (Exninfo.iexn -> valexpr Proofview.tactic) Val.tag val val_free : Id.Set.t Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag diff --git a/src/tac2intern.ml b/src/tac2intern.ml index d1a3e13cdb..2dcd8b8da3 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -654,7 +654,7 @@ let rec intern_rec env (loc, e) = match e with let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) | ArgArg (TacConstant kn) -> - let { Tac2env.gdata_type = sch }, _ = + let { Tac2env.gdata_type = sch } = try Tac2env.interp_global kn with Not_found -> CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 6bee5a0794..08cebc0af0 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -21,6 +21,17 @@ let empty_environment = { env_bkt = []; } +type closure = { + mutable clos_env : valexpr Id.Map.t; + (** Mutable so that we can implement recursive functions imperatively *) + clos_var : Name.t list; + (** Bound variables *) + clos_exp : glb_tacexpr; + (** Body *) + clos_ref : ltac_constant option; + (** Global constant from which the closure originates *) +} + let push_name ist id v = match id with | Anonymous -> ist | Name id -> { ist with env_ist = Id.Map.add id v ist.env_ist } @@ -30,7 +41,10 @@ let get_var ist id = anomaly (str "Unbound variable " ++ Id.print id) let get_ref ist kn = - try snd (Tac2env.interp_global kn) with Not_found -> + try + let data = Tac2env.interp_global kn in + data.Tac2env.gdata_expr + with Not_found -> anomaly (str "Unbound reference" ++ KerName.print kn) let return = Proofview.tclUNIT @@ -39,14 +53,17 @@ let rec interp (ist : environment) = function | GTacAtm (AtmInt n) -> return (ValInt n) | GTacAtm (AtmStr s) -> return (ValStr (Bytes.of_string s)) | GTacVar id -> return (get_var ist id) -| GTacRef qid -> return (get_ref ist qid) +| GTacRef kn -> + let data = get_ref ist kn in + return (eval_pure (Some kn) data) | GTacFun (ids, e) -> let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - return (ValCls cls) + let f = interp_app cls in + return (ValCls f) | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - interp_app ist.env_bkt (Tac2ffi.to_closure f) args + Tac2ffi.to_closure f ist.env_bkt args | GTacLet (false, el, e) -> let fold accu (na, e) = interp ist e >>= fun e -> @@ -58,17 +75,18 @@ let rec interp (ist : environment) = function let map (na, e) = match e with | GTacFun (ids, e) -> let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - na, cls + let f = ValCls (interp_app cls) in + na, cls, f | _ -> anomaly (str "Ill-formed recursive function") in let fixs = List.map map el in - let fold accu (na, cls) = match na with + let fold accu (na, _, cls) = match na with | Anonymous -> accu - | Name id -> { ist with env_ist = Id.Map.add id (ValCls cls) accu.env_ist } + | Name id -> { ist with env_ist = Id.Map.add id cls accu.env_ist } in let ist = List.fold_left fold ist fixs in (** Hack to make a cycle imperatively in the environment *) - let iter (_, e) = e.clos_env <- ist.env_ist in + let iter (_, e, _) = e.clos_env <- ist.env_ist in let () = List.iter iter fixs in interp ist e | GTacCst (_, n, []) -> return (ValInt n) @@ -96,15 +114,16 @@ let rec interp (ist : environment) = function let ist = { ist with env_bkt = FrExtn (tag, e) :: ist.env_bkt } in tpe.Tac2env.ml_interp ist e -and interp_app bt f args = match f with +and interp_app f = (); fun bt args -> match f with | { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> let rec push ist ids args = match ids, args with | [], [] -> interp ist e | [], _ :: _ -> - interp ist e >>= fun f -> interp_app bt (Tac2ffi.to_closure f) args + interp ist e >>= fun f -> Tac2ffi.to_closure f bt args | _ :: _, [] -> let cls = { clos_ref = kn; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - return (ValCls cls) + let f = interp_app cls in + return (ValCls f) | id :: ids, arg :: args -> push (push_name ist id arg) ids args in push { env_ist = ist; env_bkt = FrLtac kn :: bt } ids args @@ -147,6 +166,28 @@ and interp_set ist e p r = match e with | ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> anomaly (str "Unexpected value shape") +and eval_pure kn = function +| GTacAtm (AtmInt n) -> ValInt n +| GTacRef kn -> + let { Tac2env.gdata_expr = e } = + try Tac2env.interp_global kn + with Not_found -> assert false + in + eval_pure (Some kn) e +| GTacFun (na, e) -> + let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in + let f = interp_app cls in + ValCls f +| GTacCst (_, n, []) -> ValInt n +| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_unnamed el) +| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_unnamed el) +| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> + anomaly (Pp.str "Term is not a syntactical value") + +and eval_unnamed e = eval_pure None e + + (** Cross-boundary hacks. *) open Geninterp diff --git a/src/tac2interp.mli b/src/tac2interp.mli index ca263b2c4b..48af59b178 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -13,7 +13,7 @@ val empty_environment : environment val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic -val interp_app : backtrace -> closure -> valexpr list -> valexpr Proofview.tactic +(* val interp_app : closure -> ml_tactic *) (** {5 Cross-boundary encodings} *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 79af41b7d0..14ad8695ca 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -18,7 +18,7 @@ module Value = Tac2ffi let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () -let thaw bt f = Tac2interp.interp_app bt (Value.to_closure f) [v_unit] +let thaw bt f = (Value.to_closure f) bt [v_unit] let to_pair f g = function | ValBlk (0, [| x; y |]) -> (f x, g y) -- cgit v1.2.3 From d6997e31e7fc4cfc6e020bf1ab53e6b1fa3f74fe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 23:46:41 +0200 Subject: Fix coq/ltac2#23: Int.compare should not be uniformly 0. Stupid typo. --- src/tac2core.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 603ddeecfd..7f136b48ae 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -230,7 +230,7 @@ let () = define2 "int_equal" int int begin fun _ m n -> end let binop n f = define2 n int int begin fun _ m n -> - return (Value.of_int (f m m)) + return (Value.of_int (f m n)) end let () = binop "int_compare" Int.compare -- cgit v1.2.3 From 2bea4137bd0841de7273a5adf9a72bd2e786fb68 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 6 Sep 2017 23:50:33 +0200 Subject: Communicate the backtrace through the monad. --- src/tac2core.ml | 233 +++++++++++++++++++++++++++------------------------- src/tac2core.mli | 2 +- src/tac2entries.ml | 8 +- src/tac2expr.mli | 3 +- src/tac2interp.ml | 46 ++++++++--- src/tac2interp.mli | 8 ++ src/tac2stdlib.ml | 221 +++++++++++++++++++++++++------------------------ src/tac2tactics.ml | 48 +++++------ src/tac2tactics.mli | 22 ++--- 9 files changed, 313 insertions(+), 278 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 7f136b48ae..4a35442b04 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -100,9 +100,14 @@ let err_matchfailure bt = (** Helper functions *) -let thaw bt f = f bt [v_unit] +let thaw f = f [v_unit] -let throw bt e = Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) +let throw e = + Tac2interp.get_backtrace >>= fun bt -> + Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) + +let fail e = + Tac2interp.get_backtrace >>= fun bt -> Proofview.tclZERO (e bt) let set_bt bt e = match e with | Tac2interp.LtacError (kn, args, _) -> Tac2interp.LtacError (kn, args, bt) @@ -117,13 +122,13 @@ let wrap f = let wrap_unit f = return () >>= fun () -> f (); return v_unit -let assert_focussed bt = +let assert_focussed = Proofview.Goal.goals >>= fun gls -> match gls with | [_] -> Proofview.tclUNIT () - | [] | _ :: _ :: _ -> throw bt err_notfocussed + | [] | _ :: _ :: _ -> throw err_notfocussed -let pf_apply bt f = +let pf_apply f = Proofview.Goal.goals >>= function | [] -> Proofview.tclENV >>= fun env -> @@ -133,103 +138,103 @@ let pf_apply bt f = gl >>= fun gl -> f (Proofview.Goal.env gl) (Tacmach.New.project gl) | _ :: _ :: _ -> - throw bt err_notfocussed + throw err_notfocussed (** Primitives *) -let define0 name f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [_] -> f bt +let define0 name f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with +| [_] -> f | _ -> assert false end -let define1 name r0 f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [x] -> f bt (r0.Value.r_to x) +let define1 name r0 f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with +| [x] -> f (r0.Value.r_to x) | _ -> assert false end -let define2 name r0 r1 f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [x; y] -> f bt (r0.Value.r_to x) (r1.Value.r_to y) +let define2 name r0 r1 f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with +| [x; y] -> f (r0.Value.r_to x) (r1.Value.r_to y) | _ -> assert false end -let define3 name r0 r1 r2 f = Tac2env.define_primitive (pname name) begin fun bt arg -> match arg with -| [x; y; z] -> f bt (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) +let define3 name r0 r1 r2 f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with +| [x; y; z] -> f (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) | _ -> assert false end (** Printing *) -let () = define1 "print" pp begin fun _ pp -> +let () = define1 "print" pp begin fun pp -> wrap_unit (fun () -> Feedback.msg_notice pp) end -let () = define1 "message_of_int" int begin fun _ n -> +let () = define1 "message_of_int" int begin fun n -> return (Value.of_pp (Pp.int n)) end -let () = define1 "message_of_string" string begin fun _ s -> +let () = define1 "message_of_string" string begin fun s -> return (Value.of_pp (str (Bytes.to_string s))) end -let () = define1 "message_of_constr" constr begin fun bt c -> - pf_apply bt begin fun env sigma -> +let () = define1 "message_of_constr" constr begin fun c -> + pf_apply begin fun env sigma -> let pp = Printer.pr_econstr_env env sigma c in return (Value.of_pp pp) end end -let () = define1 "message_of_ident" ident begin fun _ c -> +let () = define1 "message_of_ident" ident begin fun c -> let pp = Id.print c in return (Value.of_pp pp) end -let () = define2 "message_concat" pp pp begin fun _ m1 m2 -> +let () = define2 "message_concat" pp pp begin fun m1 m2 -> return (Value.of_pp (Pp.app m1 m2)) end (** Array *) -let () = define2 "array_make" int valexpr begin fun bt n x -> - if n < 0 || n > Sys.max_array_length then throw bt err_outofbounds +let () = define2 "array_make" int valexpr begin fun n x -> + if n < 0 || n > Sys.max_array_length then throw err_outofbounds else wrap (fun () -> ValBlk (0, Array.make n x)) end -let () = define1 "array_length" block begin fun _ v -> +let () = define1 "array_length" block begin fun v -> return (ValInt (Array.length v)) end -let () = define3 "array_set" block int valexpr begin fun bt v n x -> - if n < 0 || n >= Array.length v then throw bt err_outofbounds +let () = define3 "array_set" block int valexpr begin fun v n x -> + if n < 0 || n >= Array.length v then throw err_outofbounds else wrap_unit (fun () -> v.(n) <- x) end -let () = define2 "array_get" block int begin fun bt v n -> - if n < 0 || n >= Array.length v then throw bt err_outofbounds +let () = define2 "array_get" block int begin fun v n -> + if n < 0 || n >= Array.length v then throw err_outofbounds else wrap (fun () -> v.(n)) end (** Ident *) -let () = define2 "ident_equal" ident ident begin fun _ id1 id2 -> +let () = define2 "ident_equal" ident ident begin fun id1 id2 -> return (Value.of_bool (Id.equal id1 id2)) end -let () = define1 "ident_to_string" ident begin fun _ id -> +let () = define1 "ident_to_string" ident begin fun id -> return (Value.of_string (Id.to_string id)) end -let () = define1 "ident_of_string" string begin fun _ s -> +let () = define1 "ident_of_string" string begin fun s -> let id = try Some (Id.of_string s) with _ -> None in return (Value.of_option Value.of_ident id) end (** Int *) -let () = define2 "int_equal" int int begin fun _ m n -> +let () = define2 "int_equal" int int begin fun m n -> return (Value.of_bool (m == n)) end -let binop n f = define2 n int int begin fun _ m n -> +let binop n f = define2 n int int begin fun m n -> return (Value.of_int (f m n)) end @@ -238,52 +243,52 @@ let () = binop "int_add" (+) let () = binop "int_sub" (-) let () = binop "int_mul" ( * ) -let () = define1 "int_neg" int begin fun _ m -> +let () = define1 "int_neg" int begin fun m -> return (Value.of_int (~- m)) end (** String *) -let () = define2 "string_make" int char begin fun bt n c -> - if n < 0 || n > Sys.max_string_length then throw bt err_outofbounds +let () = define2 "string_make" int char begin fun n c -> + if n < 0 || n > Sys.max_string_length then throw err_outofbounds else wrap (fun () -> Value.of_string (Bytes.make n c)) end -let () = define1 "string_length" string begin fun _ s -> +let () = define1 "string_length" string begin fun s -> return (Value.of_int (Bytes.length s)) end -let () = define3 "string_set" string int char begin fun bt s n c -> - if n < 0 || n >= Bytes.length s then throw bt err_outofbounds +let () = define3 "string_set" string int char begin fun s n c -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds else wrap_unit (fun () -> Bytes.set s n c) end -let () = define2 "string_get" string int begin fun bt s n -> - if n < 0 || n >= Bytes.length s then throw bt err_outofbounds +let () = define2 "string_get" string int begin fun s n -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds else wrap (fun () -> Value.of_char (Bytes.get s n)) end (** Terms *) (** constr -> constr *) -let () = define1 "constr_type" constr begin fun bt c -> +let () = define1 "constr_type" constr begin fun c -> let get_type env sigma = Proofview.V82.wrap_exceptions begin fun () -> let (sigma, t) = Typing.type_of env sigma c in let t = Value.of_constr t in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t end in - pf_apply bt get_type + pf_apply get_type end (** constr -> constr *) -let () = define2 "constr_equal" constr constr begin fun _ c1 c2 -> +let () = define2 "constr_equal" constr constr begin fun c1 c2 -> Proofview.tclEVARMAP >>= fun sigma -> let b = EConstr.eq_constr sigma c1 c2 in Proofview.tclUNIT (Value.of_bool b) end -let () = define1 "constr_kind" constr begin fun _ c -> +let () = define1 "constr_kind" constr begin fun c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> return begin match EConstr.kind sigma c with @@ -377,7 +382,7 @@ let () = define1 "constr_kind" constr begin fun _ c -> end end -let () = define1 "constr_make" valexpr begin fun _ knd -> +let () = define1 "constr_make" valexpr begin fun knd -> let open Constr in let c = match knd with | ValBlk (0, [|n|]) -> @@ -457,8 +462,8 @@ let () = define1 "constr_make" valexpr begin fun _ knd -> return (Value.of_constr c) end -let () = define1 "constr_check" constr begin fun bt c -> - pf_apply bt begin fun env sigma -> +let () = define1 "constr_check" constr begin fun c -> + pf_apply begin fun env sigma -> try let (sigma, _) = Typing.type_of env sigma c in Proofview.Unsafe.tclEVARS sigma >>= fun () -> @@ -469,26 +474,26 @@ let () = define1 "constr_check" constr begin fun bt c -> end end -let () = define3 "constr_substnl" (list constr) int constr begin fun _ subst k c -> +let () = define3 "constr_substnl" (list constr) int constr begin fun subst k c -> let ans = EConstr.Vars.substnl subst k c in return (Value.of_constr ans) end -let () = define3 "constr_closenl" (list ident) int constr begin fun _ ids k c -> +let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> let ans = EConstr.Vars.substn_vars k ids c in return (Value.of_constr ans) end (** Patterns *) -let () = define2 "pattern_matches" pattern constr begin fun bt pat c -> - pf_apply bt begin fun env sigma -> +let () = define2 "pattern_matches" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> let ans = try Some (Constr_matching.matches env sigma pat c) with Constr_matching.PatternMatchingFailure -> None in begin match ans with - | None -> Proofview.tclZERO (err_matchfailure bt) + | None -> fail err_matchfailure | Some ans -> let ans = Id.Map.bindings ans in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in @@ -497,30 +502,30 @@ let () = define2 "pattern_matches" pattern constr begin fun bt pat c -> end end -let () = define2 "pattern_matches_subterm" pattern constr begin fun bt pat c -> +let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> let open Constr_matching in let rec of_ans s = match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO (err_matchfailure bt) + | IStream.Nil -> fail err_matchfailure | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_list of_pair ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in - pf_apply bt begin fun env sigma -> + pf_apply begin fun env sigma -> let ans = Constr_matching.match_appsubterm env sigma pat c in of_ans ans end end -let () = define2 "pattern_matches_vect" pattern constr begin fun bt pat c -> - pf_apply bt begin fun env sigma -> +let () = define2 "pattern_matches_vect" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> let ans = try Some (Constr_matching.matches env sigma pat c) with Constr_matching.PatternMatchingFailure -> None in begin match ans with - | None -> Proofview.tclZERO (err_matchfailure bt) + | None -> fail err_matchfailure | Some ans -> let ans = Id.Map.bindings ans in let ans = Array.map_of_list snd ans in @@ -529,23 +534,23 @@ let () = define2 "pattern_matches_vect" pattern constr begin fun bt pat c -> end end -let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun bt pat c -> +let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c -> let open Constr_matching in let rec of_ans s = match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO (err_matchfailure bt) + | IStream.Nil -> fail err_matchfailure | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let ans = Array.map_of_list snd ans in let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_array Value.of_constr ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in - pf_apply bt begin fun env sigma -> + pf_apply begin fun env sigma -> let ans = Constr_matching.match_appsubterm env sigma pat c in of_ans ans end end -let () = define2 "pattern_instantiate" constr constr begin fun _ ctx c -> +let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> let ctx = EConstr.Unsafe.to_constr ctx in let c = EConstr.Unsafe.to_constr c in let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in @@ -554,7 +559,8 @@ end (** Error *) -let () = define1 "throw" exn begin fun bt (e, info) -> +let () = define1 "throw" exn begin fun (e, info) -> + Tac2interp.get_backtrace >>= fun bt -> let e = set_bt bt e in Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) end @@ -562,48 +568,50 @@ end (** Control *) (** exn -> 'a *) -let () = define1 "zero" exn begin fun bt (e, info) -> +let () = define1 "zero" exn begin fun (e, info) -> + Tac2interp.get_backtrace >>= fun bt -> let e = set_bt bt e in Proofview.tclZERO ~info e end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) -let () = define2 "plus" closure closure begin fun bt x k -> - Proofview.tclOR (thaw bt x) (fun e -> k bt [Value.of_exn e]) +let () = define2 "plus" closure closure begin fun x k -> + Proofview.tclOR (thaw x) (fun e -> k [Value.of_exn e]) end (** (unit -> 'a) -> 'a *) -let () = define1 "once" closure begin fun bt f -> - Proofview.tclONCE (thaw bt f) +let () = define1 "once" closure begin fun f -> + Proofview.tclONCE (thaw f) end (** (unit -> unit) list -> unit *) -let () = define1 "dispatch" (list closure) begin fun bt l -> - let l = List.map (fun f -> Proofview.tclIGNORE (thaw bt f)) l in +let () = define1 "dispatch" (list closure) begin fun l -> + let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in Proofview.tclDISPATCH l >>= fun () -> return v_unit end (** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let () = define3 "extend" (list closure) closure (list closure) begin fun bt lft tac rgt -> - let lft = List.map (fun f -> Proofview.tclIGNORE (thaw bt f)) lft in - let tac = Proofview.tclIGNORE (thaw bt tac) in - let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw bt f)) rgt in +let () = define3 "extend" (list closure) closure (list closure) begin fun lft tac rgt -> + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let tac = Proofview.tclIGNORE (thaw tac) in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit end (** (unit -> unit) -> unit *) -let () = define1 "enter" closure begin fun bt f -> - let f = Proofview.tclIGNORE (thaw bt f) in +let () = define1 "enter" closure begin fun f -> + let f = Proofview.tclIGNORE (thaw f) in Proofview.tclINDEPENDENT f >>= fun () -> return v_unit end (** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) -let () = define1 "case" closure begin fun bt f -> - Proofview.tclCASE (thaw bt f) >>= begin function +let () = define1 "case" closure begin fun f -> + Proofview.tclCASE (thaw f) >>= begin function | Proofview.Next (x, k) -> - let k bt = function + let k = function | [e] -> let (e, info) = Value.to_exn e in + Tac2interp.get_backtrace >>= fun bt -> let e = set_bt bt e in k (e, info) | _ -> assert false @@ -614,31 +622,31 @@ let () = define1 "case" closure begin fun bt f -> end (** int -> int -> (unit -> 'a) -> 'a *) -let () = define3 "focus" int int closure begin fun bt i j tac -> - Proofview.tclFOCUS i j (thaw bt tac) +let () = define3 "focus" int int closure begin fun i j tac -> + Proofview.tclFOCUS i j (thaw tac) end (** unit -> unit *) -let () = define0 "shelve" begin fun _ -> +let () = define0 "shelve" begin Proofview.shelve >>= fun () -> return v_unit end (** unit -> unit *) -let () = define0 "shelve_unifiable" begin fun _ -> +let () = define0 "shelve_unifiable" begin Proofview.shelve_unifiable >>= fun () -> return v_unit end -let () = define1 "new_goal" int begin fun bt ev -> +let () = define1 "new_goal" int begin fun ev -> let ev = Evar.unsafe_of_int ev in Proofview.tclEVARMAP >>= fun sigma -> if Evd.mem sigma ev then Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit - else throw bt err_notfound + else throw err_notfound end (** unit -> constr *) -let () = define0 "goal" begin fun bt -> - assert_focussed bt >>= fun () -> +let () = define0 "goal" begin + assert_focussed >>= fun () -> Proofview.Goal.enter_one begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in return (Value.of_constr concl) @@ -646,8 +654,8 @@ let () = define0 "goal" begin fun bt -> end (** ident -> constr *) -let () = define1 "hyp" ident begin fun bt id -> - pf_apply bt begin fun env _ -> +let () = define1 "hyp" ident begin fun id -> + pf_apply begin fun env _ -> let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in if mem then return (Value.of_constr (EConstr.mkVar id)) else Tacticals.New.tclZEROMSG @@ -655,8 +663,8 @@ let () = define1 "hyp" ident begin fun bt id -> end end -let () = define0 "hyps" begin fun bt -> - pf_apply bt begin fun env _ -> +let () = define0 "hyps" begin + pf_apply begin fun env _ -> let open Context.Named.Declaration in let hyps = List.rev (Environ.named_context env) in let map = function @@ -673,52 +681,52 @@ let () = define0 "hyps" begin fun bt -> end (** (unit -> constr) -> unit *) -let () = define1 "refine" closure begin fun bt c -> - let c = thaw bt c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in +let () = define1 "refine" closure begin fun c -> + let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in Refine.generic_refine ~typecheck:true c gl end >>= fun () -> return v_unit end -let () = define2 "with_holes" closure closure begin fun bt x f -> +let () = define2 "with_holes" closure closure begin fun x f -> Proofview.tclEVARMAP >>= fun sigma0 -> - thaw bt x >>= fun ans -> + thaw x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> - Tacticals.New.tclWITHHOLES false (f bt [ans]) sigma + Tacticals.New.tclWITHHOLES false (f [ans]) sigma end -let () = define1 "progress" closure begin fun bt f -> - Proofview.tclPROGRESS (thaw bt f) +let () = define1 "progress" closure begin fun f -> + Proofview.tclPROGRESS (thaw f) end -let () = define2 "abstract" (option ident) closure begin fun bt id f -> - Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw bt f)) >>= fun () -> +let () = define2 "abstract" (option ident) closure begin fun id f -> + Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> return v_unit end -let () = define2 "time" (option string) closure begin fun bt s f -> - Proofview.tclTIME s (thaw bt f) +let () = define2 "time" (option string) closure begin fun s f -> + Proofview.tclTIME s (thaw f) end -let () = define0 "check_interrupt" begin fun bt -> +let () = define0 "check_interrupt" begin Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit end (** Fresh *) -let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun _ set1 set2 -> +let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun set1 set2 -> let ans = Id.Set.union set1 set2 in return (Value.of_ext Value.val_free ans) end -let () = define1 "fresh_free_of_ids" (list ident) begin fun _ ids -> +let () = define1 "fresh_free_of_ids" (list ident) begin fun ids -> let free = List.fold_right Id.Set.add ids Id.Set.empty in return (Value.of_ext Value.val_free free) end -let () = define1 "fresh_free_of_constr" constr begin fun _ c -> +let () = define1 "fresh_free_of_constr" constr begin fun c -> Proofview.tclEVARMAP >>= fun sigma -> let rec fold accu c = match EConstr.kind sigma c with | Constr.Var id -> Id.Set.add id accu @@ -728,7 +736,7 @@ let () = define1 "fresh_free_of_constr" constr begin fun _ c -> return (Value.of_ext Value.val_free ans) end -let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun _ avoid id -> +let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in return (Value.of_ident nid) end @@ -769,9 +777,8 @@ let intern_constr self ist c = let interp_constr flags ist c = let open Pretyping in - let bt = ist.env_bkt in let ist = to_lvar ist in - pf_apply bt begin fun env sigma -> + pf_apply begin fun env sigma -> Proofview.V82.wrap_exceptions begin fun () -> let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in let c = ValExt (Value.val_constr, c) in @@ -865,7 +872,7 @@ let () = GlbVal tac, gtypref t_unit in let interp ist tac = - let ist = { ist with env_ist = Id.Map.empty } in + let ist = { env_ist = Id.Map.empty } in let lfun = Tac2interp.set_env ist Id.Map.empty in let ist = Ltac_plugin.Tacinterp.default_ist () in (** FUCK YOU API *) @@ -911,8 +918,8 @@ let () = (** FUCK YOU API *) let idtac = (Obj.magic idtac : Geninterp.Val.t) in let interp ist tac = - let ist = Tac2interp.get_env ist.Geninterp.lfun in - let ist = { ist with env_ist = Id.Map.empty } in +(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) + let ist = { env_ist = Id.Map.empty } in Tac2interp.interp ist tac >>= fun _ -> Ftactic.return idtac in diff --git a/src/tac2core.mli b/src/tac2core.mli index b5800a7172..9fae65bb3e 100644 --- a/src/tac2core.mli +++ b/src/tac2core.mli @@ -27,4 +27,4 @@ val c_false : ltac_constructor end -val pf_apply : backtrace -> (Environ.env -> Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic +val pf_apply : (Environ.env -> Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 97e1fe8e8e..eed7eb6def 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -748,14 +748,12 @@ let register_struct ?local str = match str with (** Toplevel exception *) -let print_ltac2_backtrace = ref false - let _ = Goptions.declare_bool_option { Goptions.optdepr = false; Goptions.optname = "print Ltac2 backtrace"; Goptions.optkey = ["Ltac2"; "Backtrace"]; - Goptions.optread = (fun () -> !print_ltac2_backtrace); - Goptions.optwrite = (fun b -> print_ltac2_backtrace := b); + Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); + Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); } let pr_frame = function @@ -773,7 +771,7 @@ let () = register_handler begin function | Tac2interp.LtacError (kn, _, bt) -> let c = Tac2print.pr_constructor kn in (** FIXME *) let bt = - if !print_ltac2_backtrace then + if !Tac2interp.print_ltac2_backtrace then fnl () ++ str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt else mt () diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 1b4a704b11..77e2cfef0e 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -201,9 +201,8 @@ type valexpr = | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) -and ml_tactic = backtrace -> valexpr list -> valexpr Proofview.tactic +and ml_tactic = valexpr list -> valexpr Proofview.tactic type environment = { env_ist : valexpr Id.Map.t; - env_bkt : backtrace; } diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 08cebc0af0..f37b4f8e9c 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -16,9 +16,34 @@ open Tac2expr exception LtacError = Tac2ffi.LtacError +let backtrace : backtrace Evd.Store.field = Evd.Store.field () + +let print_ltac2_backtrace = ref false + +let get_backtrace = + Proofview.tclEVARMAP >>= fun sigma -> + match Evd.Store.get (Evd.get_extra_data sigma) backtrace with + | None -> Proofview.tclUNIT [] + | Some bt -> Proofview.tclUNIT bt + +let set_backtrace bt = + Proofview.tclEVARMAP >>= fun sigma -> + let store = Evd.get_extra_data sigma in + let store = Evd.Store.set store backtrace bt in + let sigma = Evd.set_extra_data store sigma in + Proofview.Unsafe.tclEVARS sigma + +let with_frame frame tac = + if !print_ltac2_backtrace then + get_backtrace >>= fun bt -> + set_backtrace (frame :: bt) >>= fun () -> + tac >>= fun ans -> + set_backtrace bt >>= fun () -> + Proofview.tclUNIT ans + else tac + let empty_environment = { env_ist = Id.Map.empty; - env_bkt = []; } type closure = { @@ -34,7 +59,7 @@ type closure = { let push_name ist id v = match id with | Anonymous -> ist -| Name id -> { ist with env_ist = Id.Map.add id v ist.env_ist } +| Name id -> { env_ist = Id.Map.add id v ist.env_ist } let get_var ist id = try Id.Map.find id ist.env_ist with Not_found -> @@ -63,7 +88,7 @@ let rec interp (ist : environment) = function | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - Tac2ffi.to_closure f ist.env_bkt args + Tac2ffi.to_closure f args | GTacLet (false, el, e) -> let fold accu (na, e) = interp ist e >>= fun e -> @@ -82,7 +107,7 @@ let rec interp (ist : environment) = function let fixs = List.map map el in let fold accu (na, _, cls) = match na with | Anonymous -> accu - | Name id -> { ist with env_ist = Id.Map.add id cls accu.env_ist } + | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } in let ist = List.fold_left fold ist fixs in (** Hack to make a cycle imperatively in the environment *) @@ -108,25 +133,24 @@ let rec interp (ist : environment) = function return (ValOpn (kn, Array.of_list el)) | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - Tac2env.interp_primitive ml (FrPrim ml :: ist.env_bkt) el + with_frame (FrPrim ml) (Tac2env.interp_primitive ml el) | GTacExt (tag, e) -> let tpe = Tac2env.interp_ml_object tag in - let ist = { ist with env_bkt = FrExtn (tag, e) :: ist.env_bkt } in - tpe.Tac2env.ml_interp ist e + with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) -and interp_app f = (); fun bt args -> match f with +and interp_app f = (); fun args -> match f with | { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> let rec push ist ids args = match ids, args with - | [], [] -> interp ist e + | [], [] -> with_frame (FrLtac kn) (interp ist e) | [], _ :: _ -> - interp ist e >>= fun f -> Tac2ffi.to_closure f bt args + with_frame (FrLtac kn) (interp ist e) >>= fun f -> Tac2ffi.to_closure f args | _ :: _, [] -> let cls = { clos_ref = kn; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in let f = interp_app cls in return (ValCls f) | id :: ids, arg :: args -> push (push_name ist id arg) ids args in - push { env_ist = ist; env_bkt = FrLtac kn :: bt } ids args + push { env_ist = ist } ids args and interp_case ist e cse0 cse1 = match e with | ValInt n -> interp ist cse0.(n) diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 48af59b178..1003e9f1eb 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -24,3 +24,11 @@ val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound exception LtacError of KerName.t * valexpr array * backtrace (** Ltac2-defined exceptions seen from OCaml side *) + +(** {5 Backtrace} *) + +val get_backtrace : backtrace Proofview.tactic + +val with_frame : frame -> 'a Proofview.tactic -> 'a Proofview.tactic + +val print_ltac2_backtrace : bool ref diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 14ad8695ca..28bcd6a1cf 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -18,7 +18,7 @@ module Value = Tac2ffi let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () -let thaw bt f = (Value.to_closure f) bt [v_unit] +let thaw f = Value.to_closure f [v_unit] let to_pair f g = function | ValBlk (0, [| x; y |]) -> (f x, g y) @@ -126,8 +126,7 @@ and to_intro_patterns il = let to_destruction_arg = function | ValBlk (0, [| c |]) -> - (** FIXME: lost backtrace *) - let c = thaw [] c >>= fun c -> return (to_constr_with_bindings c) in + let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in None, ElimOnConstr c | ValBlk (1, [| id |]) -> None, ElimOnIdent (Loc.tag (Value.to_ident id)) | ValBlk (2, [| n |]) -> None, ElimOnAnonHyp (Value.to_int n) @@ -155,7 +154,7 @@ let to_rewriting = function let orient = Value.to_option Value.to_bool orient in let repeat = to_multi repeat in (** FIXME: lost backtrace *) - let c = thaw [] c >>= fun c -> return (to_constr_with_bindings c) in + let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in (orient, repeat, c) | _ -> assert false @@ -190,59 +189,59 @@ let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } let lift tac = tac <*> return v_unit let define_prim0 name tac = - let tac bt arg = match arg with + let tac arg = match arg with | [_] -> lift tac | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim1 name tac = - let tac bt arg = match arg with - | [x] -> lift (tac bt x) + let tac arg = match arg with + | [x] -> lift (tac x) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim2 name tac = - let tac bt arg = match arg with - | [x; y] -> lift (tac bt x y) + let tac arg = match arg with + | [x; y] -> lift (tac x y) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim3 name tac = - let tac bt arg = match arg with - | [x; y; z] -> lift (tac bt x y z) + let tac arg = match arg with + | [x; y; z] -> lift (tac x y z) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim4 name tac = - let tac bt arg = match arg with - | [x; y; z; u] -> lift (tac bt x y z u) + let tac arg = match arg with + | [x; y; z; u] -> lift (tac x y z u) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_prim5 name tac = - let tac bt arg = match arg with - | [x; y; z; u; v] -> lift (tac bt x y z u v) + let tac arg = match arg with + | [x; y; z; u; v] -> lift (tac x y z u v) | _ -> assert false in Tac2env.define_primitive (pname name) tac (** Tactics from Tacexpr *) -let () = define_prim2 "tac_intros" begin fun _ ev ipat -> +let () = define_prim2 "tac_intros" begin fun ev ipat -> let ev = Value.to_bool ev in let ipat = to_intro_patterns ipat in Tactics.intros_patterns ev ipat end -let () = define_prim4 "tac_apply" begin fun bt adv ev cb ipat -> +let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> let adv = Value.to_bool adv in let ev = Value.to_bool ev in - let map_cb c = thaw bt c >>= fun c -> return (to_constr_with_bindings c) in + let map_cb c = thaw c >>= fun c -> return (to_constr_with_bindings c) in let cb = Value.to_list map_cb cb in let map p = Value.to_option (fun p -> Loc.tag (to_intro_pattern p)) p in let map_ipat p = to_pair Value.to_ident map p in @@ -250,20 +249,20 @@ let () = define_prim4 "tac_apply" begin fun bt adv ev cb ipat -> Tac2tactics.apply adv ev cb ipat end -let () = define_prim3 "tac_elim" begin fun _ ev c copt -> +let () = define_prim3 "tac_elim" begin fun ev c copt -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in let copt = Value.to_option to_constr_with_bindings copt in Tactics.elim ev None c copt end -let () = define_prim2 "tac_case" begin fun _ ev c -> +let () = define_prim2 "tac_case" begin fun ev c -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in Tactics.general_case_analysis ev None c end -let () = define_prim1 "tac_generalize" begin fun _ cl -> +let () = define_prim1 "tac_generalize" begin fun cl -> let cast = function | ValBlk (0, [| c; occs; na |]) -> ((to_occurrences Value.to_int occs, Value.to_constr c), to_name na) @@ -273,113 +272,113 @@ let () = define_prim1 "tac_generalize" begin fun _ cl -> Tactics.new_generalize_gen cl end -let () = define_prim3 "tac_assert" begin fun bt c tac ipat -> +let () = define_prim3 "tac_assert" begin fun c tac ipat -> let c = Value.to_constr c in - let of_tac t = Proofview.tclIGNORE (thaw bt t) in + let of_tac t = Proofview.tclIGNORE (thaw t) in let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in Tactics.forward true tac ipat c end -let () = define_prim3 "tac_enough" begin fun bt c tac ipat -> +let () = define_prim3 "tac_enough" begin fun c tac ipat -> let c = Value.to_constr c in - let of_tac t = Proofview.tclIGNORE (thaw bt t) in + let of_tac t = Proofview.tclIGNORE (thaw t) in let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in Tactics.forward false tac ipat c end -let () = define_prim2 "tac_pose" begin fun _ idopt c -> +let () = define_prim2 "tac_pose" begin fun idopt c -> let na = to_name idopt in let c = Value.to_constr c in Tactics.letin_tac None na c None Locusops.nowhere end -let () = define_prim4 "tac_set" begin fun bt ev idopt c cl -> +let () = define_prim4 "tac_set" begin fun ev idopt c cl -> let ev = Value.to_bool ev in let na = to_name idopt in let cl = to_clause cl in Proofview.tclEVARMAP >>= fun sigma -> - thaw bt c >>= fun c -> + thaw c >>= fun c -> let c = Value.to_constr c in Tactics.letin_pat_tac ev None na (sigma, c) cl end -let () = define_prim3 "tac_destruct" begin fun _ ev ic using -> +let () = define_prim3 "tac_destruct" begin fun ev ic using -> let ev = Value.to_bool ev in let ic = Value.to_list to_induction_clause ic in let using = Value.to_option to_constr_with_bindings using in Tac2tactics.induction_destruct false ev ic using end -let () = define_prim3 "tac_induction" begin fun _ ev ic using -> +let () = define_prim3 "tac_induction" begin fun ev ic using -> let ev = Value.to_bool ev in let ic = Value.to_list to_induction_clause ic in let using = Value.to_option to_constr_with_bindings using in Tac2tactics.induction_destruct true ev ic using end -let () = define_prim1 "tac_red" begin fun _ cl -> +let () = define_prim1 "tac_red" begin fun cl -> let cl = to_clause cl in Tactics.reduce (Red false) cl end -let () = define_prim1 "tac_hnf" begin fun _ cl -> +let () = define_prim1 "tac_hnf" begin fun cl -> let cl = to_clause cl in Tactics.reduce Hnf cl end -let () = define_prim3 "tac_simpl" begin fun _ flags where cl -> +let () = define_prim3 "tac_simpl" begin fun flags where cl -> let flags = to_red_flag flags in let where = Value.to_option to_pattern_with_occs where in let cl = to_clause cl in Tac2tactics.simpl flags where cl end -let () = define_prim2 "tac_cbv" begin fun _ flags cl -> +let () = define_prim2 "tac_cbv" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in Tac2tactics.cbv flags cl end -let () = define_prim2 "tac_cbn" begin fun _ flags cl -> +let () = define_prim2 "tac_cbn" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in Tac2tactics.cbn flags cl end -let () = define_prim2 "tac_lazy" begin fun _ flags cl -> +let () = define_prim2 "tac_lazy" begin fun flags cl -> let flags = to_red_flag flags in let cl = to_clause cl in Tac2tactics.lazy_ flags cl end -let () = define_prim2 "tac_unfold" begin fun _ refs cl -> +let () = define_prim2 "tac_unfold" begin fun refs cl -> let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in let refs = Value.to_list map refs in let cl = to_clause cl in Tac2tactics.unfold refs cl end -let () = define_prim2 "tac_fold" begin fun _ args cl -> +let () = define_prim2 "tac_fold" begin fun args cl -> let args = Value.to_list Value.to_constr args in let cl = to_clause cl in Tactics.reduce (Fold args) cl end -let () = define_prim2 "tac_pattern" begin fun _ where cl -> +let () = define_prim2 "tac_pattern" begin fun where cl -> let where = Value.to_list to_constr_with_occs where in let cl = to_clause cl in Tactics.reduce (Pattern where) cl end -let () = define_prim2 "tac_vm" begin fun _ where cl -> +let () = define_prim2 "tac_vm" begin fun where cl -> let where = Value.to_option to_pattern_with_occs where in let cl = to_clause cl in Tac2tactics.vm where cl end -let () = define_prim2 "tac_native" begin fun _ where cl -> +let () = define_prim2 "tac_native" begin fun where cl -> let where = Value.to_option to_pattern_with_occs where in let cl = to_clause cl in Tac2tactics.native where cl @@ -388,102 +387,102 @@ end (** Reduction functions *) let define_red1 name tac = - let tac bt arg = match arg with - | [x] -> tac bt x >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let tac arg = match arg with + | [x] -> tac x >>= fun c -> Proofview.tclUNIT (Value.of_constr c) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_red2 name tac = - let tac bt arg = match arg with - | [x; y] -> tac bt x y >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let tac arg = match arg with + | [x; y] -> tac x y >>= fun c -> Proofview.tclUNIT (Value.of_constr c) | _ -> assert false in Tac2env.define_primitive (pname name) tac let define_red3 name tac = - let tac bt arg = match arg with - | [x; y; z] -> tac bt x y z >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let tac arg = match arg with + | [x; y; z] -> tac x y z >>= fun c -> Proofview.tclUNIT (Value.of_constr c) | _ -> assert false in Tac2env.define_primitive (pname name) tac -let () = define_red1 "eval_red" begin fun bt c -> +let () = define_red1 "eval_red" begin fun c -> let c = Value.to_constr c in - Tac2tactics.eval_red bt c + Tac2tactics.eval_red c end -let () = define_red1 "eval_hnf" begin fun bt c -> +let () = define_red1 "eval_hnf" begin fun c -> let c = Value.to_constr c in - Tac2tactics.eval_hnf bt c + Tac2tactics.eval_hnf c end -let () = define_red3 "eval_simpl" begin fun bt flags where c -> +let () = define_red3 "eval_simpl" begin fun flags where c -> let flags = to_red_flag flags in let where = Value.to_option to_pattern_with_occs where in let c = Value.to_constr c in - Tac2tactics.eval_simpl bt flags where c + Tac2tactics.eval_simpl flags where c end -let () = define_red2 "eval_cbv" begin fun bt flags c -> +let () = define_red2 "eval_cbv" begin fun flags c -> let flags = to_red_flag flags in let c = Value.to_constr c in - Tac2tactics.eval_cbv bt flags c + Tac2tactics.eval_cbv flags c end -let () = define_red2 "eval_cbn" begin fun bt flags c -> +let () = define_red2 "eval_cbn" begin fun flags c -> let flags = to_red_flag flags in let c = Value.to_constr c in - Tac2tactics.eval_cbn bt flags c + Tac2tactics.eval_cbn flags c end -let () = define_red2 "eval_lazy" begin fun bt flags c -> +let () = define_red2 "eval_lazy" begin fun flags c -> let flags = to_red_flag flags in let c = Value.to_constr c in - Tac2tactics.eval_lazy bt flags c + Tac2tactics.eval_lazy flags c end -let () = define_red2 "eval_unfold" begin fun bt refs c -> +let () = define_red2 "eval_unfold" begin fun refs c -> let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in let refs = Value.to_list map refs in let c = Value.to_constr c in - Tac2tactics.eval_unfold bt refs c + Tac2tactics.eval_unfold refs c end -let () = define_red2 "eval_fold" begin fun bt args c -> +let () = define_red2 "eval_fold" begin fun args c -> let args = Value.to_list Value.to_constr args in let c = Value.to_constr c in - Tac2tactics.eval_fold bt args c + Tac2tactics.eval_fold args c end -let () = define_red2 "eval_pattern" begin fun bt where c -> +let () = define_red2 "eval_pattern" begin fun where c -> let where = Value.to_list (fun p -> to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) p) where in let c = Value.to_constr c in - Tac2tactics.eval_pattern bt where c + Tac2tactics.eval_pattern where c end -let () = define_red2 "eval_vm" begin fun bt where c -> +let () = define_red2 "eval_vm" begin fun where c -> let where = Value.to_option to_pattern_with_occs where in let c = Value.to_constr c in - Tac2tactics.eval_vm bt where c + Tac2tactics.eval_vm where c end -let () = define_red2 "eval_native" begin fun bt where c -> +let () = define_red2 "eval_native" begin fun where c -> let where = Value.to_option to_pattern_with_occs where in let c = Value.to_constr c in - Tac2tactics.eval_native bt where c + Tac2tactics.eval_native where c end -let () = define_prim4 "tac_rewrite" begin fun bt ev rw cl by -> +let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> let ev = Value.to_bool ev in let rw = Value.to_list to_rewriting rw in let cl = to_clause cl in - let to_tac t = Proofview.tclIGNORE (thaw bt t) in + let to_tac t = Proofview.tclIGNORE (thaw t) in let by = Value.to_option to_tac by in Tac2tactics.rewrite ev rw cl by end -let () = define_prim4 "tac_inversion" begin fun bt knd arg pat ids -> +let () = define_prim4 "tac_inversion" begin fun knd arg pat ids -> let knd = to_inversion_kind knd in let arg = to_destruction_arg arg in let pat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) pat in @@ -495,13 +494,13 @@ end let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity -let () = define_prim2 "tac_move" begin fun _ id mv -> +let () = define_prim2 "tac_move" begin fun id mv -> let id = Value.to_ident id in let mv = to_move_location mv in Tactics.move_hyp id mv end -let () = define_prim2 "tac_intro" begin fun _ id mv -> +let () = define_prim2 "tac_intro" begin fun id mv -> let id = Value.to_option Value.to_ident id in let mv = Value.to_option to_move_location mv in let mv = Option.default MoveLast mv in @@ -518,69 +517,69 @@ END let () = define_prim0 "tac_assumption" Tactics.assumption -let () = define_prim1 "tac_transitivity" begin fun _ c -> +let () = define_prim1 "tac_transitivity" begin fun c -> let c = Value.to_constr c in Tactics.intros_transitivity (Some c) end let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) -let () = define_prim1 "tac_cut" begin fun _ c -> +let () = define_prim1 "tac_cut" begin fun c -> let c = Value.to_constr c in Tactics.cut c end -let () = define_prim2 "tac_left" begin fun _ ev bnd -> +let () = define_prim2 "tac_left" begin fun ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in Tactics.left_with_bindings ev bnd end -let () = define_prim2 "tac_right" begin fun _ ev bnd -> +let () = define_prim2 "tac_right" begin fun ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in Tactics.right_with_bindings ev bnd end -let () = define_prim1 "tac_introsuntil" begin fun _ h -> +let () = define_prim1 "tac_introsuntil" begin fun h -> Tactics.intros_until (to_qhyp h) end -let () = define_prim1 "tac_exactnocheck" begin fun _ c -> +let () = define_prim1 "tac_exactnocheck" begin fun c -> Tactics.exact_no_check (Value.to_constr c) end -let () = define_prim1 "tac_vmcastnocheck" begin fun _ c -> +let () = define_prim1 "tac_vmcastnocheck" begin fun c -> Tactics.vm_cast_no_check (Value.to_constr c) end -let () = define_prim1 "tac_nativecastnocheck" begin fun _ c -> +let () = define_prim1 "tac_nativecastnocheck" begin fun c -> Tactics.native_cast_no_check (Value.to_constr c) end -let () = define_prim1 "tac_constructor" begin fun _ ev -> +let () = define_prim1 "tac_constructor" begin fun ev -> let ev = Value.to_bool ev in Tactics.any_constructor ev None end -let () = define_prim3 "tac_constructorn" begin fun _ ev n bnd -> +let () = define_prim3 "tac_constructorn" begin fun ev n bnd -> let ev = Value.to_bool ev in let n = Value.to_int n in let bnd = to_bindings bnd in Tactics.constructor_tac ev None n bnd end -let () = define_prim1 "tac_symmetry" begin fun _ cl -> +let () = define_prim1 "tac_symmetry" begin fun cl -> let cl = to_clause cl in Tactics.intros_symmetry cl end -let () = define_prim2 "tac_split" begin fun _ ev bnd -> +let () = define_prim2 "tac_split" begin fun ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in Tactics.split_with_bindings ev [bnd] end -let () = define_prim1 "tac_rename" begin fun _ ids -> +let () = define_prim1 "tac_rename" begin fun ids -> let map c = match Value.to_tuple c with | [|x; y|] -> (Value.to_ident x, Value.to_ident y) | _ -> assert false @@ -589,72 +588,72 @@ let () = define_prim1 "tac_rename" begin fun _ ids -> Tactics.rename_hyp ids end -let () = define_prim1 "tac_revert" begin fun _ ids -> +let () = define_prim1 "tac_revert" begin fun ids -> let ids = Value.to_list Value.to_ident ids in Tactics.revert ids end let () = define_prim0 "tac_admit" Proofview.give_up -let () = define_prim2 "tac_fix" begin fun _ idopt n -> +let () = define_prim2 "tac_fix" begin fun idopt n -> let idopt = Value.to_option Value.to_ident idopt in let n = Value.to_int n in Tactics.fix idopt n end -let () = define_prim1 "tac_cofix" begin fun _ idopt -> +let () = define_prim1 "tac_cofix" begin fun idopt -> let idopt = Value.to_option Value.to_ident idopt in Tactics.cofix idopt end -let () = define_prim1 "tac_clear" begin fun _ ids -> +let () = define_prim1 "tac_clear" begin fun ids -> let ids = Value.to_list Value.to_ident ids in Tactics.clear ids end -let () = define_prim1 "tac_keep" begin fun _ ids -> +let () = define_prim1 "tac_keep" begin fun ids -> let ids = Value.to_list Value.to_ident ids in Tactics.keep ids end -let () = define_prim1 "tac_clearbody" begin fun _ ids -> +let () = define_prim1 "tac_clearbody" begin fun ids -> let ids = Value.to_list Value.to_ident ids in Tactics.clear_body ids end (** Tactics from extratactics *) -let () = define_prim2 "tac_discriminate" begin fun _ ev arg -> +let () = define_prim2 "tac_discriminate" begin fun ev arg -> let ev = Value.to_bool ev in let arg = Value.to_option to_destruction_arg arg in Tac2tactics.discriminate ev arg end -let () = define_prim3 "tac_injection" begin fun _ ev ipat arg -> +let () = define_prim3 "tac_injection" begin fun ev ipat arg -> let ev = Value.to_bool ev in let ipat = Value.to_option to_intro_patterns ipat in let arg = Value.to_option to_destruction_arg arg in Tac2tactics.injection ev ipat arg end -let () = define_prim1 "tac_absurd" begin fun _ c -> +let () = define_prim1 "tac_absurd" begin fun c -> Contradiction.absurd (Value.to_constr c) end -let () = define_prim1 "tac_contradiction" begin fun _ c -> +let () = define_prim1 "tac_contradiction" begin fun c -> let c = Value.to_option to_constr_with_bindings c in Contradiction.contradiction c end -let () = define_prim4 "tac_autorewrite" begin fun bt all by ids cl -> +let () = define_prim4 "tac_autorewrite" begin fun all by ids cl -> let all = Value.to_bool all in - let by = Value.to_option (fun tac -> Proofview.tclIGNORE (thaw bt tac)) by in + let by = Value.to_option (fun tac -> Proofview.tclIGNORE (thaw tac)) by in let ids = Value.to_list Value.to_ident ids in let cl = to_clause cl in Tac2tactics.autorewrite ~all by ids cl end -let () = define_prim1 "tac_subst" begin fun _ ids -> +let () = define_prim1 "tac_subst" begin fun ids -> let ids = Value.to_list Value.to_ident ids in Equality.subst ids end @@ -663,43 +662,43 @@ let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all (** Auto *) -let () = define_prim3 "tac_trivial" begin fun bt dbg lems dbs -> +let () = define_prim3 "tac_trivial" begin fun dbg lems dbs -> let dbg = to_debug dbg in - let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let map c = thaw c >>= fun c -> return (Value.to_constr c) in let lems = Value.to_list map lems in let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in Tac2tactics.trivial dbg lems dbs end -let () = define_prim5 "tac_eauto" begin fun bt dbg n p lems dbs -> +let () = define_prim5 "tac_eauto" begin fun dbg n p lems dbs -> let dbg = to_debug dbg in let n = Value.to_option Value.to_int n in let p = Value.to_option Value.to_int p in - let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let map c = thaw c >>= fun c -> return (Value.to_constr c) in let lems = Value.to_list map lems in let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in Tac2tactics.eauto dbg n p lems dbs end -let () = define_prim4 "tac_auto" begin fun bt dbg n lems dbs -> +let () = define_prim4 "tac_auto" begin fun dbg n lems dbs -> let dbg = to_debug dbg in let n = Value.to_option Value.to_int n in - let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let map c = thaw c >>= fun c -> return (Value.to_constr c) in let lems = Value.to_list map lems in let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in Tac2tactics.auto dbg n lems dbs end -let () = define_prim4 "tac_newauto" begin fun bt dbg n lems dbs -> +let () = define_prim4 "tac_newauto" begin fun dbg n lems dbs -> let dbg = to_debug dbg in let n = Value.to_option Value.to_int n in - let map c = thaw bt c >>= fun c -> return (Value.to_constr c) in + let map c = thaw c >>= fun c -> return (Value.to_constr c) in let lems = Value.to_list map lems in let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in Tac2tactics.new_auto dbg n lems dbs end -let () = define_prim3 "tac_typeclasses_eauto" begin fun bt str n dbs -> +let () = define_prim3 "tac_typeclasses_eauto" begin fun str n dbs -> let str = Value.to_option to_strategy str in let n = Value.to_option Value.to_int n in let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in @@ -708,8 +707,8 @@ end (** Firstorder *) -let () = define_prim3 "tac_firstorder" begin fun bt tac refs ids -> - let tac = Value.to_option (fun t -> Proofview.tclIGNORE (thaw bt t)) tac in +let () = define_prim3 "tac_firstorder" begin fun tac refs ids -> + let tac = Value.to_option (fun t -> Proofview.tclIGNORE (thaw t)) tac in let refs = Value.to_list Value.to_reference refs in let ids = Value.to_list Value.to_ident ids in Tac2tactics.firstorder tac refs ids diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index dacbb898d3..aa2ee4711a 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -122,62 +122,62 @@ let native where cl = let where = Option.map map_pattern_with_occs where in Tactics.reduce (CbvNative where) cl -let eval_fun bt red c = - Tac2core.pf_apply bt begin fun env sigma -> +let eval_fun red c = + Tac2core.pf_apply begin fun env sigma -> let (redfun, _) = Redexpr.reduction_of_red_expr env red in let (sigma, ans) = redfun env sigma c in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT ans end -let eval_red bt c = - eval_fun bt (Red false) c +let eval_red c = + eval_fun (Red false) c -let eval_hnf bt c = - eval_fun bt Hnf c +let eval_hnf c = + eval_fun Hnf c -let eval_simpl bt flags where c = +let eval_simpl flags where c = let where = Option.map map_pattern_with_occs where in Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun bt (Simpl (flags, where)) c + eval_fun (Simpl (flags, where)) c -let eval_cbv bt flags c = +let eval_cbv flags c = Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun bt (Cbv flags) c + eval_fun (Cbv flags) c -let eval_cbn bt flags c = +let eval_cbn flags c = Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun bt (Cbn flags) c + eval_fun (Cbn flags) c -let eval_lazy bt flags c = +let eval_lazy flags c = Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in - eval_fun bt (Lazy flags) c + eval_fun (Lazy flags) c -let eval_unfold bt occs c = +let eval_unfold occs c = let map (gr, occ) = get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) in Proofview.Monad.List.map map occs >>= fun occs -> - eval_fun bt (Unfold occs) c + eval_fun (Unfold occs) c -let eval_fold bt cl c = - eval_fun bt (Fold cl) c +let eval_fold cl c = + eval_fun (Fold cl) c -let eval_pattern bt where c = +let eval_pattern where c = let where = List.map (fun (pat, occ) -> (occ, pat)) where in - eval_fun bt (Pattern where) c + eval_fun (Pattern where) c -let eval_vm bt where c = +let eval_vm where c = let where = Option.map map_pattern_with_occs where in - eval_fun bt (CbvVm where) c + eval_fun (CbvVm where) c -let eval_native bt where c = +let eval_native where c = let where = Option.map map_pattern_with_occs where in - eval_fun bt (CbvNative where) c + eval_fun (CbvNative where) c let on_destruction_arg tac ev arg = Proofview.Goal.enter begin fun gl -> diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 841e8fe762..f6825d84aa 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -56,28 +56,28 @@ val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit ta val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic -val eval_red : backtrace -> constr -> constr tactic +val eval_red : constr -> constr tactic -val eval_hnf : backtrace -> constr -> constr tactic +val eval_hnf : constr -> constr tactic -val eval_simpl : backtrace -> global_reference glob_red_flag -> +val eval_simpl : global_reference glob_red_flag -> (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic -val eval_cbv : backtrace -> global_reference glob_red_flag -> constr -> constr tactic +val eval_cbv : global_reference glob_red_flag -> constr -> constr tactic -val eval_cbn : backtrace -> global_reference glob_red_flag -> constr -> constr tactic +val eval_cbn : global_reference glob_red_flag -> constr -> constr tactic -val eval_lazy : backtrace -> global_reference glob_red_flag -> constr -> constr tactic +val eval_lazy : global_reference glob_red_flag -> constr -> constr tactic -val eval_unfold : backtrace -> (global_reference * occurrences_expr) list -> constr -> constr tactic +val eval_unfold : (global_reference * occurrences_expr) list -> constr -> constr tactic -val eval_fold : backtrace -> constr list -> constr -> constr tactic +val eval_fold : constr list -> constr -> constr tactic -val eval_pattern : backtrace -> (EConstr.t * occurrences_expr) list -> constr -> constr tactic +val eval_pattern : (EConstr.t * occurrences_expr) list -> constr -> constr tactic -val eval_vm : backtrace -> (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic +val eval_vm : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic -val eval_native : backtrace -> (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic +val eval_native : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic val discriminate : evars_flag -> destruction_arg option -> unit tactic -- cgit v1.2.3 From d577fe086794fda2edb3b98c12606e24c9c92ea1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 7 Sep 2017 16:06:04 +0200 Subject: Fix coq/ltac2#21: Backtraces should print Ltac2 closures. --- src/tac2entries.ml | 4 ++-- src/tac2expr.mli | 3 ++- src/tac2interp.ml | 8 ++++++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index eed7eb6def..d596a61152 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -757,8 +757,8 @@ let _ = Goptions.declare_bool_option { } let pr_frame = function -| FrLtac None -> str "Call " -| FrLtac (Some kn) -> +| FrAnon e -> str "Call " +| FrLtac kn -> str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) | FrPrim ml -> str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 77e2cfef0e..0b9923f7b9 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -181,7 +181,8 @@ type strexpr = type tag = int type frame = -| FrLtac of ltac_constant option +| FrLtac of ltac_constant +| FrAnon of glb_tacexpr | FrPrim of ml_tactic_name | FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame diff --git a/src/tac2interp.ml b/src/tac2interp.ml index f37b4f8e9c..19efeb7669 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -140,10 +140,14 @@ let rec interp (ist : environment) = function and interp_app f = (); fun args -> match f with | { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> + let frame = match kn with + | None -> FrAnon e + | Some kn -> FrLtac kn + in let rec push ist ids args = match ids, args with - | [], [] -> with_frame (FrLtac kn) (interp ist e) + | [], [] -> with_frame frame (interp ist e) | [], _ :: _ -> - with_frame (FrLtac kn) (interp ist e) >>= fun f -> Tac2ffi.to_closure f args + with_frame frame (interp ist e) >>= fun f -> Tac2ffi.to_closure f args | _ :: _, [] -> let cls = { clos_ref = kn; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in let f = interp_app cls in -- cgit v1.2.3 From 643832c053e0255dd356231f4e5887db0228c2cd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 7 Sep 2017 16:28:55 +0200 Subject: Slightly better printing for anonymous closures. --- src/tac2entries.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index d596a61152..7cffdc6590 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -757,7 +757,7 @@ let _ = Goptions.declare_bool_option { } let pr_frame = function -| FrAnon e -> str "Call " +| FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" | FrLtac kn -> str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) | FrPrim ml -> -- cgit v1.2.3 From bdd594093b4fb7e46a6cae0135b6630d75bae6f6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 7 Sep 2017 23:45:26 +0200 Subject: Fix coq/ltac2#22: Argument to Tactic_failure should be printed. We implement a printer for toplevel values and use it for exceptions in particular. --- src/ltac2_plugin.mlpack | 2 +- src/tac2entries.ml | 7 ++- src/tac2print.ml | 123 ++++++++++++++++++++++++++++++++++++++++++++++-- src/tac2print.mli | 9 ++++ 4 files changed, 133 insertions(+), 8 deletions(-) diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 00ba5bc58e..70f97b9d1e 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -1,8 +1,8 @@ Tac2dyn Tac2env +Tac2ffi Tac2print Tac2intern -Tac2ffi Tac2interp Tac2entries Tac2quote diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 7cffdc6590..9a2693379b 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -768,8 +768,11 @@ let pr_frame = function obj.Tac2env.ml_print (Global.env ()) arg let () = register_handler begin function -| Tac2interp.LtacError (kn, _, bt) -> - let c = Tac2print.pr_constructor kn in (** FIXME *) +| Tac2interp.LtacError (kn, args, bt) -> + let t_exn = KerName.make2 Tac2env.coq_prefix (Label.make "exn") in + let v = ValOpn (kn, args) in + let t = GTypRef (Other t_exn, []) in + let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in let bt = if !Tac2interp.print_ltac2_backtrace then fnl () ++ str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt diff --git a/src/tac2print.ml b/src/tac2print.ml index 75ad2082d4..fd1d759cce 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -112,14 +112,14 @@ let pr_name = function let find_constructor n empty def = let rec find n = function | [] -> assert false - | (id, []) :: rem -> + | (id, []) as ans :: rem -> if empty then - if Int.equal n 0 then id + if Int.equal n 0 then ans else find (pred n) rem else find n rem - | (id, _ :: _) :: rem -> + | (id, _ :: _) as ans :: rem -> if not empty then - if Int.equal n 0 then id + if Int.equal n 0 then ans else find (pred n) rem else find n rem in @@ -130,7 +130,7 @@ let pr_internal_constructor tpe n is_const = | (_, GTydAlg data) -> data | _ -> assert false in - let id = find_constructor n is_const data.galg_constructors in + let (id, _) = find_constructor n is_const data.galg_constructors in let kn = change_kn_label tpe id in pr_constructor kn @@ -302,3 +302,116 @@ let pr_glbexpr_gen lvl c = let pr_glbexpr c = pr_glbexpr_gen E5 c + +(** Toplevel printers *) + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst.(id) +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let unfold kn args = + let (nparams, def) = Tac2env.interp_type kn in + match def with + | GTydDef (Some def) -> + let args = Array.of_list args in + Some (subst_type args def) + | _ -> None + +let rec kind t = match t with +| GTypVar id -> GTypVar id +| GTypRef (Other kn, tl) -> + begin match unfold kn tl with + | None -> t + | Some t -> kind t + end +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +let printers = ref KNmap.empty + +let register_val_printer kn pr = + printers := KNmap.add kn pr !printers + +open Tac2ffi + +let rec pr_valexpr env sigma v t = match kind t with +| GTypVar _ -> str "" +| GTypRef (Other kn, params) -> + let pr = try Some (KNmap.find kn !printers) with Not_found -> None in + begin match pr with + | Some pr -> pr.val_printer env sigma v params + | None -> + let n, repr = Tac2env.interp_type kn in + match repr with + | GTydDef None -> str "" + | GTydDef (Some _) -> + (** Shouldn't happen thanks to kind *) + assert false + | GTydAlg alg -> + begin match v with + | ValInt n -> pr_internal_constructor kn n true + | ValBlk (n, args) -> + let (id, tpe) = find_constructor n false alg.galg_constructors in + let knc = change_kn_label kn id in + let args = pr_constrargs env sigma params args tpe in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + | _ -> str "" + end + | GTydRec rcd -> str "{}" + | GTydOpn -> + begin match v with + | ValOpn (knc, [||]) -> pr_constructor knc + | ValOpn (knc, args) -> + let data = Tac2env.interp_constructor knc in + let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + | _ -> str "" + end + end +| GTypArrow _ -> str "" +| GTypRef (Tuple _, tl) -> + let blk = Array.to_list (block.r_to v) in + if List.length blk == List.length tl then + let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in + hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") + else + str "" + +and pr_constrargs env sigma params args tpe = + let subst = Array.of_list params in + let tpe = List.map (fun t -> subst_type subst t) tpe in + let args = Array.to_list args in + let args = List.combine args tpe in + prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args + +let register_init n f = + let kn = KerName.make2 Tac2env.coq_prefix (Label.make n) in + register_val_printer kn { val_printer = fun _ _ v _ -> f v } + +let () = register_init "int" begin fun n -> + let n = to_int n in + Pp.int n +end + +let () = register_init "string" begin fun s -> + let s = to_string s in + Pp.quote (Pp.str s) +end + +let () = register_init "ident" begin fun id -> + let id = to_ident id in + Pp.str "@" ++ Id.print id +end + +let () = register_init "message" begin fun pp -> + str "message:(" ++ to_pp pp ++ str ")" +end + +let () = register_init "err" begin fun e -> + let (e, _) = to_ext val_exn e in + str "err:(" ++ CErrors.print_no_report e ++ str ")" +end diff --git a/src/tac2print.mli b/src/tac2print.mli index 737e813ed3..01abd1efb1 100644 --- a/src/tac2print.mli +++ b/src/tac2print.mli @@ -29,6 +29,15 @@ val pr_projection : ltac_projection -> Pp.t val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t val pr_glbexpr : glb_tacexpr -> Pp.t +(** {5 Printing values}*) + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +val register_val_printer : type_constant -> val_printer -> unit + +val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp.t + (** {5 Utilities} *) val int_name : unit -> (int -> string) -- cgit v1.2.3 From 9820b2c72cbf2da61cf44456334b38683799fd58 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Sep 2017 01:39:51 +0200 Subject: Fix coq/ltac2#24: There should be a way to turn an exn into a message. --- src/tac2core.ml | 9 +++++++++ theories/Message.v | 3 +++ 2 files changed, 12 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index 4a35442b04..f969183dce 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -37,6 +37,7 @@ let t_constr = coq_core "constr" let t_pattern = coq_core "pattern" let t_ident = coq_core "ident" let t_option = coq_core "option" +let t_exn = coq_core "exn" let t_reference = std_core "reference" let c_nil = coq_core "[]" @@ -188,6 +189,14 @@ let () = define1 "message_of_ident" ident begin fun c -> return (Value.of_pp pp) end +let () = define1 "message_of_exn" valexpr begin fun v -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let pp = Tac2print.pr_valexpr env sigma v (GTypRef (Other Core.t_exn, [])) in + return (Value.of_pp pp) +end + + let () = define2 "message_concat" pp pp begin fun m1 m2 -> return (Value.of_pp (Pp.app m1 m2)) end diff --git a/theories/Message.v b/theories/Message.v index 45f4b221db..7bffe0746b 100644 --- a/theories/Message.v +++ b/theories/Message.v @@ -19,4 +19,7 @@ Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". (** Panics if there is more than one goal under focus. *) +Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". +(** Panics if there is more than one goal under focus. *) + Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". -- cgit v1.2.3 From 2b66bf0083fd85cf2fc983dbca75b848194f897f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Sep 2017 02:32:54 +0200 Subject: Fix coq/ltac2#27: ... is not a particularly helpful printing of an error message. --- src/tac2print.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tac2print.ml b/src/tac2print.ml index fd1d759cce..ee45b33706 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -412,6 +412,7 @@ let () = register_init "message" begin fun pp -> end let () = register_init "err" begin fun e -> - let (e, _) = to_ext val_exn e in + let e = to_ext val_exn e in + let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in str "err:(" ++ CErrors.print_no_report e ++ str ")" end -- cgit v1.2.3 From 555a7cf0ce4457ecfbf68cd12dd0e801728f6662 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Sep 2017 19:02:51 +0200 Subject: Using a dedicated argument for tactic quotations. This prevents having to go through an expensive phase of goal-building, when we can simply type-check the term. --- src/g_ltac2.ml4 | 4 ++-- src/tac2core.ml | 17 +++++++++++++++++ src/tac2env.ml | 1 + src/tac2env.mli | 1 + src/tac2intern.ml | 25 +++++++++++++++++++++++++ 5 files changed, 46 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 5c285010e9..7295f31181 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -717,8 +717,8 @@ GEXTEND Gram let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) | test_dollar_ident; "$"; id = Prim.ident -> - let tac = Tac2quote.of_exact_var ~loc:!@loc (Loc.tag ~loc:!@loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + let id = Loc.tag ~loc:!@loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index f969183dce..8b83e501f9 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -912,6 +912,23 @@ let () = in Pretyping.register_constr_interp0 wit_ltac2 interp +let () = + let interp ist env sigma concl id = + let ist = Tac2interp.get_env ist in + let c = Id.Map.find id ist.env_ist in + let c = Value.to_constr c in + let evdref = ref sigma in + let () = Typing.e_check env evdref c concl in + (c, !evdref) + in + Pretyping.register_constr_interp0 wit_ltac2_quotation interp + +let () = + let pr_raw id = mt () in + let pr_glb id = str "$" ++ Id.print id in + let pr_top _ = mt () in + Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top + (** Ltac2 in Ltac1 *) let () = diff --git a/src/tac2env.ml b/src/tac2env.ml index ef2b44afb9..831c6a3b42 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -276,6 +276,7 @@ let std_prefix = (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2:value" +let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" let is_constructor qid = let (_, id) = repr_qualid qid in diff --git a/src/tac2env.mli b/src/tac2env.mli index 49c9910a44..89e22f07d5 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -132,6 +132,7 @@ val std_prefix : ModPath.t (** {5 Generic arguments} *) val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type (** {5 Helper functions} *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 2dcd8b8da3..0efd9a3005 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -25,6 +25,7 @@ let t_int = coq_type "int" let t_string = coq_type "string" let t_array = coq_type "array" let t_list = coq_type "list" +let t_constr = coq_type "constr" let c_nil = GTacCst (Other t_list, 0, []) let c_cons e el = GTacCst (Other t_list, 0, [e; el]) @@ -1511,3 +1512,27 @@ let () = in Genintern.register_intern0 wit_ltac2 intern let () = Genintern.register_subst0 wit_ltac2 subst_expr + +let () = + let open Genintern in + let intern ist (loc, id) = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (** Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let t = + try Id.Map.find id env.env_var + with Not_found -> + CErrors.user_err ?loc (str "Unbound value " ++ Id.print id) + in + let t = fresh_mix_type_scheme env t in + let () = unify ?loc env t (GTypRef (Other t_constr, [])) in + (ist, id) + in + Genintern.register_intern0 wit_ltac2_quotation intern + +let () = Genintern.register_subst0 wit_ltac2_quotation (fun _ id -> id) -- cgit v1.2.3 From 0ece31492e4cf2813025aab3c4972bb769a3dea2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Sep 2017 02:02:52 +0200 Subject: Fix coq/ltac2#25: Control.case should not be able to catch Control.throw. When crossing constr boundaries, we mark exceptions as being fatal not to catch them. --- src/tac2core.ml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 8b83e501f9..e01b9f3086 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -103,9 +103,12 @@ let err_matchfailure bt = let thaw f = f [v_unit] +let fatal_flag : unit Exninfo.t = Exninfo.make () +let fatal_info = Exninfo.add Exninfo.null fatal_flag () + let throw e = Tac2interp.get_backtrace >>= fun bt -> - Proofview.tclLIFT (Proofview.NonLogical.raise (e bt)) + Proofview.tclLIFT (Proofview.NonLogical.raise ~info:fatal_info (e bt)) let fail e = Tac2interp.get_backtrace >>= fun bt -> Proofview.tclZERO (e bt) @@ -571,6 +574,7 @@ end let () = define1 "throw" exn begin fun (e, info) -> Tac2interp.get_backtrace >>= fun bt -> let e = set_bt bt e in + let info = Exninfo.add info fatal_flag () in Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) end @@ -784,16 +788,24 @@ let intern_constr self ist c = let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in (GlbVal c, gtypref t_constr) +let catchable_exception = function + | Logic_monad.Exception _ -> false + | e -> CErrors.noncritical e + let interp_constr flags ist c = let open Pretyping in let ist = to_lvar ist in pf_apply begin fun env sigma -> - Proofview.V82.wrap_exceptions begin fun () -> + try let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in let c = ValExt (Value.val_constr, c) in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c - end + with e when catchable_exception e -> + let (e, info) = CErrors.push e in + match Exninfo.get info fatal_flag with + | None -> Proofview.tclZERO ~info e + | Some () -> Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) end let () = -- cgit v1.2.3 From 254785a4a7f8373b5b0c4a289c2184cac3b5c420 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Sep 2017 19:58:25 +0200 Subject: Moving Ltac2 backtraces to the Exninfo mechanism. I don't know why, but on CoqIDE this triggers a printing of the backtrace twice. This is not reproducible with coqtop. --- src/tac2core.ml | 46 +++++++++++++++++++++------------------------- src/tac2entries.ml | 23 +++++++++++++++-------- src/tac2entries.mli | 4 ++++ src/tac2ffi.ml | 6 +++--- src/tac2ffi.mli | 2 +- src/tac2interp.mli | 2 +- 6 files changed, 45 insertions(+), 38 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index e01b9f3086..ab87fa7739 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -87,17 +87,17 @@ let of_result f = function (** Stdlib exceptions *) -let err_notfocussed bt = - Tac2interp.LtacError (coq_core "Not_focussed", [||], bt) +let err_notfocussed = + Tac2interp.LtacError (coq_core "Not_focussed", [||]) -let err_outofbounds bt = - Tac2interp.LtacError (coq_core "Out_of_bounds", [||], bt) +let err_outofbounds = + Tac2interp.LtacError (coq_core "Out_of_bounds", [||]) -let err_notfound bt = - Tac2interp.LtacError (coq_core "Not_found", [||], bt) +let err_notfound = + Tac2interp.LtacError (coq_core "Not_found", [||]) -let err_matchfailure bt = - Tac2interp.LtacError (coq_core "Match_failure", [||], bt) +let err_matchfailure = + Tac2interp.LtacError (coq_core "Match_failure", [||]) (** Helper functions *) @@ -106,16 +106,18 @@ let thaw f = f [v_unit] let fatal_flag : unit Exninfo.t = Exninfo.make () let fatal_info = Exninfo.add Exninfo.null fatal_flag () -let throw e = +let set_bt info = Tac2interp.get_backtrace >>= fun bt -> - Proofview.tclLIFT (Proofview.NonLogical.raise ~info:fatal_info (e bt)) + Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) -let fail e = - Tac2interp.get_backtrace >>= fun bt -> Proofview.tclZERO (e bt) +let throw ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + let info = Exninfo.add info fatal_flag () in + Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) -let set_bt bt e = match e with -| Tac2interp.LtacError (kn, args, _) -> Tac2interp.LtacError (kn, args, bt) -| e -> e +let fail ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + Proofview.tclZERO ~info e let return x = Proofview.tclUNIT x let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -572,19 +574,14 @@ end (** Error *) let () = define1 "throw" exn begin fun (e, info) -> - Tac2interp.get_backtrace >>= fun bt -> - let e = set_bt bt e in - let info = Exninfo.add info fatal_flag () in - Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) + throw ~info e end (** Control *) (** exn -> 'a *) let () = define1 "zero" exn begin fun (e, info) -> - Tac2interp.get_backtrace >>= fun bt -> - let e = set_bt bt e in - Proofview.tclZERO ~info e + fail ~info e end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) @@ -624,8 +621,7 @@ let () = define1 "case" closure begin fun f -> let k = function | [e] -> let (e, info) = Value.to_exn e in - Tac2interp.get_backtrace >>= fun bt -> - let e = set_bt bt e in + set_bt info >>= fun info -> k (e, info) | _ -> assert false in @@ -805,7 +801,7 @@ let interp_constr flags ist c = let (e, info) = CErrors.push e in match Exninfo.get info fatal_flag with | None -> Proofview.tclZERO ~info e - | Some () -> Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) + | Some () -> throw ~info e end let () = diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 9a2693379b..208231b814 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -756,6 +756,8 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); } +let backtrace : backtrace Exninfo.t = Exninfo.make () + let pr_frame = function | FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" | FrLtac kn -> @@ -768,21 +770,26 @@ let pr_frame = function obj.Tac2env.ml_print (Global.env ()) arg let () = register_handler begin function -| Tac2interp.LtacError (kn, args, bt) -> +| Tac2interp.LtacError (kn, args) -> let t_exn = KerName.make2 Tac2env.coq_prefix (Label.make "exn") in let v = ValOpn (kn, args) in let t = GTypRef (Other t_exn, []) in let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in - let bt = - if !Tac2interp.print_ltac2_backtrace then - fnl () ++ str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt - else - mt () - in - hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) ++ bt + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) | _ -> raise Unhandled end +let () = ExplainErr.register_additional_error_info begin fun (e, info) -> + if !Tac2interp.print_ltac2_backtrace then + let bt = Exninfo.get info backtrace in + let bt = Option.default [] bt in + let bt = + str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () + in + Some (Loc.tag @@ Some bt) + else raise Exit +end + (** Printing *) let print_ltac ref = diff --git a/src/tac2entries.mli b/src/tac2entries.mli index dda1653593..7c71130402 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -49,6 +49,10 @@ val print_ltac : Libnames.reference -> unit (** Evaluate a tactic expression in the current environment *) val call : default:bool -> raw_tacexpr -> unit +(** {5 Toplevel exceptions} *) + +val backtrace : backtrace Exninfo.t + (** {5 Parsing entries} *) module Pltac : diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index fb97177c4d..16c17cce62 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -43,7 +43,7 @@ match Val.eq tag tag' with (** Exception *) -exception LtacError of KerName.t * valexpr array * backtrace +exception LtacError of KerName.t * valexpr array (** Conversion functions *) @@ -169,7 +169,7 @@ let internal_err = (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with -| LtacError (kn, c, _) -> ValOpn (kn, c) +| LtacError (kn, c) -> ValOpn (kn, c) | _ -> ValOpn (internal_err, [|of_ext val_exn c|]) let to_exn c = match c with @@ -177,7 +177,7 @@ let to_exn c = match c with if Names.KerName.equal kn internal_err then to_ext val_exn c.(0) else - (LtacError (kn, c, []), Exninfo.null) + (LtacError (kn, c), Exninfo.null) | _ -> assert false let exn = { diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index dfc87f7db3..05f4d210ab 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -121,5 +121,5 @@ val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Exception *) -exception LtacError of KerName.t * valexpr array * backtrace +exception LtacError of KerName.t * valexpr array (** Ltac2-defined exceptions seen from OCaml side *) diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 1003e9f1eb..3acca72367 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -22,7 +22,7 @@ val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound (** {5 Exceptions} *) -exception LtacError of KerName.t * valexpr array * backtrace +exception LtacError of KerName.t * valexpr array (** Ltac2-defined exceptions seen from OCaml side *) (** {5 Backtrace} *) -- cgit v1.2.3 From a059c181c3b2d6c1f9c3682c15270c0942430f39 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Sep 2017 20:40:11 +0200 Subject: Fix coq/ltac2#18: Terms should show a backtrace when Set Ltac2 Backtrace is set. --- src/tac2core.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index ab87fa7739..9920b4c805 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -799,6 +799,7 @@ let interp_constr flags ist c = Proofview.tclUNIT c with e when catchable_exception e -> let (e, info) = CErrors.push e in + set_bt info >>= fun info -> match Exninfo.get info fatal_flag with | None -> Proofview.tclZERO ~info e | Some () -> throw ~info e -- cgit v1.2.3 From 91a9313fbe24dfb0c9b7fcaa31e3c11bf055450a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Sep 2017 20:43:32 +0200 Subject: Fix coq/ltac2#26: Ltac1 gives no backtraces. --- src/tac2core.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 9920b4c805..f19f45fa4e 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -895,7 +895,9 @@ let () = let ist = Ltac_plugin.Tacinterp.default_ist () in (** FUCK YOU API *) let ist = { ist with API.Geninterp.lfun = (Obj.magic lfun) } in - (Obj.magic Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) >>= fun () -> + let tac = (Obj.magic Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in + let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in + Proofview.tclOR tac wrap >>= fun () -> return v_unit in let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in -- cgit v1.2.3 From 6bc632021b47103b57abb34836766a57198d9cb4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Sep 2017 20:45:48 +0200 Subject: Update backtraces only when the Ltac2 Backtrace flag is set. --- src/tac2core.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index f19f45fa4e..7bd0164b4d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -107,8 +107,10 @@ let fatal_flag : unit Exninfo.t = Exninfo.make () let fatal_info = Exninfo.add Exninfo.null fatal_flag () let set_bt info = - Tac2interp.get_backtrace >>= fun bt -> - Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) + if !Tac2interp.print_ltac2_backtrace then + Tac2interp.get_backtrace >>= fun bt -> + Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) + else Proofview.tclUNIT info let throw ?(info = Exninfo.null) e = set_bt info >>= fun info -> -- cgit v1.2.3 From c7c1f9b2da838a604c479bb2bc162fef621524ed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Sep 2017 20:46:59 +0200 Subject: If backtrace is missing, don't print it. --- src/tac2entries.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 208231b814..26f96f7d72 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -782,7 +782,10 @@ end let () = ExplainErr.register_additional_error_info begin fun (e, info) -> if !Tac2interp.print_ltac2_backtrace then let bt = Exninfo.get info backtrace in - let bt = Option.default [] bt in + let bt = match bt with + | Some bt -> bt + | None -> raise Exit + in let bt = str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () in -- cgit v1.2.3 From 46095430ed07306ba3380ea8192540793c5c0a26 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 13 Sep 2017 21:44:43 +0200 Subject: Adding quotations for the generalize tactic. --- src/g_ltac2.ml4 | 18 +++++++++++++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 5 +++++ src/tac2quote.ml | 10 ++++++++++ src/tac2quote.mli | 2 ++ theories/Notations.v | 6 ++++++ 8 files changed, 43 insertions(+), 1 deletion(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 7295f31181..dad1b71685 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -369,7 +369,7 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching - q_hintdb q_move_location; + q_hintdb q_move_location q_generalizations; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -702,6 +702,22 @@ GEXTEND Gram q_move_location: [ [ mv = move_location -> mv ] ] ; + opt_generalization: + [ [ occs = occs; na = OPT ident_or_anti -> (occs, na) + | -> Loc.tag ~loc:!@loc QAllOccurrences, None + ] ] + ; + generalization: + [ [ c = Constr.constr; (occs, na) = opt_generalization -> + Loc.tag ~loc:!@loc (c, occs, na) + ] ] + ; + generalizations: + [ [ g = LIST1 generalization SEP "," -> Loc.tag ~loc:!@loc g ] ] + ; + q_generalizations: + [ [ g = generalizations -> g ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 7bd0164b4d..1eef098311 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1118,6 +1118,7 @@ let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location +let () = add_expr_scope "generalizations" q_generalizations Tac2quote.of_generalizations let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 26f96f7d72..2025753aec 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -40,6 +40,7 @@ let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" +let q_generalizations = Pcoq.Gram.entry_create "tactic:q_generalizations" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 7c71130402..d91032c2a8 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -79,6 +79,7 @@ val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry val q_hintdb : hintdb Pcoq.Gram.entry val q_move_location : move_location Pcoq.Gram.entry +val q_generalizations : generalizations Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 7d02022e07..59c7ad6f3f 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -139,3 +139,8 @@ type move_location_r = | QMoveLast type move_location = move_location_r located + +type generalization = + (Constrexpr.constr_expr * occurrences * Id.t located or_anti option) located + +type generalizations = generalization list located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index f14612d58f..a5c5c7d31f 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -370,3 +370,13 @@ let of_move_location (loc, mv) = match mv with | QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] | QMoveFirst -> std_constructor ?loc "MoveFirst" [] | QMoveLast -> std_constructor ?loc "MoveLast" [] + +let of_generalization (loc, (c, occ, na)) = + of_tuple ?loc [ + of_open_constr c; + of_occurrences occ; + of_option (fun id -> of_anti of_ident id) na; + ] + +let of_generalizations (loc, l) = + of_list ?loc of_generalization l diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 9f42c60042..d31ce455eb 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -71,6 +71,8 @@ val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr val of_exact_var : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) +val of_generalizations : generalizations -> raw_tacexpr + val of_dispatch : dispatch -> raw_tacexpr val of_strategy_flag : strategy_flag -> raw_tacexpr diff --git a/theories/Notations.v b/theories/Notations.v index 9b39942ca5..e393002f55 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -284,6 +284,12 @@ Ltac2 Notation "einduction" use(thunk(opt(seq("using", constr, with_bindings)))) := induction0 true ic use. +Ltac2 generalize0 gen := + enter_h false (fun _ gen => Std.generalize gen) gen. + +Ltac2 Notation "generalize" gen(thunk(generalizations)) := + generalize0 gen. + Ltac2 destruct0 ev ic use := let f ev use := Std.destruct ev ic use in enter_h ev f use. -- cgit v1.2.3 From c6fb27a363b38c30c7f9953d5f74e9eb98a26387 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 13 Sep 2017 22:53:29 +0200 Subject: Better printing for list literals. --- src/tac2print.ml | 72 +++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 50 insertions(+), 22 deletions(-) diff --git a/src/tac2print.ml b/src/tac2print.ml index ee45b33706..7113b01610 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -21,6 +21,10 @@ let change_kn_label kn id = let paren p = hov 2 (str "(" ++ p ++ str ")") +let t_list = + KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string "list")) + + (** Type printing *) type typ_level = @@ -187,28 +191,7 @@ let pr_glbexpr_gen lvl c = in paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) | GTacCst (Other tpe, n, cl) -> - begin match Tac2env.interp_type tpe with - | _, GTydAlg def -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let cstr = pr_internal_constructor tpe n (List.is_empty cl) in - let cl = match cl with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl - in - paren (hov 2 (cstr ++ cl)) - | _, GTydRec def -> - let args = List.combine def cl in - let pr_arg ((id, _, _), arg) = - let kn = change_kn_label tpe id in - pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg - in - let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in - hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") - | _, (GTydDef _ | GTydOpn) -> assert false - end + pr_applied_constructor lvl tpe n cl | GTacCse (e, info, cst_br, ncst_br) -> let e = pr_glbexpr E5 e in let br = match info with @@ -297,9 +280,54 @@ let pr_glbexpr_gen lvl c = in hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ qstring prm.mltac_tactic ++ args) + and pr_applied_constructor lvl tpe n cl = + let _, data = Tac2env.interp_type tpe in + if KerName.equal tpe t_list then + let rec factorize accu = function + | GTacCst (_, 0, []) -> accu, None + | GTacCst (_, 0, [e; l]) -> factorize (e :: accu) l + | e -> accu, Some e + in + let l, e = factorize [] (GTacCst (Other tpe, n, cl)) in + match e with + | None -> + let pr e = pr_glbexpr E4 e in + hov 2 (str "[" ++ prlist_with_sep pr_semicolon pr (List.rev l) ++ str "]") + | Some e -> + let paren = match lvl with + | E0 | E1 | E2 -> paren + | E3 | E4 | E5 -> fun x -> x + in + let pr e = pr_glbexpr E1 e in + let pr_cons () = spc () ++ str "::" ++ spc () in + paren (hov 2 (prlist_with_sep pr_cons pr (List.rev (e :: l)))) + else match data with + | GTydAlg def -> + let paren = match lvl with + | E0 -> + if List.is_empty cl then fun x -> x else paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let cstr = pr_internal_constructor tpe n (List.is_empty cl) in + let cl = match cl with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl + in + paren (hov 2 (cstr ++ cl)) + | GTydRec def -> + let args = List.combine def cl in + let pr_arg ((id, _, _), arg) = + let kn = change_kn_label tpe id in + pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg + in + let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in + hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") + | (GTydDef _ | GTydOpn) -> assert false in hov 0 (pr_glbexpr lvl c) + + let pr_glbexpr c = pr_glbexpr_gen E5 c -- cgit v1.2.3 From 4ed40a9427f67ab6091f1af5457ffdec5e156d12 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Sep 2017 00:02:39 +0200 Subject: Use a simpler syntax for generalize grammar. This removes the use for a quotation. --- src/g_ltac2.ml4 | 18 +----------------- src/tac2core.ml | 1 - src/tac2entries.ml | 1 - src/tac2entries.mli | 1 - src/tac2qexpr.mli | 5 ----- src/tac2quote.ml | 10 ---------- src/tac2quote.mli | 2 -- theories/Notations.v | 3 ++- 8 files changed, 3 insertions(+), 38 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index dad1b71685..7295f31181 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -369,7 +369,7 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching - q_hintdb q_move_location q_generalizations; + q_hintdb q_move_location; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -702,22 +702,6 @@ GEXTEND Gram q_move_location: [ [ mv = move_location -> mv ] ] ; - opt_generalization: - [ [ occs = occs; na = OPT ident_or_anti -> (occs, na) - | -> Loc.tag ~loc:!@loc QAllOccurrences, None - ] ] - ; - generalization: - [ [ c = Constr.constr; (occs, na) = opt_generalization -> - Loc.tag ~loc:!@loc (c, occs, na) - ] ] - ; - generalizations: - [ [ g = LIST1 generalization SEP "," -> Loc.tag ~loc:!@loc g ] ] - ; - q_generalizations: - [ [ g = generalizations -> g ] ] - ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1eef098311..7bd0164b4d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1118,7 +1118,6 @@ let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location -let () = add_expr_scope "generalizations" q_generalizations Tac2quote.of_generalizations let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 2025753aec..26f96f7d72 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -40,7 +40,6 @@ let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" -let q_generalizations = Pcoq.Gram.entry_create "tactic:q_generalizations" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index d91032c2a8..7c71130402 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -79,7 +79,6 @@ val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry val q_hintdb : hintdb Pcoq.Gram.entry val q_move_location : move_location Pcoq.Gram.entry -val q_generalizations : generalizations Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 59c7ad6f3f..7d02022e07 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -139,8 +139,3 @@ type move_location_r = | QMoveLast type move_location = move_location_r located - -type generalization = - (Constrexpr.constr_expr * occurrences * Id.t located or_anti option) located - -type generalizations = generalization list located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index a5c5c7d31f..f14612d58f 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -370,13 +370,3 @@ let of_move_location (loc, mv) = match mv with | QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] | QMoveFirst -> std_constructor ?loc "MoveFirst" [] | QMoveLast -> std_constructor ?loc "MoveLast" [] - -let of_generalization (loc, (c, occ, na)) = - of_tuple ?loc [ - of_open_constr c; - of_occurrences occ; - of_option (fun id -> of_anti of_ident id) na; - ] - -let of_generalizations (loc, l) = - of_list ?loc of_generalization l diff --git a/src/tac2quote.mli b/src/tac2quote.mli index d31ce455eb..9f42c60042 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -71,8 +71,6 @@ val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr val of_exact_var : ?loc:Loc.t -> Id.t located -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) -val of_generalizations : generalizations -> raw_tacexpr - val of_dispatch : dispatch -> raw_tacexpr val of_strategy_flag : strategy_flag -> raw_tacexpr diff --git a/theories/Notations.v b/theories/Notations.v index e393002f55..9b2b04f9e6 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -287,7 +287,8 @@ Ltac2 Notation "einduction" Ltac2 generalize0 gen := enter_h false (fun _ gen => Std.generalize gen) gen. -Ltac2 Notation "generalize" gen(thunk(generalizations)) := +Ltac2 Notation "generalize" + gen(thunk(list1(seq (open_constr, occurrences, opt(seq("as", ident))), ","))) := generalize0 gen. Ltac2 destruct0 ev ic use := -- cgit v1.2.3 From c53fb4be8c65a89dd03d4aedc2fc65d9807da915 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Sep 2017 00:15:09 +0200 Subject: Binding the pose/set family of tactics. --- src/g_ltac2.ml4 | 37 ++++++++++++++++++++++++++++++++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 2 ++ src/tac2quote.ml | 3 +++ src/tac2quote.mli | 2 ++ src/tac2stdlib.ml | 7 +++---- tests/example2.v | 14 ++++++++++++++ theories/Notations.v | 27 +++++++++++++++++++++------ theories/Std.v | 2 +- 11 files changed, 85 insertions(+), 12 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 7295f31181..dfd586d5ef 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -40,6 +40,27 @@ let test_lpar_idnum_coloneq = | _ -> err ()) | _ -> err ()) +(* Hack to recognize "(x := t)" and "($x := t)" *) +let test_lpar_coloneq = + Gram.Entry.of_parser "test_coloneq" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ -> + (match stream_nth 2 strm with + | KEYWORD ":=" -> () + | _ -> err ()) + | KEYWORD "$" -> + (match stream_nth 2 strm with + | IDENT _ -> + (match stream_nth 3 strm with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + (* Hack to recognize "(x)" *) let test_lpar_id_rpar = Gram.Entry.of_parser "lpar_id_coloneq" @@ -369,7 +390,7 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching - q_hintdb q_move_location; + q_hintdb q_move_location q_pose; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -702,6 +723,20 @@ GEXTEND Gram q_move_location: [ [ mv = move_location -> mv ] ] ; + as_name: + [ [ -> None + | "as"; id = ident_or_anti -> Some id + ] ] + ; + pose: + [ [ test_lpar_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (Some id, c) + | c = Constr.constr; na = as_name -> Loc.tag ~loc:!@loc (na, c) + ] ] + ; + q_pose: + [ [ p = pose -> p ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 7bd0164b4d..bb6578090d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1118,6 +1118,7 @@ let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location +let () = add_expr_scope "pose" q_pose Tac2quote.of_pose let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 26f96f7d72..d622aaba69 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -40,6 +40,7 @@ let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" +let q_pose = Pcoq.Gram.entry_create "tactic:q_pose" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 7c71130402..55e658884b 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -79,6 +79,7 @@ val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry val q_hintdb : hintdb Pcoq.Gram.entry val q_move_location : move_location Pcoq.Gram.entry +val q_pose : pose Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 7d02022e07..580039afe5 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -139,3 +139,5 @@ type move_location_r = | QMoveLast type move_location = move_location_r located + +type pose = (Id.t located or_anti option * Constrexpr.constr_expr) located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index f14612d58f..466c1f5094 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -370,3 +370,6 @@ let of_move_location (loc, mv) = match mv with | QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] | QMoveFirst -> std_constructor ?loc "MoveFirst" [] | QMoveLast -> std_constructor ?loc "MoveLast" [] + +let of_pose p = + of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 9f42c60042..ccb832535a 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -75,6 +75,8 @@ val of_dispatch : dispatch -> raw_tacexpr val of_strategy_flag : strategy_flag -> raw_tacexpr +val of_pose : pose -> raw_tacexpr + val of_constr_matching : constr_matching -> raw_tacexpr (** {5 Generic arguments} *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 28bcd6a1cf..0db71fb293 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -294,13 +294,12 @@ let () = define_prim2 "tac_pose" begin fun idopt c -> Tactics.letin_tac None na c None Locusops.nowhere end -let () = define_prim4 "tac_set" begin fun ev idopt c cl -> +let () = define_prim3 "tac_set" begin fun ev p cl -> let ev = Value.to_bool ev in - let na = to_name idopt in let cl = to_clause cl in Proofview.tclEVARMAP >>= fun sigma -> - thaw c >>= fun c -> - let c = Value.to_constr c in + thaw p >>= fun p -> + let (na, c) = to_pair to_name Value.to_constr p in Tactics.letin_pat_tac ev None na (sigma, c) cl end diff --git a/tests/example2.v b/tests/example2.v index a7eb02050b..b667e19bbd 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -208,3 +208,17 @@ Proof. refine '(let x := 0 in _). eexists; exists &x; reflexivity. Qed. + +Goal True. +Proof. +pose (X := True). +constructor. +Qed. + +Goal True. +Proof. +let x := @foo in +set ($x := True) in * |-. +constructor. +Qed. + diff --git a/theories/Notations.v b/theories/Notations.v index 9b2b04f9e6..65b05113ae 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -270,6 +270,27 @@ Ltac2 Notation "apply" cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := apply0 true false cb cl. +Ltac2 default_on_concl cl := +match cl with +| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 pose0 ev p := + enter_h ev (fun ev ((na, p)) => Std.pose na p) p. + +Ltac2 Notation "pose" p(thunk(pose)) := + pose0 false p. + +Ltac2 Notation "epose" p(thunk(pose)) := + pose0 true p. + +Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := + Std.set false p (default_on_concl cl). + +Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := + Std.set true p (default_on_concl cl). + Ltac2 induction0 ev ic use := let f ev use := Std.induction ev ic use in enter_h ev f use. @@ -323,12 +344,6 @@ Ltac2 Notation "inversion_clear" ids(opt(seq("in", list1(ident)))) := Std.inversion Std.FullInversionClear arg pat ids. -Ltac2 default_on_concl cl := -match cl with -| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } -| Some cl => cl -end. - Ltac2 Notation "red" cl(opt(clause)) := Std.red (default_on_concl cl). Ltac2 Notation red := red. diff --git a/theories/Std.v b/theories/Std.v index f8b269dce6..42bd9edde0 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -135,7 +135,7 @@ Ltac2 @ external assert : constr -> (unit -> unit) option option -> intro_patter Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". -Ltac2 @ external set : evar_flag -> ident option -> (unit -> constr) -> clause -> unit := "ltac2" "tac_set". +Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". Ltac2 @ external destruct : evar_flag -> induction_clause list -> constr_with_bindings option -> unit := "ltac2" "tac_induction". -- cgit v1.2.3 From 6218f06931384a38445e9d829e6782c069c3ffb4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Sep 2017 15:37:54 +0200 Subject: Introducing the remember tactic. --- src/tac2stdlib.ml | 16 ++++++++++++++++ tests/example2.v | 6 ++++++ theories/Notations.v | 20 ++++++++++++++++++++ theories/Std.v | 2 ++ 4 files changed, 44 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 0db71fb293..e253cc382b 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -303,6 +303,22 @@ let () = define_prim3 "tac_set" begin fun ev p cl -> Tactics.letin_pat_tac ev None na (sigma, c) cl end +let () = define_prim5 "tac_remember" begin fun ev na c eqpat cl -> + let ev = Value.to_bool ev in + let na = to_name na in + let cl = to_clause cl in + let eqpat = Value.to_option to_intro_pattern eqpat in + let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in + match eqpat with + | IntroNaming eqpat -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw c >>= fun c -> + let c = Value.to_constr c in + Tactics.letin_pat_tac ev (Some (true, Loc.tag eqpat)) na (sigma, c) cl + | _ -> + Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") +end + let () = define_prim3 "tac_destruct" begin fun ev ic using -> let ev = Value.to_bool ev in let ic = Value.to_list to_induction_clause ic in diff --git a/tests/example2.v b/tests/example2.v index b667e19bbd..a21f3a7f4e 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -222,3 +222,9 @@ set ($x := True) in * |-. constructor. Qed. +Goal 0 = 0. +Proof. +remember 0 as n eqn: foo at 1. +rewrite foo. +reflexivity. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 65b05113ae..1b5792e051 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -291,6 +291,26 @@ Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := Std.set true p (default_on_concl cl). +Ltac2 default_everywhere cl := +match cl with +| None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 Notation "remember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember false na c pat (default_everywhere cl). + +Ltac2 Notation "eremember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember true na c pat (default_everywhere cl). + Ltac2 induction0 ev ic use := let f ev use := Std.induction ev ic use in enter_h ev f use. diff --git a/theories/Std.v b/theories/Std.v index 42bd9edde0..e938bc24b1 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -137,6 +137,8 @@ Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_patter Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". +Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". + Ltac2 @ external destruct : evar_flag -> induction_clause list -> constr_with_bindings option -> unit := "ltac2" "tac_induction". -- cgit v1.2.3 From 7cee394fc0c6a7a28def2222be0289d6083f47c2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Sep 2017 16:07:47 +0200 Subject: Explicit arity for closures. --- src/tac2core.ml | 33 +++++++++++++-------------- src/tac2expr.mli | 6 ++++- src/tac2ffi.ml | 33 +++++++++++++++++++++++++++ src/tac2ffi.mli | 10 +++++++++ src/tac2interp.ml | 31 +++++++++++-------------- src/tac2stdlib.ml | 67 +++++++++++++++++-------------------------------------- 6 files changed, 97 insertions(+), 83 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index bb6578090d..ea65066d74 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -101,7 +101,7 @@ let err_matchfailure = (** Helper functions *) -let thaw f = f [v_unit] +let thaw f = Tac2ffi.apply f [v_unit] let fatal_flag : unit Exninfo.t = Exninfo.make () let fatal_info = Exninfo.add Exninfo.null fatal_flag () @@ -150,24 +150,21 @@ let pf_apply f = (** Primitives *) -let define0 name f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with -| [_] -> f -| _ -> assert false -end +let define_primitive name arity f = + Tac2env.define_primitive (pname name) (MLTactic (arity, f)) + +let define0 name f = define_primitive name OneAty (fun _ -> f) -let define1 name r0 f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with -| [x] -> f (r0.Value.r_to x) -| _ -> assert false +let define1 name r0 f = define_primitive name OneAty begin fun x -> + f (r0.Value.r_to x) end -let define2 name r0 r1 f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with -| [x; y] -> f (r0.Value.r_to x) (r1.Value.r_to y) -| _ -> assert false +let define2 name r0 r1 f = define_primitive name (AddAty OneAty) begin fun x y -> + f (r0.Value.r_to x) (r1.Value.r_to y) end -let define3 name r0 r1 r2 f = Tac2env.define_primitive (pname name) begin fun arg -> match arg with -| [x; y; z] -> f (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) -| _ -> assert false +let define3 name r0 r1 r2 f = define_primitive name (AddAty (AddAty OneAty)) begin fun x y z -> + f (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) end (** Printing *) @@ -588,7 +585,7 @@ end (** (unit -> 'a) -> (exn -> 'a) -> 'a *) let () = define2 "plus" closure closure begin fun x k -> - Proofview.tclOR (thaw x) (fun e -> k [Value.of_exn e]) + Proofview.tclOR (thaw x) (fun e -> Tac2ffi.apply k [Value.of_exn e]) end (** (unit -> 'a) -> 'a *) @@ -620,13 +617,13 @@ end let () = define1 "case" closure begin fun f -> Proofview.tclCASE (thaw f) >>= begin function | Proofview.Next (x, k) -> - let k = function + let k = Tac2ffi.abstract 1 begin function | [e] -> let (e, info) = Value.to_exn e in set_bt info >>= fun info -> k (e, info) | _ -> assert false - in + end in return (ValBlk (0, [| Value.of_tuple [| x; Value.of_closure k |] |])) | Proofview.Fail e -> return (ValBlk (1, [| Value.of_exn e |])) end @@ -705,7 +702,7 @@ let () = define2 "with_holes" closure closure begin fun x f -> thaw x >>= fun ans -> Proofview.tclEVARMAP >>= fun sigma -> Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> - Tacticals.New.tclWITHHOLES false (f [ans]) sigma + Tacticals.New.tclWITHHOLES false (Tac2ffi.apply f [ans]) sigma end let () = define1 "progress" closure begin fun f -> diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 0b9923f7b9..bbe127e94d 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -188,6 +188,10 @@ type frame = type backtrace = frame list +type ('a, _) arity = +| OneAty : ('a, 'a -> 'a Proofview.tactic) arity +| AddAty : ('a, 'b) arity -> ('a, 'a -> 'b) arity + type valexpr = | ValInt of int (** Immediate integers *) @@ -202,7 +206,7 @@ type valexpr = | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) -and ml_tactic = valexpr list -> valexpr Proofview.tactic +and ml_tactic = MLTactic : (valexpr, 'v) arity * 'v -> ml_tactic type environment = { env_ist : valexpr Id.Map.t; diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 16c17cce62..b4191acd60 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -12,6 +12,7 @@ open Globnames open Genarg open Tac2dyn open Tac2expr +open Proofview.Notations type 'a repr = { r_of : 'a -> valexpr; @@ -248,3 +249,35 @@ let reference = { r_to = to_reference; r_id = false; } + +let rec apply : type a. (valexpr, a) arity -> a -> valexpr list -> valexpr Proofview.tactic = + fun arity f args -> match args, arity with + | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) + (** A few hardcoded cases for efficiency *) + | [a0], OneAty -> f a0 + | [a0; a1], AddAty OneAty -> f a0 a1 + | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 + | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 + (** Generic cases *) + | a :: args, OneAty -> + f a >>= fun f -> + let MLTactic (arity, f) = to_closure f in + apply arity f args + | a :: args, AddAty arity -> + apply arity (f a) args + +let apply (MLTactic (arity, f)) args = apply arity f args + +type n_closure = +| NClosure : (valexpr, 'a) arity * (valexpr list -> 'a) -> n_closure + +let rec abstract n f = + if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) + else + let NClosure (arity, fe) = abstract (n - 1) f in + NClosure (AddAty arity, fun accu v -> fe (v :: accu)) + +let abstract n f = + let () = assert (n > 0) in + let NClosure (arity, f) = abstract n f in + MLTactic (arity, f []) diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 05f4d210ab..489531671c 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -119,6 +119,16 @@ val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] should be put into a value with tag [val_exn]. *) +(** Closures *) + +val apply : ml_tactic -> valexpr list -> valexpr Proofview.tactic +(** Given a closure, apply it to some arguments. Handling of argument mismatches + is done automatically, i.e. in case of over or under-application. *) + +val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> ml_tactic +(** Turn a fixed-arity function into a closure. The inner function is guaranteed + to be applied to a list whose size is the integer argument. *) + (** Exception *) exception LtacError of KerName.t * valexpr array diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 19efeb7669..815fdffe0f 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -88,7 +88,7 @@ let rec interp (ist : environment) = function | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - Tac2ffi.to_closure f args + Tac2ffi.apply (Tac2ffi.to_closure f) args | GTacLet (false, el, e) -> let fold accu (na, e) = interp ist e >>= fun e -> @@ -133,28 +133,23 @@ let rec interp (ist : environment) = function return (ValOpn (kn, Array.of_list el)) | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - with_frame (FrPrim ml) (Tac2env.interp_primitive ml el) + with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) | GTacExt (tag, e) -> let tpe = Tac2env.interp_ml_object tag in with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) -and interp_app f = (); fun args -> match f with -| { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } -> - let frame = match kn with - | None -> FrAnon e - | Some kn -> FrLtac kn +and interp_app f = + let ans = fun args -> + let { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } = f in + let frame = match kn with + | None -> FrAnon e + | Some kn -> FrLtac kn + in + let ist = { env_ist = ist } in + let ist = List.fold_left2 push_name ist ids args in + with_frame frame (interp ist e) in - let rec push ist ids args = match ids, args with - | [], [] -> with_frame frame (interp ist e) - | [], _ :: _ -> - with_frame frame (interp ist e) >>= fun f -> Tac2ffi.to_closure f args - | _ :: _, [] -> - let cls = { clos_ref = kn; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - let f = interp_app cls in - return (ValCls f) - | id :: ids, arg :: args -> push (push_name ist id arg) ids args - in - push { env_ist = ist } ids args + Tac2ffi.abstract (List.length f.clos_var) ans and interp_case ist e cse0 cse1 = match e with | ValInt n -> interp ist cse0.(n) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index e253cc382b..6512510f0a 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -18,7 +18,7 @@ module Value = Tac2ffi let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () -let thaw f = Value.to_closure f [v_unit] +let thaw f = Tac2ffi.apply (Value.to_closure f) [v_unit] let to_pair f g = function | ValBlk (0, [| x; y |]) -> (f x, g y) @@ -189,46 +189,28 @@ let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } let lift tac = tac <*> return v_unit let define_prim0 name tac = - let tac arg = match arg with - | [_] -> lift tac - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac _ = lift tac in + Tac2env.define_primitive (pname name) (MLTactic (OneAty, tac)) let define_prim1 name tac = - let tac arg = match arg with - | [x] -> lift (tac x) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x = lift (tac x) in + Tac2env.define_primitive (pname name) (MLTactic (OneAty, tac)) let define_prim2 name tac = - let tac arg = match arg with - | [x; y] -> lift (tac x y) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x y = lift (tac x y) in + Tac2env.define_primitive (pname name) (MLTactic (AddAty OneAty, tac)) let define_prim3 name tac = - let tac arg = match arg with - | [x; y; z] -> lift (tac x y z) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x y z = lift (tac x y z) in + Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty OneAty), tac)) let define_prim4 name tac = - let tac arg = match arg with - | [x; y; z; u] -> lift (tac x y z u) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x y z u = lift (tac x y z u) in + Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty (AddAty OneAty)), tac)) let define_prim5 name tac = - let tac arg = match arg with - | [x; y; z; u; v] -> lift (tac x y z u v) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x y z u v = lift (tac x y z u v) in + Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty (AddAty (AddAty OneAty))), tac)) (** Tactics from Tacexpr *) @@ -401,26 +383,19 @@ end (** Reduction functions *) +let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + let define_red1 name tac = - let tac arg = match arg with - | [x] -> tac x >>= fun c -> Proofview.tclUNIT (Value.of_constr c) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x = lift (tac x) in + Tac2env.define_primitive (pname name) (MLTactic (OneAty, tac)) let define_red2 name tac = - let tac arg = match arg with - | [x; y] -> tac x y >>= fun c -> Proofview.tclUNIT (Value.of_constr c) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x y = lift (tac x y) in + Tac2env.define_primitive (pname name) (MLTactic (AddAty OneAty, tac)) let define_red3 name tac = - let tac arg = match arg with - | [x; y; z] -> tac x y z >>= fun c -> Proofview.tclUNIT (Value.of_constr c) - | _ -> assert false - in - Tac2env.define_primitive (pname name) tac + let tac x y z = lift (tac x y z) in + Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty OneAty), tac)) let () = define_red1 "eval_red" begin fun c -> let c = Value.to_constr c in -- cgit v1.2.3 From 97bcc97fab0e9c0967c7f723e24ba0f238bd94ff Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Sep 2017 21:28:32 +0200 Subject: Moving valexpr definition to Tac2ffi. --- src/ltac2_plugin.mlpack | 2 +- src/tac2entries.ml | 2 +- src/tac2env.ml | 5 +++++ src/tac2env.mli | 5 +++++ src/tac2expr.mli | 24 ------------------------ src/tac2ffi.ml | 25 ++++++++++++++++++++++++- src/tac2ffi.mli | 22 ++++++++++++++++++++++ src/tac2interp.ml | 5 +++++ src/tac2interp.mli | 3 +++ src/tac2print.ml | 3 ++- src/tac2print.mli | 1 + src/tac2stdlib.ml | 1 + 12 files changed, 70 insertions(+), 28 deletions(-) diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 70f97b9d1e..a2237f4d26 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -1,6 +1,6 @@ Tac2dyn -Tac2env Tac2ffi +Tac2env Tac2print Tac2intern Tac2interp diff --git a/src/tac2entries.ml b/src/tac2entries.ml index d622aaba69..78fe7b5bd9 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -773,7 +773,7 @@ let pr_frame = function let () = register_handler begin function | Tac2interp.LtacError (kn, args) -> let t_exn = KerName.make2 Tac2env.coq_prefix (Label.make "exn") in - let v = ValOpn (kn, args) in + let v = Tac2ffi.ValOpn (kn, args) in let t = GTypRef (Other t_exn, []) in let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) diff --git a/src/tac2env.ml b/src/tac2env.ml index 831c6a3b42..0aa2da77ae 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -12,6 +12,7 @@ open Names open Libnames open Tac2dyn open Tac2expr +open Tac2ffi type global_data = { gdata_expr : glb_tacexpr; @@ -237,6 +238,10 @@ type 'a or_glb_tacexpr = | GlbVal of 'a | GlbTacexpr of glb_tacexpr +type environment = { + env_ist : valexpr Id.Map.t; +} + type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr type ('a, 'b) ml_object = { diff --git a/src/tac2env.mli b/src/tac2env.mli index 89e22f07d5..85dba90262 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -12,6 +12,7 @@ open Libnames open Nametab open Tac2dyn open Tac2expr +open Tac2ffi (** Ltac2 global environment *) @@ -111,6 +112,10 @@ type 'a or_glb_tacexpr = type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr +type environment = { + env_ist : valexpr Id.Map.t; +} + type ('a, 'b) ml_object = { ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; ml_subst : Mod_subst.substitution -> 'b -> 'b; diff --git a/src/tac2expr.mli b/src/tac2expr.mli index bbe127e94d..c787870c65 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -187,27 +187,3 @@ type frame = | FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame type backtrace = frame list - -type ('a, _) arity = -| OneAty : ('a, 'a -> 'a Proofview.tactic) arity -| AddAty : ('a, 'b) arity -> ('a, 'a -> 'b) arity - -type valexpr = -| ValInt of int - (** Immediate integers *) -| ValBlk of tag * valexpr array - (** Structured blocks *) -| ValStr of Bytes.t - (** Strings *) -| ValCls of ml_tactic - (** Closures *) -| ValOpn of KerName.t * valexpr array - (** Open constructors *) -| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr - (** Arbitrary data *) - -and ml_tactic = MLTactic : (valexpr, 'v) arity * 'v -> ml_tactic - -type environment = { - env_ist : valexpr Id.Map.t; -} diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index b4191acd60..3e9842b926 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -14,6 +14,26 @@ open Tac2dyn open Tac2expr open Proofview.Notations +type ('a, _) arity = +| OneAty : ('a, 'a -> 'a Proofview.tactic) arity +| AddAty : ('a, 'b) arity -> ('a, 'a -> 'b) arity + +type valexpr = +| ValInt of int + (** Immediate integers *) +| ValBlk of tag * valexpr array + (** Structured blocks *) +| ValStr of Bytes.t + (** Strings *) +| ValCls of ml_tactic + (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr + (** Arbitrary data *) + +and ml_tactic = MLTactic : (valexpr, 'v) arity * 'v -> ml_tactic + type 'a repr = { r_of : 'a -> valexpr; r_to : valexpr -> 'a; @@ -166,7 +186,10 @@ let pattern = repr_ext val_pattern let internal_err = let open Names in - KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string "Internal")) + let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + in + KerName.make2 coq_prefix (Label.of_id (Id.of_string "Internal")) (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 489531671c..26e309e5fd 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -11,6 +11,28 @@ open EConstr open Tac2dyn open Tac2expr +(** {5 Toplevel values} *) + +type ('a, _) arity = +| OneAty : ('a, 'a -> 'a Proofview.tactic) arity +| AddAty : ('a, 'b) arity -> ('a, 'a -> 'b) arity + +type valexpr = +| ValInt of int + (** Immediate integers *) +| ValBlk of tag * valexpr array + (** Structured blocks *) +| ValStr of Bytes.t + (** Strings *) +| ValCls of ml_tactic + (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr + (** Arbitrary data *) + +and ml_tactic = MLTactic : (valexpr, 'v) arity * 'v -> ml_tactic + (** {5 Ltac2 FFI} *) type 'a repr = { diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 815fdffe0f..58a3a9a4ec 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -13,6 +13,7 @@ open Genarg open Names open Proofview.Notations open Tac2expr +open Tac2ffi exception LtacError = Tac2ffi.LtacError @@ -42,6 +43,10 @@ let with_frame frame tac = Proofview.tclUNIT ans else tac +type environment = Tac2env.environment = { + env_ist : valexpr Id.Map.t; +} + let empty_environment = { env_ist = Id.Map.empty; } diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 3acca72367..211ac95196 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -8,6 +8,9 @@ open Names open Tac2expr +open Tac2ffi + +type environment = Tac2env.environment val empty_environment : environment diff --git a/src/tac2print.ml b/src/tac2print.ml index 7113b01610..d39051c93e 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -12,6 +12,7 @@ open Genarg open Names open Tac2expr open Tac2env +open Tac2ffi (** Utils *) @@ -106,7 +107,7 @@ type exp_level = Tac2expr.exp_level = | E0 let pr_atom = function -| AtmInt n -> int n +| AtmInt n -> Pp.int n | AtmStr s -> qstring s let pr_name = function diff --git a/src/tac2print.mli b/src/tac2print.mli index 01abd1efb1..9b9db2937d 100644 --- a/src/tac2print.mli +++ b/src/tac2print.mli @@ -7,6 +7,7 @@ (************************************************************************) open Tac2expr +open Tac2ffi (** {5 Printing types} *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 6512510f0a..6b3b997232 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -12,6 +12,7 @@ open Globnames open Misctypes open Genredexpr open Tac2expr +open Tac2ffi open Proofview.Notations module Value = Tac2ffi -- cgit v1.2.3 From dac0b95c77dc316a2ef65bbc3901ed7c9366e982 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Sep 2017 21:36:47 +0200 Subject: Abstracting away the type of arities and ML tactics. --- src/tac2core.ml | 14 ++++++-------- src/tac2env.mli | 4 ++-- src/tac2ffi.ml | 21 ++++++++++++++------- src/tac2ffi.mli | 23 +++++++++++++---------- src/tac2stdlib.ml | 18 +++++++++--------- 5 files changed, 44 insertions(+), 36 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index ea65066d74..9e65111c0d 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -151,19 +151,19 @@ let pf_apply f = (** Primitives *) let define_primitive name arity f = - Tac2env.define_primitive (pname name) (MLTactic (arity, f)) + Tac2env.define_primitive (pname name) (mk_closure arity f) -let define0 name f = define_primitive name OneAty (fun _ -> f) +let define0 name f = define_primitive name arity_one (fun _ -> f) -let define1 name r0 f = define_primitive name OneAty begin fun x -> +let define1 name r0 f = define_primitive name arity_one begin fun x -> f (r0.Value.r_to x) end -let define2 name r0 r1 f = define_primitive name (AddAty OneAty) begin fun x y -> +let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> f (r0.Value.r_to x) (r1.Value.r_to y) end -let define3 name r0 r1 r2 f = define_primitive name (AddAty (AddAty OneAty)) begin fun x y z -> +let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> f (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) end @@ -617,12 +617,10 @@ end let () = define1 "case" closure begin fun f -> Proofview.tclCASE (thaw f) >>= begin function | Proofview.Next (x, k) -> - let k = Tac2ffi.abstract 1 begin function - | [e] -> + let k = Tac2ffi.mk_closure arity_one begin fun e -> let (e, info) = Value.to_exn e in set_bt info >>= fun info -> k (e, info) - | _ -> assert false end in return (ValBlk (0, [| Value.of_tuple [| x; Value.of_closure k |] |])) | Proofview.Fail e -> return (ValBlk (1, [| Value.of_exn e |])) diff --git a/src/tac2env.mli b/src/tac2env.mli index 85dba90262..b82923765d 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -101,8 +101,8 @@ val shortest_qualid_of_projection : ltac_projection -> qualid (** This state is not part of the summary, contrarily to the ones above. It is intended to be used from ML plugins to register ML-side functions. *) -val define_primitive : ml_tactic_name -> ml_tactic -> unit -val interp_primitive : ml_tactic_name -> ml_tactic +val define_primitive : ml_tactic_name -> closure -> unit +val interp_primitive : ml_tactic_name -> closure (** {5 ML primitive types} *) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 3e9842b926..ede4836750 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -14,9 +14,9 @@ open Tac2dyn open Tac2expr open Proofview.Notations -type ('a, _) arity = -| OneAty : ('a, 'a -> 'a Proofview.tactic) arity -| AddAty : ('a, 'b) arity -> ('a, 'a -> 'b) arity +type ('a, _) arity0 = +| OneAty : ('a, 'a -> 'a Proofview.tactic) arity0 +| AddAty : ('a, 'b) arity0 -> ('a, 'a -> 'b) arity0 type valexpr = | ValInt of int @@ -25,14 +25,21 @@ type valexpr = (** Structured blocks *) | ValStr of Bytes.t (** Strings *) -| ValCls of ml_tactic +| ValCls of closure (** Closures *) | ValOpn of KerName.t * valexpr array (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) -and ml_tactic = MLTactic : (valexpr, 'v) arity * 'v -> ml_tactic +and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure + +let arity_one = OneAty +let arity_suc a = AddAty a + +type 'a arity = (valexpr, 'a) arity0 + +let mk_closure arity f = MLTactic (arity, f) type 'a repr = { r_of : 'a -> valexpr; @@ -273,7 +280,7 @@ let reference = { r_id = false; } -let rec apply : type a. (valexpr, a) arity -> a -> valexpr list -> valexpr Proofview.tactic = +let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = fun arity f args -> match args, arity with | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) (** A few hardcoded cases for efficiency *) @@ -292,7 +299,7 @@ let rec apply : type a. (valexpr, a) arity -> a -> valexpr list -> valexpr Proof let apply (MLTactic (arity, f)) args = apply arity f args type n_closure = -| NClosure : (valexpr, 'a) arity * (valexpr list -> 'a) -> n_closure +| NClosure : 'a arity * (valexpr list -> 'a) -> n_closure let rec abstract n f = if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 26e309e5fd..ed63f2d4a6 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -13,9 +13,7 @@ open Tac2expr (** {5 Toplevel values} *) -type ('a, _) arity = -| OneAty : ('a, 'a -> 'a Proofview.tactic) arity -| AddAty : ('a, 'b) arity -> ('a, 'a -> 'b) arity +type closure type valexpr = | ValInt of int @@ -24,14 +22,19 @@ type valexpr = (** Structured blocks *) | ValStr of Bytes.t (** Strings *) -| ValCls of ml_tactic +| ValCls of closure (** Closures *) | ValOpn of KerName.t * valexpr array (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) -and ml_tactic = MLTactic : (valexpr, 'v) arity * 'v -> ml_tactic +type 'a arity + +val arity_one : (valexpr -> valexpr Proofview.tactic) arity +val arity_suc : 'a arity -> (valexpr -> 'a) arity + +val mk_closure : 'v arity -> 'v -> closure (** {5 Ltac2 FFI} *) @@ -82,9 +85,9 @@ val of_ident : Id.t -> valexpr val to_ident : valexpr -> Id.t val ident : Id.t repr -val of_closure : ml_tactic -> valexpr -val to_closure : valexpr -> ml_tactic -val closure : ml_tactic repr +val of_closure : closure -> valexpr +val to_closure : valexpr -> closure +val closure : closure repr val block : valexpr array repr @@ -143,11 +146,11 @@ val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Closures *) -val apply : ml_tactic -> valexpr list -> valexpr Proofview.tactic +val apply : closure -> valexpr list -> valexpr Proofview.tactic (** Given a closure, apply it to some arguments. Handling of argument mismatches is done automatically, i.e. in case of over or under-application. *) -val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> ml_tactic +val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> closure (** Turn a fixed-arity function into a closure. The inner function is guaranteed to be applied to a list whose size is the integer argument. *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 6b3b997232..e94027c899 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -191,27 +191,27 @@ let lift tac = tac <*> return v_unit let define_prim0 name tac = let tac _ = lift tac in - Tac2env.define_primitive (pname name) (MLTactic (OneAty, tac)) + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) let define_prim1 name tac = let tac x = lift (tac x) in - Tac2env.define_primitive (pname name) (MLTactic (OneAty, tac)) + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) let define_prim2 name tac = let tac x y = lift (tac x y) in - Tac2env.define_primitive (pname name) (MLTactic (AddAty OneAty, tac)) + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) let define_prim3 name tac = let tac x y z = lift (tac x y z) in - Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty OneAty), tac)) + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) let define_prim4 name tac = let tac x y z u = lift (tac x y z u) in - Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty (AddAty OneAty)), tac)) + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) let define_prim5 name tac = let tac x y z u v = lift (tac x y z u v) in - Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty (AddAty (AddAty OneAty))), tac)) + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) (** Tactics from Tacexpr *) @@ -388,15 +388,15 @@ let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) let define_red1 name tac = let tac x = lift (tac x) in - Tac2env.define_primitive (pname name) (MLTactic (OneAty, tac)) + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) let define_red2 name tac = let tac x y = lift (tac x y) in - Tac2env.define_primitive (pname name) (MLTactic (AddAty OneAty, tac)) + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) let define_red3 name tac = let tac x y z = lift (tac x y z) in - Tac2env.define_primitive (pname name) (MLTactic (AddAty (AddAty OneAty), tac)) + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) let () = define_red1 "eval_red" begin fun c -> let c = Value.to_constr c in -- cgit v1.2.3 From 45beb72954651f3ac587faacd997a5459d122426 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 15 Sep 2017 00:35:04 +0200 Subject: Phantom type for typed closures. --- src/tac2ffi.ml | 7 +++++++ src/tac2ffi.mli | 6 ++++++ 2 files changed, 13 insertions(+) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index ede4836750..5460643bb5 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -280,6 +280,10 @@ let reference = { r_id = false; } +type ('a, 'b) fun1 = closure + +let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure + let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = fun arity f args -> match args, arity with | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) @@ -311,3 +315,6 @@ let abstract n f = let () = assert (n > 0) in let NClosure (arity, f) = abstract n f in MLTactic (arity, f []) + +let app_fun1 cls r0 r1 x = + apply cls [r0.r_of x] >>= fun v -> Proofview.tclUNIT (r1.r_to v) diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index ed63f2d4a6..af854e2d07 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -122,6 +122,12 @@ val of_ext : 'a Val.tag -> 'a -> valexpr val to_ext : 'a Val.tag -> valexpr -> 'a val repr_ext : 'a Val.tag -> 'a repr +type ('a, 'b) fun1 + +val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic + +val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr + val valexpr : valexpr repr (** {5 Dynamic tags} *) -- cgit v1.2.3 From 67851196e552948da9960fe32e9e9f628b349ee1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 15 Sep 2017 00:42:13 +0200 Subject: Making Ltac2 representation of data coincide with the ML-side one. --- src/tac2stdlib.ml | 57 ++++++++--------- src/tac2tactics.ml | 178 +++++++++++++++++++++++++++++++++++++++++++++------- src/tac2tactics.mli | 79 +++++++++++++++++++---- theories/Std.v | 2 +- 4 files changed, 253 insertions(+), 63 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index e94027c899..07b01b1174 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -13,6 +13,7 @@ open Misctypes open Genredexpr open Tac2expr open Tac2ffi +open Tac2tactics open Proofview.Notations module Value = Tac2ffi @@ -39,7 +40,7 @@ let to_bindings = function | ValBlk (0, [| vl |]) -> ImplicitBindings (Value.to_list Value.to_constr vl) | ValBlk (1, [| vl |]) -> - ExplicitBindings ((Value.to_list (fun p -> None, to_pair to_qhyp Value.to_constr p) vl)) + ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) | _ -> assert false let to_constr_with_bindings = function @@ -89,8 +90,7 @@ let to_pattern_with_occs pat = to_pair Value.to_pattern (fun occ -> to_occurrences to_int_or_var occ) pat let to_constr_with_occs c = - let (c, occ) = to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) c in - (occ, c) + to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) c let rec to_intro_pattern = function | ValBlk (0, [| b |]) -> IntroForthcoming (Value.to_bool b) @@ -108,9 +108,11 @@ and to_intro_pattern_action = function | ValInt 0 -> IntroWildcard | ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) | ValBlk (1, [| inj |]) -> - let map ipat = Loc.tag (to_intro_pattern ipat) in + let map ipat = to_intro_pattern ipat in IntroInjection (Value.to_list map inj) -| ValBlk (2, [| _ |]) -> IntroApplyOn (assert false, assert false) (** TODO *) +| ValBlk (2, [| c; ipat |]) -> + let c = thaw c >>= fun c -> return (Value.to_constr c) in + IntroApplyOn (c, to_intro_pattern ipat) | ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) | _ -> assert false @@ -122,22 +124,21 @@ and to_or_and_intro_pattern = function | _ -> assert false and to_intro_patterns il = - let map ipat = Loc.tag (to_intro_pattern ipat) in - Value.to_list map il + Value.to_list to_intro_pattern il let to_destruction_arg = function | ValBlk (0, [| c |]) -> let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in - None, ElimOnConstr c -| ValBlk (1, [| id |]) -> None, ElimOnIdent (Loc.tag (Value.to_ident id)) -| ValBlk (2, [| n |]) -> None, ElimOnAnonHyp (Value.to_int n) + ElimOnConstr c +| ValBlk (1, [| id |]) -> ElimOnIdent (Value.to_ident id) +| ValBlk (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) | _ -> assert false let to_induction_clause = function | ValBlk (0, [| arg; eqn; as_; in_ |]) -> let arg = to_destruction_arg arg in - let eqn = Value.to_option (fun p -> Loc.tag (to_intro_pattern_naming p)) eqn in - let as_ = Value.to_option (fun p -> Loc.tag (to_or_and_intro_pattern p)) as_ in + let eqn = Value.to_option to_intro_pattern_naming eqn in + let as_ = Value.to_option to_or_and_intro_pattern as_ in let in_ = Value.to_option to_clause in_ in (arg, eqn, as_, in_) | _ -> @@ -218,7 +219,7 @@ let define_prim5 name tac = let () = define_prim2 "tac_intros" begin fun ev ipat -> let ev = Value.to_bool ev in let ipat = to_intro_patterns ipat in - Tactics.intros_patterns ev ipat + Tac2tactics.intros_patterns ev ipat end let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> @@ -226,7 +227,7 @@ let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> let ev = Value.to_bool ev in let map_cb c = thaw c >>= fun c -> return (to_constr_with_bindings c) in let cb = Value.to_list map_cb cb in - let map p = Value.to_option (fun p -> Loc.tag (to_intro_pattern p)) p in + let map p = Value.to_option to_intro_pattern p in let map_ipat p = to_pair Value.to_ident map p in let ipat = Value.to_option map_ipat ipat in Tac2tactics.apply adv ev cb ipat @@ -236,13 +237,13 @@ let () = define_prim3 "tac_elim" begin fun ev c copt -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in let copt = Value.to_option to_constr_with_bindings copt in - Tactics.elim ev None c copt + Tac2tactics.elim ev c copt end let () = define_prim2 "tac_case" begin fun ev c -> let ev = Value.to_bool ev in let c = to_constr_with_bindings c in - Tactics.general_case_analysis ev None c + Tac2tactics.general_case_analysis ev c end let () = define_prim1 "tac_generalize" begin fun cl -> @@ -259,16 +260,16 @@ let () = define_prim3 "tac_assert" begin fun c tac ipat -> let c = Value.to_constr c in let of_tac t = Proofview.tclIGNORE (thaw t) in let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in - let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in - Tactics.forward true tac ipat c + let ipat = Value.to_option to_intro_pattern ipat in + Tac2tactics.forward true tac ipat c end let () = define_prim3 "tac_enough" begin fun c tac ipat -> let c = Value.to_constr c in let of_tac t = Proofview.tclIGNORE (thaw t) in let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in - let ipat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) ipat in - Tactics.forward false tac ipat c + let ipat = Value.to_option to_intro_pattern ipat in + Tac2tactics.forward false tac ipat c end let () = define_prim2 "tac_pose" begin fun idopt c -> @@ -297,7 +298,7 @@ let () = define_prim5 "tac_remember" begin fun ev na c eqpat cl -> Proofview.tclEVARMAP >>= fun sigma -> thaw c >>= fun c -> let c = Value.to_constr c in - Tactics.letin_pat_tac ev (Some (true, Loc.tag eqpat)) na (sigma, c) cl + Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl | _ -> Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") end @@ -367,7 +368,7 @@ end let () = define_prim2 "tac_pattern" begin fun where cl -> let where = Value.to_list to_constr_with_occs where in let cl = to_clause cl in - Tactics.reduce (Pattern where) cl + Tac2tactics.pattern where cl end let () = define_prim2 "tac_vm" begin fun where cl -> @@ -476,7 +477,7 @@ end let () = define_prim4 "tac_inversion" begin fun knd arg pat ids -> let knd = to_inversion_kind knd in let arg = to_destruction_arg arg in - let pat = Value.to_option (fun ipat -> Loc.tag (to_intro_pattern ipat)) pat in + let pat = Value.to_option to_intro_pattern pat in let ids = Value.to_option (fun l -> Value.to_list Value.to_ident l) ids in Tac2tactics.inversion knd arg pat ids end @@ -523,12 +524,12 @@ end let () = define_prim2 "tac_left" begin fun ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in - Tactics.left_with_bindings ev bnd + Tac2tactics.left_with_bindings ev bnd end let () = define_prim2 "tac_right" begin fun ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in - Tactics.right_with_bindings ev bnd + Tac2tactics.right_with_bindings ev bnd end let () = define_prim1 "tac_introsuntil" begin fun h -> @@ -556,7 +557,7 @@ let () = define_prim3 "tac_constructorn" begin fun ev n bnd -> let ev = Value.to_bool ev in let n = Value.to_int n in let bnd = to_bindings bnd in - Tactics.constructor_tac ev None n bnd + Tac2tactics.constructor_tac ev None n bnd end let () = define_prim1 "tac_symmetry" begin fun cl -> @@ -567,7 +568,7 @@ end let () = define_prim2 "tac_split" begin fun ev bnd -> let ev = Value.to_bool ev in let bnd = to_bindings bnd in - Tactics.split_with_bindings ev [bnd] + Tac2tactics.split_with_bindings ev bnd end let () = define_prim1 "tac_rename" begin fun ids -> @@ -633,7 +634,7 @@ end let () = define_prim1 "tac_contradiction" begin fun c -> let c = Value.to_option to_constr_with_bindings c in - Contradiction.contradiction c + Tac2tactics.contradiction c end let () = define_prim4 "tac_autorewrite" begin fun all by ids cl -> diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index aa2ee4711a..083ec9e9d4 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -16,7 +16,41 @@ open Genredexpr open Proofview open Proofview.Notations -type destruction_arg = EConstr.constr with_bindings tactic Misctypes.destruction_arg +let return = Proofview.tclUNIT + +type explicit_bindings = (quantified_hypothesis * EConstr.t) list + +type bindings = +| ImplicitBindings of EConstr.t list +| ExplicitBindings of explicit_bindings +| NoBindings + +type constr_with_bindings = EConstr.constr * bindings + +type intro_pattern = +| IntroForthcoming of bool +| IntroNaming of intro_pattern_naming +| IntroAction of intro_pattern_action +and intro_pattern_naming = +| IntroIdentifier of Id.t +| IntroFresh of Id.t +| IntroAnonymous +and intro_pattern_action = +| IntroWildcard +| IntroOrAndPattern of or_and_intro_pattern +| IntroInjection of intro_pattern list +| IntroApplyOn of EConstr.t tactic * intro_pattern +| IntroRewrite of bool +and or_and_intro_pattern = +| IntroOrPattern of intro_pattern list list +| IntroAndPattern of intro_pattern list + +type core_destruction_arg = +| ElimOnConstr of constr_with_bindings tactic +| ElimOnIdent of Id.t +| ElimOnAnonHyp of int + +type destruction_arg = core_destruction_arg let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; @@ -31,12 +65,57 @@ let delayed_of_tactic tac env sigma = let c, pv, _, _ = Proofview.apply env tac pv in (sigma, c) +let mk_bindings = function +| ImplicitBindings l -> Misctypes.ImplicitBindings l +| ExplicitBindings l -> + let l = List.map Loc.tag l in + Misctypes.ExplicitBindings l +| NoBindings -> Misctypes.NoBindings + +let mk_with_bindings (x, b) = (x, mk_bindings b) + +let rec mk_intro_pattern = function +| IntroForthcoming b -> Loc.tag @@ Misctypes.IntroForthcoming b +| IntroNaming ipat -> Loc.tag @@ Misctypes.IntroNaming (mk_intro_pattern_naming ipat) +| IntroAction ipat -> Loc.tag @@ Misctypes.IntroAction (mk_intro_pattern_action ipat) + +and mk_intro_pattern_naming = function +| IntroIdentifier id -> Misctypes.IntroIdentifier id +| IntroFresh id -> Misctypes.IntroFresh id +| IntroAnonymous -> Misctypes.IntroAnonymous + +and mk_intro_pattern_action = function +| IntroWildcard -> Misctypes.IntroWildcard +| IntroOrAndPattern ipat -> Misctypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) +| IntroInjection ipats -> Misctypes.IntroInjection (List.map mk_intro_pattern ipats) +| IntroApplyOn (c, ipat) -> + let c = Loc.tag @@ delayed_of_tactic c in + Misctypes.IntroApplyOn (c, mk_intro_pattern ipat) +| IntroRewrite b -> Misctypes.IntroRewrite b + +and mk_or_and_intro_pattern = function +| IntroOrPattern ipatss -> + Misctypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) +| IntroAndPattern ipats -> + Misctypes.IntroAndPattern (List.map mk_intro_pattern ipats) + +let mk_intro_patterns ipat = List.map mk_intro_pattern ipat + +let intros_patterns ev ipat = + let ipat = mk_intro_patterns ipat in + Tactics.intro_patterns ev ipat + let apply adv ev cb cl = - let map c = None, Loc.tag (delayed_of_tactic c) in + let map c = + let c = c >>= fun c -> return (mk_with_bindings c) in + None, Loc.tag (delayed_of_tactic c) + in let cb = List.map map cb in match cl with | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb - | Some (id, cl) -> Tactics.apply_delayed_in adv ev id cb cl + | Some (id, cl) -> + let cl = Option.map mk_intro_pattern cl in + Tactics.apply_delayed_in adv ev id cb cl type induction_clause = destruction_arg * @@ -44,31 +123,70 @@ type induction_clause = or_and_intro_pattern option * Locus.clause option -let map_destruction_arg = function -| ElimOnConstr c -> ElimOnConstr (delayed_of_tactic c) -| ElimOnIdent id -> ElimOnIdent id -| ElimOnAnonHyp n -> ElimOnAnonHyp n +let mk_destruction_arg = function +| ElimOnConstr c -> + let c = c >>= fun c -> return (mk_with_bindings c) in + Misctypes.ElimOnConstr (delayed_of_tactic c) +| ElimOnIdent id -> Misctypes.ElimOnIdent (Loc.tag id) +| ElimOnAnonHyp n -> Misctypes.ElimOnAnonHyp n + +let mk_induction_clause (arg, eqn, as_, occ) = + let eqn = Option.map (fun ipat -> Loc.tag @@ mk_intro_pattern_naming ipat) eqn in + let as_ = Option.map (fun ipat -> Loc.tag @@ mk_or_and_intro_pattern ipat) as_ in + ((None, mk_destruction_arg arg), (eqn, as_), occ) + +let induction_destruct isrec ev (ic : induction_clause list) using = + let ic = List.map mk_induction_clause ic in + let using = Option.map mk_with_bindings using in + Tactics.induction_destruct isrec ev (ic, using) + +let elim ev c copt = + let c = mk_with_bindings c in + let copt = Option.map mk_with_bindings copt in + Tactics.elim ev None c copt -let map_induction_clause ((clear, arg), eqn, as_, occ) = - ((clear, map_destruction_arg arg), (eqn, as_), occ) +let general_case_analysis ev c = + let c = mk_with_bindings c in + Tactics.general_case_analysis ev None c -let induction_destruct isrec ev ic using = - let ic = List.map map_induction_clause ic in - Tactics.induction_destruct isrec ev (ic, using) +let constructor_tac ev n i bnd = + let bnd = mk_bindings bnd in + Tactics.constructor_tac ev n i bnd + +let left_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.left_with_bindings ev bnd + +let right_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.right_with_bindings ev bnd + +let split_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.split_with_bindings ev [bnd] type rewriting = bool option * multi * - EConstr.constr with_bindings tactic + constr_with_bindings tactic let rewrite ev rw cl by = let map_rw (orient, repeat, c) = + let c = c >>= fun c -> return (mk_with_bindings c) in (Option.default true orient, repeat, None, delayed_of_tactic c) in let rw = List.map map_rw rw in let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE tac, Equality.Naive) by in Equality.general_multi_rewrite ev rw cl by +let forward ev tac ipat c = + let ipat = Option.map mk_intro_pattern ipat in + Tactics.forward ev tac ipat c + +let letin_pat_tac ev ipat na c cl = + let ipat = Option.map (fun (b, ipat) -> (b, Loc.tag @@ mk_intro_pattern_naming ipat)) ipat in + Tactics.letin_pat_tac ev ipat na c cl + (** Ltac interface treats differently global references than other term arguments in reduction expressions. In Ltac1, this is done at parsing time. Instead, we parse indifferently any pattern and dispatch when the tactic is @@ -114,6 +232,10 @@ let unfold occs cl = Proofview.Monad.List.map map occs >>= fun occs -> Tactics.reduce (Unfold occs) cl +let pattern where cl = + let where = List.map (fun (c, occ) -> (occ, c)) where in + Tactics.reduce (Pattern where) cl + let vm where cl = let where = Option.map map_pattern_with_occs where in Tactics.reduce (CbvVm where) cl @@ -189,12 +311,13 @@ let on_destruction_arg tac ev arg = let env = Proofview.Goal.env gl in Proofview.tclEVARMAP >>= fun sigma -> c >>= fun (c, lbind) -> + let lbind = mk_bindings lbind in Proofview.tclEVARMAP >>= fun sigma' -> let flags = tactic_infer_flags ev in let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in - Proofview.tclUNIT (Some sigma', ElimOnConstr (c, lbind)) - | ElimOnIdent id -> Proofview.tclUNIT (None, ElimOnIdent id) - | ElimOnAnonHyp n -> Proofview.tclUNIT (None, ElimOnAnonHyp n) + Proofview.tclUNIT (Some sigma', Misctypes.ElimOnConstr (c, lbind)) + | ElimOnIdent id -> Proofview.tclUNIT (None, Misctypes.ElimOnIdent (Loc.tag id)) + | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Misctypes.ElimOnAnonHyp n) in arg >>= fun (sigma', arg) -> let arg = Some (clear, arg) in @@ -204,9 +327,13 @@ let on_destruction_arg tac ev arg = Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' end -let discriminate ev arg = on_destruction_arg Equality.discr_tac ev arg +let discriminate ev arg = + let arg = Option.map (fun arg -> None, arg) arg in + on_destruction_arg Equality.discr_tac ev arg let injection ev ipat arg = + let arg = Option.map (fun arg -> None, arg) arg in + let ipat = Option.map mk_intro_patterns ipat in let tac ev arg = Equality.injClause ipat ev arg in on_destruction_arg tac ev arg @@ -262,25 +389,30 @@ let inversion knd arg pat ids = in begin match pat with | None -> Proofview.tclUNIT None - | Some (_, IntroAction (IntroOrAndPattern p)) -> - Proofview.tclUNIT (Some (Loc.tag p)) + | Some (IntroAction (IntroOrAndPattern p)) -> + Proofview.tclUNIT (Some (Loc.tag @@ mk_or_and_intro_pattern p)) | Some _ -> Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") end >>= fun pat -> let inversion _ arg = begin match arg with | None -> assert false - | Some (_, ElimOnAnonHyp n) -> + | Some (_, Misctypes.ElimOnAnonHyp n) -> Inv.inv_clause knd pat ids (AnonHyp n) - | Some (_, ElimOnIdent (_, id)) -> + | Some (_, Misctypes.ElimOnIdent (_, id)) -> Inv.inv_clause knd pat ids (NamedHyp id) - | Some (_, ElimOnConstr c) -> + | Some (_, Misctypes.ElimOnConstr c) -> + let open Misctypes in let anon = Loc.tag @@ IntroNaming IntroAnonymous in Tactics.specialize c (Some anon) >>= fun () -> Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) end in - on_destruction_arg inversion true (Some arg) + on_destruction_arg inversion true (Some (None, arg)) + +let contradiction c = + let c = Option.map mk_with_bindings c in + Contradiction.contradiction c (** Firstorder *) diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index f6825d84aa..5fdd1c39bc 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -16,13 +16,41 @@ open Misctypes open Tactypes open Proofview -type destruction_arg = EConstr.constr with_bindings tactic Misctypes.destruction_arg - -(** Local reimplementations of tactics variants from Coq *) - -val apply : advanced_flag -> evars_flag -> - EConstr.constr with_bindings tactic list -> - (Id.t * intro_pattern option) option -> unit tactic +(** Redefinition of Ltac1 data structures because of impedance mismatch *) + +type explicit_bindings = (quantified_hypothesis * EConstr.t) list + +type bindings = +| ImplicitBindings of EConstr.t list +| ExplicitBindings of explicit_bindings +| NoBindings + +type constr_with_bindings = EConstr.constr * bindings + +type core_destruction_arg = +| ElimOnConstr of constr_with_bindings tactic +| ElimOnIdent of Id.t +| ElimOnAnonHyp of int + +type destruction_arg = core_destruction_arg + +type intro_pattern = +| IntroForthcoming of bool +| IntroNaming of intro_pattern_naming +| IntroAction of intro_pattern_action +and intro_pattern_naming = +| IntroIdentifier of Id.t +| IntroFresh of Id.t +| IntroAnonymous +and intro_pattern_action = +| IntroWildcard +| IntroOrAndPattern of or_and_intro_pattern +| IntroInjection of intro_pattern list +| IntroApplyOn of EConstr.t tactic * intro_pattern +| IntroRewrite of bool +and or_and_intro_pattern = +| IntroOrPattern of intro_pattern list list +| IntroAndPattern of intro_pattern list type induction_clause = destruction_arg * @@ -30,17 +58,42 @@ type induction_clause = or_and_intro_pattern option * clause option -val induction_destruct : rec_flag -> evars_flag -> - induction_clause list -> EConstr.constr with_bindings option -> unit tactic - type rewriting = bool option * multi * - EConstr.constr with_bindings tactic + constr_with_bindings tactic + +(** Local reimplementations of tactics variants from Coq *) + +val intros_patterns : evars_flag -> intro_pattern list -> unit tactic + +val apply : advanced_flag -> evars_flag -> + constr_with_bindings tactic list -> + (Id.t * intro_pattern option) option -> unit tactic + +val induction_destruct : rec_flag -> evars_flag -> + induction_clause list -> constr_with_bindings option -> unit tactic + +val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> + unit tactic + +val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic + +val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic + +val left_with_bindings : evars_flag -> bindings -> unit tactic +val right_with_bindings : evars_flag -> bindings -> unit tactic +val split_with_bindings : evars_flag -> bindings -> unit tactic val rewrite : evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic +val forward : bool -> unit tactic option option -> + intro_pattern option -> constr -> unit tactic + +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> + Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic + val simpl : global_reference glob_red_flag -> (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic @@ -52,6 +105,8 @@ val lazy_ : global_reference glob_red_flag -> clause -> unit tactic val unfold : (global_reference * occurrences_expr) list -> clause -> unit tactic +val pattern : (constr * occurrences_expr) list -> clause -> unit tactic + val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic @@ -102,4 +157,6 @@ val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> val inversion : inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic +val contradiction : constr_with_bindings option -> unit tactic + val firstorder : unit Proofview.tactic option -> global_reference list -> Id.t list -> unit tactic diff --git a/theories/Std.v b/theories/Std.v index e938bc24b1..2eab172432 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -67,7 +67,7 @@ with intro_pattern_action := [ | IntroWildcard | IntroOrAndPattern (or_and_intro_pattern) | IntroInjection (intro_pattern list) -| IntroApplyOn ((constr * intro_pattern) not_implemented) (* Not Implemented yet *) +| IntroApplyOn ((unit -> constr), intro_pattern) | IntroRewrite (bool) ] with or_and_intro_pattern := [ -- cgit v1.2.3 From 3f734c5f5338feb491a6ca021e8b5a578f95c88b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 26 Sep 2017 17:52:34 +0200 Subject: Slightly more straightforward notation for (e)apply. --- tests/example2.v | 7 +++++++ theories/Notations.v | 16 ++-------------- 2 files changed, 9 insertions(+), 14 deletions(-) diff --git a/tests/example2.v b/tests/example2.v index a21f3a7f4e..378abb86a8 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -44,6 +44,13 @@ apply &H with (m := 0). split. Qed. +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> (0 = 1) -> P 0. +Proof. +intros P H e. +apply &H with (m := 1) in e. +exact e. +Qed. + Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. Proof. intros P H. diff --git a/theories/Notations.v b/theories/Notations.v index 1b5792e051..d4520dbdfd 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -246,28 +246,16 @@ Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) elim0 true c bnd use. Ltac2 apply0 adv ev cb cl := - let cl := match cl with - | None => None - | Some p => - let ((_, id, ipat)) := p in - let p := match ipat with - | None => None - | Some p => - let ((_, ipat)) := p in - Some ipat - end in - Some (id, p) - end in Std.apply adv ev cb cl. Ltac2 Notation "eapply" cb(list1(thunk(seq(constr, with_bindings)), ",")) - cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := apply0 true true cb cl. Ltac2 Notation "apply" cb(list1(thunk(seq(constr, with_bindings)), ",")) - cl(opt(seq(keyword("in"), ident, opt(seq(keyword("as"), intropattern))))) := + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := apply0 true false cb cl. Ltac2 default_on_concl cl := -- cgit v1.2.3 From 310ed15a1dd4d33246d8b331133fb7a8e7c1f4e3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 26 Sep 2017 18:12:23 +0200 Subject: Small language of combinators for lookaheads in parsing. --- src/g_ltac2.ml4 | 106 +++++++++++++++++++++++--------------------------------- 1 file changed, 43 insertions(+), 63 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index dfd586d5ef..e6921e2f6c 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -19,81 +19,61 @@ open Ltac_plugin let err () = raise Stream.Failure +type lookahead = int -> Tok.t Stream.t -> int option + +let entry_of_lookahead s (lk : lookahead) = + let run strm = match lk 0 strm with None -> err () | Some _ -> () in + Gram.Entry.of_parser s run + +let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> None +| Some n -> lk2 n strm + +let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> lk2 n strm +| Some n -> Some n + +let lk_kw kw n strm = match stream_nth n strm with +| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None +| _ -> None + +let lk_ident n strm = match stream_nth n strm with +| IDENT _ -> Some (n + 1) +| _ -> None + +let lk_int n strm = match stream_nth n strm with +| INT _ -> Some (n + 1) +| _ -> None + +let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) + (* lookahead for (x:=t), (?x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" - (fun strm -> - match stream_nth 0 strm with - | KEYWORD "(" -> - (match stream_nth 1 strm with - | IDENT _ | INT _ -> - (match stream_nth 2 strm with - | KEYWORD ":=" -> () - | _ -> err ()) - | KEYWORD "$" -> - (match stream_nth 2 strm with - | IDENT _ -> - (match stream_nth 3 strm with - | KEYWORD ":=" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) + entry_of_lookahead "test_lpar_idnum_coloneq" begin + lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" + end (* Hack to recognize "(x := t)" and "($x := t)" *) let test_lpar_coloneq = - Gram.Entry.of_parser "test_coloneq" - (fun strm -> - match stream_nth 0 strm with - | KEYWORD "(" -> - (match stream_nth 1 strm with - | IDENT _ -> - (match stream_nth 2 strm with - | KEYWORD ":=" -> () - | _ -> err ()) - | KEYWORD "$" -> - (match stream_nth 2 strm with - | IDENT _ -> - (match stream_nth 3 strm with - | KEYWORD ":=" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) + entry_of_lookahead "test_coloneq" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" + end (* Hack to recognize "(x)" *) let test_lpar_id_rpar = - Gram.Entry.of_parser "lpar_id_coloneq" - (fun strm -> - match stream_nth 0 strm with - | KEYWORD "(" -> - (match stream_nth 1 strm with - | IDENT _ -> - (match stream_nth 2 strm with - | KEYWORD ")" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) + entry_of_lookahead "test_lpar_id_coloneq" begin + lk_kw "(" >> lk_ident >> lk_kw ")" + end let test_ampersand_ident = - Gram.Entry.of_parser "test_ampersand_ident" - (fun strm -> - match stream_nth 0 strm with - | KEYWORD "&" -> - (match stream_nth 1 strm with - | IDENT _ -> () - | _ -> err ()) - | _ -> err ()) + entry_of_lookahead "test_ampersand_ident" begin + lk_kw "&" >> lk_ident + end let test_dollar_ident = - Gram.Entry.of_parser "test_dollar_ident" - (fun strm -> - match stream_nth 0 strm with - | IDENT "$" | KEYWORD "$" -> - (match stream_nth 1 strm with - | IDENT _ -> () - | _ -> err ()) - | _ -> err ()) + entry_of_lookahead "test_dollar_ident" begin + lk_kw "$" >> lk_ident + end let tac2expr = Tac2entries.Pltac.tac2expr let tac2type = Gram.entry_create "tactic:tac2type" -- cgit v1.2.3 From 940da8a791b8b1c704f28662fa2e6a8f3ddf040f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 26 Sep 2017 18:57:18 +0200 Subject: Adding quotations for the assert family of tactics. --- src/g_ltac2.ml4 | 40 +++++++++++++++++++++++++++++++++++----- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 6 ++++++ src/tac2quote.ml | 11 +++++++++++ src/tac2quote.mli | 2 ++ src/tac2stdlib.ml | 20 ++++++++++++++------ src/tac2tactics.ml | 16 ++++++++++++++-- src/tac2tactics.mli | 6 ++++++ tests/example2.v | 25 +++++++++++++++++++++++++ theories/Notations.v | 7 +++++++ theories/Std.v | 7 ++++++- 13 files changed, 129 insertions(+), 14 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index e6921e2f6c..c92a242637 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -53,15 +53,21 @@ let test_lpar_idnum_coloneq = lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" end +(* lookahead for (x:t), (?x:t) *) +let test_lpar_id_colon = + entry_of_lookahead "test_lpar_id_colon" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" + end + (* Hack to recognize "(x := t)" and "($x := t)" *) -let test_lpar_coloneq = - entry_of_lookahead "test_coloneq" begin +let test_lpar_id_coloneq = + entry_of_lookahead "test_lpar_id_coloneq" begin lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" end (* Hack to recognize "(x)" *) let test_lpar_id_rpar = - entry_of_lookahead "test_lpar_id_coloneq" begin + entry_of_lookahead "test_lpar_id_rpar" begin lk_kw "(" >> lk_ident >> lk_kw ")" end @@ -370,7 +376,7 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching - q_hintdb q_move_location q_pose; + q_hintdb q_move_location q_pose q_assert; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -709,7 +715,7 @@ GEXTEND Gram ] ] ; pose: - [ [ test_lpar_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> Loc.tag ~loc:!@loc (Some id, c) | c = Constr.constr; na = as_name -> Loc.tag ~loc:!@loc (na, c) ] ] @@ -717,6 +723,30 @@ GEXTEND Gram q_pose: [ [ p = pose -> p ] ] ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> Some ipat + | -> None + ] ] + ; + by_tactic: + [ [ "by"; tac = tac2expr -> Some tac + | -> None + ] ] + ; + assertion: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + Loc.tag ~loc:!@loc (QAssertValue (id, c)) + | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> + let loc = !@loc in + let ipat = Loc.tag ~loc @@ QIntroNaming (Loc.tag ~loc @@ QIntroIdentifier id) in + Loc.tag ~loc (QAssertType (Some ipat, c, tac)) + | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> + Loc.tag ~loc:!@loc (QAssertType (ipat, c, tac)) + ] ] + ; + q_assert: + [ [ a = assertion -> a ] ] + ; END (** Extension of constr syntax *) diff --git a/src/tac2core.ml b/src/tac2core.ml index 9e65111c0d..1917fa5f66 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1114,6 +1114,7 @@ let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag let () = add_expr_scope "reference" q_reference Tac2quote.of_reference let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location let () = add_expr_scope "pose" q_pose Tac2quote.of_pose +let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 78fe7b5bd9..24db19d02a 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -41,6 +41,7 @@ let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" let q_pose = Pcoq.Gram.entry_create "tactic:q_pose" +let q_assert = Pcoq.Gram.entry_create "tactic:q_assert" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 55e658884b..7bd512651c 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -80,6 +80,7 @@ val q_constr_matching : constr_matching Pcoq.Gram.entry val q_hintdb : hintdb Pcoq.Gram.entry val q_move_location : move_location Pcoq.Gram.entry val q_pose : pose Pcoq.Gram.entry +val q_assert : assertion Pcoq.Gram.entry end (** {5 Hooks} *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 580039afe5..cb43a980de 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -141,3 +141,9 @@ type move_location_r = type move_location = move_location_r located type pose = (Id.t located or_anti option * Constrexpr.constr_expr) located + +type assertion_r = +| QAssertType of intro_pattern option * Constrexpr.constr_expr * raw_tacexpr option +| QAssertValue of Id.t located or_anti * Constrexpr.constr_expr + +type assertion = assertion_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 466c1f5094..e89f37f2ba 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -373,3 +373,14 @@ let of_move_location (loc, mv) = match mv with let of_pose p = of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p + +let of_assertion (loc, ast) = match ast with +| QAssertType (ipat, c, tac) -> + let ipat = of_option of_intro_pattern ipat in + let c = of_constr c in + let tac = of_option thunk tac in + std_constructor ?loc "AssertType" [ipat; c; tac] +| QAssertValue (id, c) -> + let id = of_anti of_ident id in + let c = of_constr c in + std_constructor ?loc "AssertValue" [id; c] diff --git a/src/tac2quote.mli b/src/tac2quote.mli index ccb832535a..b9cae23e63 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -77,6 +77,8 @@ val of_strategy_flag : strategy_flag -> raw_tacexpr val of_pose : pose -> raw_tacexpr +val of_assertion : assertion -> raw_tacexpr + val of_constr_matching : constr_matching -> raw_tacexpr (** {5 Generic arguments} *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 07b01b1174..5f61081a76 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -144,6 +144,17 @@ let to_induction_clause = function | _ -> assert false +let to_assertion = function +| ValBlk (0, [| ipat; t; tac |]) -> + let to_tac t = Proofview.tclIGNORE (thaw t) in + let ipat = Value.to_option to_intro_pattern ipat in + let t = Value.to_constr t in + let tac = Value.to_option to_tac tac in + AssertType (ipat, t, tac) +| ValBlk (1, [| id; c |]) -> + AssertValue (Value.to_ident id, Value.to_constr c) +| _ -> assert false + let to_multi = function | ValBlk (0, [| n |]) -> Precisely (Value.to_int n) | ValBlk (1, [| n |]) -> UpTo (Value.to_int n) @@ -256,12 +267,9 @@ let () = define_prim1 "tac_generalize" begin fun cl -> Tactics.new_generalize_gen cl end -let () = define_prim3 "tac_assert" begin fun c tac ipat -> - let c = Value.to_constr c in - let of_tac t = Proofview.tclIGNORE (thaw t) in - let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in - let ipat = Value.to_option to_intro_pattern ipat in - Tac2tactics.forward true tac ipat c +let () = define_prim1 "tac_assert" begin fun ast -> + let ast = to_assertion ast in + Tac2tactics.assert_ ast end let () = define_prim3 "tac_enough" begin fun c tac ipat -> diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 083ec9e9d4..a6dd4e3a9f 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -170,6 +170,10 @@ type rewriting = multi * constr_with_bindings tactic +type assertion = +| AssertType of intro_pattern option * EConstr.t * unit tactic option +| AssertValue of Id.t * EConstr.t + let rewrite ev rw cl by = let map_rw (orient, repeat, c) = let c = c >>= fun c -> return (mk_with_bindings c) in @@ -179,9 +183,17 @@ let rewrite ev rw cl by = let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE tac, Equality.Naive) by in Equality.general_multi_rewrite ev rw cl by -let forward ev tac ipat c = +let forward fst tac ipat c = + let ipat = Option.map mk_intro_pattern ipat in + Tactics.forward fst tac ipat c + +let assert_ = function +| AssertValue (id, c) -> + let ipat = Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id) in + Tactics.forward true None (Some ipat) c +| AssertType (ipat, c, tac) -> let ipat = Option.map mk_intro_pattern ipat in - Tactics.forward ev tac ipat c + Tactics.forward true (Some tac) ipat c let letin_pat_tac ev ipat na c cl = let ipat = Option.map (fun (b, ipat) -> (b, Loc.tag @@ mk_intro_pattern_naming ipat)) ipat in diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 5fdd1c39bc..8e15fb1392 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -63,6 +63,10 @@ type rewriting = multi * constr_with_bindings tactic +type assertion = +| AssertType of intro_pattern option * constr * unit tactic option +| AssertValue of Id.t * constr + (** Local reimplementations of tactics variants from Coq *) val intros_patterns : evars_flag -> intro_pattern list -> unit tactic @@ -91,6 +95,8 @@ val rewrite : val forward : bool -> unit tactic option option -> intro_pattern option -> constr -> unit tactic +val assert_ : assertion -> unit tactic + val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic diff --git a/tests/example2.v b/tests/example2.v index 378abb86a8..20819606db 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -222,6 +222,12 @@ pose (X := True). constructor. Qed. +Goal True. +Proof. +pose True as X. +constructor. +Qed. + Goal True. Proof. let x := @foo in @@ -235,3 +241,22 @@ remember 0 as n eqn: foo at 1. rewrite foo. reflexivity. Qed. + +Goal True. +Proof. +assert (H := 0 + 0). +constructor. +Qed. + +Goal True. +Proof. +assert (exists n, n = 0) as [n Hn]. ++ exists 0; reflexivity. ++ exact I. +Qed. + +Goal True -> True. +Proof. +assert (H : 0 + 0 = 0) by reflexivity. +intros x; exact x. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index d4520dbdfd..91025ea964 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -279,6 +279,13 @@ Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := Std.set true p (default_on_concl cl). +Ltac2 assert0 ev ast := + enter_h ev (fun _ ast => Std.assert ast) ast. + +Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. + +Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. + Ltac2 default_everywhere cl := match cl with | None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } diff --git a/theories/Std.v b/theories/Std.v index 2eab172432..7831baf046 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -88,6 +88,11 @@ Ltac2 Type induction_clause := { indcl_in : clause option; }. +Ltac2 Type assertion := [ +| AssertType (intro_pattern option, constr, (unit -> unit) option) +| AssertValue (ident, constr) +]. + Ltac2 Type repeat := [ | Precisely (int) | UpTo (int) @@ -131,7 +136,7 @@ Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "ta Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". -Ltac2 @ external assert : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_assert". +Ltac2 @ external assert : assertion -> unit := "ltac2" "tac_assert". Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". -- cgit v1.2.3 From 5d208a8e1d46a57d3428ed43c195d193fc6c5b67 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 26 Sep 2017 22:47:09 +0200 Subject: Abstracting away the primitive functions on valexpr datatype. --- src/tac2core.ml | 123 +++++++++++++++++++++++++++-------------------------- src/tac2entries.ml | 2 +- src/tac2ffi.ml | 50 +++++++++++++++++++++- src/tac2ffi.mli | 19 ++++++++- src/tac2interp.ml | 66 +++++++++++++--------------- src/tac2print.ml | 18 ++++---- src/tac2stdlib.ml | 97 +++++++++++++++++++++--------------------- 7 files changed, 214 insertions(+), 161 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1917fa5f66..9e3cefc6f5 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -53,7 +53,8 @@ end open Core -let v_unit = ValInt 0 +let v_unit = Value.of_unit () +let v_blk = Valexpr.make_block let of_name c = match c with | Anonymous -> Value.of_option Value.of_ident None @@ -82,8 +83,8 @@ let to_rec_declaration (nas, ts, cs) = Value.to_array Value.to_constr cs) let of_result f = function -| Inl c -> ValBlk (0, [|f c|]) -| Inr e -> ValBlk (1, [|Value.of_exn e|]) +| Inl c -> v_blk 0 [|f c|] +| Inr e -> v_blk 1 [|Value.of_exn e|] (** Stdlib exceptions *) @@ -209,19 +210,19 @@ end let () = define2 "array_make" int valexpr begin fun n x -> if n < 0 || n > Sys.max_array_length then throw err_outofbounds - else wrap (fun () -> ValBlk (0, Array.make n x)) + else wrap (fun () -> v_blk 0 (Array.make n x)) end -let () = define1 "array_length" block begin fun v -> - return (ValInt (Array.length v)) +let () = define1 "array_length" block begin fun (_, v) -> + return (Value.of_int (Array.length v)) end -let () = define3 "array_set" block int valexpr begin fun v n x -> +let () = define3 "array_set" block int valexpr begin fun (_, v) n x -> if n < 0 || n >= Array.length v then throw err_outofbounds else wrap_unit (fun () -> v.(n) <- x) end -let () = define2 "array_get" block int begin fun v n -> +let () = define2 "array_get" block int begin fun (_, v) n -> if n < 0 || n >= Array.length v then throw err_outofbounds else wrap (fun () -> v.(n)) end @@ -306,167 +307,167 @@ let () = define1 "constr_kind" constr begin fun c -> Proofview.tclEVARMAP >>= fun sigma -> return begin match EConstr.kind sigma c with | Rel n -> - ValBlk (0, [|Value.of_int n|]) + v_blk 0 [|Value.of_int n|] | Var id -> - ValBlk (1, [|Value.of_ident id|]) + v_blk 1 [|Value.of_ident id|] | Meta n -> - ValBlk (2, [|Value.of_int n|]) + v_blk 2 [|Value.of_int n|] | Evar (evk, args) -> - ValBlk (3, [| + v_blk 3 [| Value.of_int (Evar.repr evk); Value.of_array Value.of_constr args; - |]) + |] | Sort s -> - ValBlk (4, [|Value.of_ext Value.val_sort s|]) + v_blk 4 [|Value.of_ext Value.val_sort s|] | Cast (c, k, t) -> - ValBlk (5, [| + v_blk 5 [| Value.of_constr c; Value.of_ext Value.val_cast k; Value.of_constr t; - |]) + |] | Prod (na, t, u) -> - ValBlk (6, [| + v_blk 6 [| of_name na; Value.of_constr t; Value.of_constr u; - |]) + |] | Lambda (na, t, c) -> - ValBlk (7, [| + v_blk 7 [| of_name na; Value.of_constr t; Value.of_constr c; - |]) + |] | LetIn (na, b, t, c) -> - ValBlk (8, [| + v_blk 8 [| of_name na; Value.of_constr b; Value.of_constr t; Value.of_constr c; - |]) + |] | App (c, cl) -> - ValBlk (9, [| + v_blk 9 [| Value.of_constr c; Value.of_array Value.of_constr cl; - |]) + |] | Const (cst, u) -> - ValBlk (10, [| + v_blk 10 [| Value.of_constant cst; of_instance u; - |]) + |] | Ind (ind, u) -> - ValBlk (11, [| + v_blk 11 [| Value.of_ext Value.val_inductive ind; of_instance u; - |]) + |] | Construct (cstr, u) -> - ValBlk (12, [| + v_blk 12 [| Value.of_ext Value.val_constructor cstr; of_instance u; - |]) + |] | Case (ci, c, t, bl) -> - ValBlk (13, [| + v_blk 13 [| Value.of_ext Value.val_case ci; Value.of_constr c; Value.of_constr t; Value.of_array Value.of_constr bl; - |]) + |] | Fix ((recs, i), def) -> let (nas, ts, cs) = of_rec_declaration def in - ValBlk (14, [| + v_blk 14 [| Value.of_array Value.of_int recs; Value.of_int i; nas; ts; cs; - |]) + |] | CoFix (i, def) -> let (nas, ts, cs) = of_rec_declaration def in - ValBlk (15, [| + v_blk 15 [| Value.of_int i; nas; ts; cs; - |]) + |] | Proj (p, c) -> - ValBlk (16, [| + v_blk 16 [| Value.of_ext Value.val_projection p; Value.of_constr c; - |]) + |] end end let () = define1 "constr_make" valexpr begin fun knd -> let open Constr in - let c = match knd with - | ValBlk (0, [|n|]) -> + let c = match Tac2ffi.to_block knd with + | (0, [|n|]) -> let n = Value.to_int n in EConstr.mkRel n - | ValBlk (1, [|id|]) -> + | (1, [|id|]) -> let id = Value.to_ident id in EConstr.mkVar id - | ValBlk (2, [|n|]) -> + | (2, [|n|]) -> let n = Value.to_int n in EConstr.mkMeta n - | ValBlk (3, [|evk; args|]) -> + | (3, [|evk; args|]) -> let evk = Evar.unsafe_of_int (Value.to_int evk) in let args = Value.to_array Value.to_constr args in EConstr.mkEvar (evk, args) - | ValBlk (4, [|s|]) -> + | (4, [|s|]) -> let s = Value.to_ext Value.val_sort s in EConstr.mkSort (EConstr.Unsafe.to_sorts s) - | ValBlk (5, [|c; k; t|]) -> + | (5, [|c; k; t|]) -> let c = Value.to_constr c in let k = Value.to_ext Value.val_cast k in let t = Value.to_constr t in EConstr.mkCast (c, k, t) - | ValBlk (6, [|na; t; u|]) -> + | (6, [|na; t; u|]) -> let na = to_name na in let t = Value.to_constr t in let u = Value.to_constr u in EConstr.mkProd (na, t, u) - | ValBlk (7, [|na; t; c|]) -> + | (7, [|na; t; c|]) -> let na = to_name na in let t = Value.to_constr t in let u = Value.to_constr c in EConstr.mkLambda (na, t, u) - | ValBlk (8, [|na; b; t; c|]) -> + | (8, [|na; b; t; c|]) -> let na = to_name na in let b = Value.to_constr b in let t = Value.to_constr t in let c = Value.to_constr c in EConstr.mkLetIn (na, b, t, c) - | ValBlk (9, [|c; cl|]) -> + | (9, [|c; cl|]) -> let c = Value.to_constr c in let cl = Value.to_array Value.to_constr cl in EConstr.mkApp (c, cl) - | ValBlk (10, [|cst; u|]) -> + | (10, [|cst; u|]) -> let cst = Value.to_constant cst in let u = to_instance u in EConstr.mkConstU (cst, u) - | ValBlk (11, [|ind; u|]) -> + | (11, [|ind; u|]) -> let ind = Value.to_ext Value.val_inductive ind in let u = to_instance u in EConstr.mkIndU (ind, u) - | ValBlk (12, [|cstr; u|]) -> + | (12, [|cstr; u|]) -> let cstr = Value.to_ext Value.val_constructor cstr in let u = to_instance u in EConstr.mkConstructU (cstr, u) - | ValBlk (13, [|ci; c; t; bl|]) -> + | (13, [|ci; c; t; bl|]) -> let ci = Value.to_ext Value.val_case ci in let c = Value.to_constr c in let t = Value.to_constr t in let bl = Value.to_array Value.to_constr bl in EConstr.mkCase (ci, c, t, bl) - | ValBlk (14, [|recs; i; nas; ts; cs|]) -> + | (14, [|recs; i; nas; ts; cs|]) -> let recs = Value.to_array Value.to_int recs in let i = Value.to_int i in let def = to_rec_declaration (nas, ts, cs) in EConstr.mkFix ((recs, i), def) - | ValBlk (15, [|i; nas; ts; cs|]) -> + | (15, [|i; nas; ts; cs|]) -> let i = Value.to_int i in let def = to_rec_declaration (nas, ts, cs) in EConstr.mkCoFix (i, def) - | ValBlk (16, [|p; c|]) -> + | (16, [|p; c|]) -> let p = Value.to_ext Value.val_projection p in let c = Value.to_constr c in EConstr.mkProj (p, c) @@ -622,8 +623,8 @@ let () = define1 "case" closure begin fun f -> set_bt info >>= fun info -> k (e, info) end in - return (ValBlk (0, [| Value.of_tuple [| x; Value.of_closure k |] |])) - | Proofview.Fail e -> return (ValBlk (1, [| Value.of_exn e |])) + return (v_blk 0 [| Value.of_tuple [| x; Value.of_closure k |] |]) + | Proofview.Fail e -> return (v_blk 1 [| Value.of_exn e |]) end end @@ -791,7 +792,7 @@ let interp_constr flags ist c = pf_apply begin fun env sigma -> try let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = ValExt (Value.val_constr, c) in + let c = Value.of_constr c in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c with e when catchable_exception e -> @@ -827,7 +828,7 @@ let () = define_ml_object Tac2quote.wit_open_constr obj let () = - let interp _ id = return (ValExt (Value.val_ident, id)) in + let interp _ id = return (Value.of_ident id) in let print _ id = str "ident:(" ++ Id.print id ++ str ")" in let obj = { ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); @@ -843,7 +844,7 @@ let () = GlbVal pat, gtypref t_pattern in let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in - let interp _ c = return (ValExt (Value.val_pattern, c)) in + let interp _ c = return (Value.of_pattern c) in let obj = { ml_intern = intern; ml_interp = interp; diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 24db19d02a..cd4b701ca7 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -774,7 +774,7 @@ let pr_frame = function let () = register_handler begin function | Tac2interp.LtacError (kn, args) -> let t_exn = KerName.make2 Tac2env.coq_prefix (Label.make "exn") in - let v = Tac2ffi.ValOpn (kn, args) in + let v = Tac2ffi.of_open (kn, args) in let t = GTypRef (Other t_exn, []) in let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 5460643bb5..7960d4d45f 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -41,6 +41,35 @@ type 'a arity = (valexpr, 'a) arity0 let mk_closure arity f = MLTactic (arity, f) +module Valexpr = +struct + +type t = valexpr + +let is_int = function +| ValInt _ -> true +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false + +let tag v = match v with +| ValBlk (n, _) -> n +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let field v n = match v with +| ValBlk (_, v) -> v.(n) +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let set_field v n w = match v with +| ValBlk (_, v) -> v.(n) <- w +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let make_block tag v = ValBlk (tag, v) +let make_int n = ValInt n + +end + type 'a repr = { r_of : 'a -> valexpr; r_to : valexpr -> 'a; @@ -251,9 +280,26 @@ let array r = { r_id = false; } +let of_block (n, args) = ValBlk (n, args) +let to_block = function +| ValBlk (n, args) -> (n, args) +| _ -> assert false + let block = { - r_of = of_tuple; - r_to = to_tuple; + r_of = of_block; + r_to = to_block; + r_id = false; +} + +let of_open (kn, args) = ValOpn (kn, args) + +let to_open = function +| ValOpn (kn, args) -> (kn, args) +| _ -> assert false + +let open_ = { + r_of = of_open; + r_to = to_open; r_id = false; } diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index af854e2d07..36743f3346 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -36,6 +36,17 @@ val arity_suc : 'a arity -> (valexpr -> 'a) arity val mk_closure : 'v arity -> 'v -> closure +module Valexpr : +sig + type t = valexpr + val is_int : t -> bool + val tag : t -> int + val field : t -> int -> t + val set_field : t -> int -> t -> unit + val make_block : int -> t array -> t + val make_int : int -> t +end + (** {5 Ltac2 FFI} *) type 'a repr = { @@ -89,7 +100,9 @@ val of_closure : closure -> valexpr val to_closure : valexpr -> closure val closure : closure repr -val block : valexpr array repr +val of_block : (int * valexpr array) -> valexpr +val to_block : valexpr -> (int * valexpr array) +val block : (int * valexpr array) repr val of_array : ('a -> valexpr) -> 'a array -> valexpr val to_array : (valexpr -> 'a) -> valexpr -> 'a array @@ -122,6 +135,10 @@ val of_ext : 'a Val.tag -> 'a -> valexpr val to_ext : 'a Val.tag -> valexpr -> 'a val repr_ext : 'a Val.tag -> 'a repr +val of_open : KerName.t * valexpr array -> valexpr +val to_open : valexpr -> KerName.t * valexpr array +val open_ : (KerName.t * valexpr array) repr + type ('a, 'b) fun1 val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 58a3a9a4ec..db30f52772 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -80,8 +80,8 @@ let get_ref ist kn = let return = Proofview.tclUNIT let rec interp (ist : environment) = function -| GTacAtm (AtmInt n) -> return (ValInt n) -| GTacAtm (AtmStr s) -> return (ValStr (Bytes.of_string s)) +| GTacAtm (AtmInt n) -> return (Tac2ffi.of_int n) +| GTacAtm (AtmStr s) -> return (Tac2ffi.of_string (Bytes.of_string s)) | GTacVar id -> return (get_var ist id) | GTacRef kn -> let data = get_ref ist kn in @@ -89,7 +89,7 @@ let rec interp (ist : environment) = function | GTacFun (ids, e) -> let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in let f = interp_app cls in - return (ValCls f) + return (Tac2ffi.of_closure f) | GTacApp (f, args) -> interp ist f >>= fun f -> Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> @@ -105,7 +105,7 @@ let rec interp (ist : environment) = function let map (na, e) = match e with | GTacFun (ids, e) -> let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - let f = ValCls (interp_app cls) in + let f = Tac2ffi.of_closure (interp_app cls) in na, cls, f | _ -> anomaly (str "Ill-formed recursive function") in @@ -119,10 +119,10 @@ let rec interp (ist : environment) = function let iter (_, e, _) = e.clos_env <- ist.env_ist in let () = List.iter iter fixs in interp ist e -| GTacCst (_, n, []) -> return (ValInt n) +| GTacCst (_, n, []) -> return (Valexpr.make_int n) | GTacCst (_, n, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (ValBlk (n, Array.of_list el)) + return (Valexpr.make_block n (Array.of_list el)) | GTacCse (e, _, cse0, cse1) -> interp ist e >>= fun e -> interp_case ist e cse0 cse1 | GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> @@ -135,7 +135,7 @@ let rec interp (ist : environment) = function interp_set ist e p r | GTacOpn (kn, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (ValOpn (kn, Array.of_list el)) + return (Tac2ffi.of_open (kn, Array.of_list el)) | GTacPrm (ml, el) -> Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) @@ -156,17 +156,17 @@ and interp_app f = in Tac2ffi.abstract (List.length f.clos_var) ans -and interp_case ist e cse0 cse1 = match e with -| ValInt n -> interp ist cse0.(n) -| ValBlk (n, args) -> - let (ids, e) = cse1.(n) in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist e -| ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> - anomaly (str "Unexpected value shape") +and interp_case ist e cse0 cse1 = + if Valexpr.is_int e then + interp ist cse0.(Tac2ffi.to_int e) + else + let (n, args) = Tac2ffi.to_block e in + let (ids, e) = cse1.(n) in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist e -and interp_with ist e cse def = match e with -| ValOpn (kn, args) -> +and interp_with ist e cse def = + let (kn, args) = Tac2ffi.to_open e in let br = try Some (KNmap.find kn cse) with Not_found -> None in begin match br with | None -> @@ -178,24 +178,16 @@ and interp_with ist e cse def = match e with let ist = CArray.fold_left2 push_name ist ids args in interp ist p end -| ValInt _ | ValBlk _ | ValExt _ | ValStr _ | ValCls _ -> - anomaly (str "Unexpected value shape") - -and interp_proj ist e p = match e with -| ValBlk (_, args) -> - return args.(p) -| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> - anomaly (str "Unexpected value shape") - -and interp_set ist e p r = match e with -| ValBlk (_, args) -> - let () = args.(p) <- r in - return (ValInt 0) -| ValInt _ | ValExt _ | ValStr _ | ValCls _ | ValOpn _ -> - anomaly (str "Unexpected value shape") + +and interp_proj ist e p = + return (Valexpr.field e p) + +and interp_set ist e p r = + let () = Valexpr.set_field e p r in + return (Valexpr.make_int 0) and eval_pure kn = function -| GTacAtm (AtmInt n) -> ValInt n +| GTacAtm (AtmInt n) -> Valexpr.make_int n | GTacRef kn -> let { Tac2env.gdata_expr = e } = try Tac2env.interp_global kn @@ -205,10 +197,10 @@ and eval_pure kn = function | GTacFun (na, e) -> let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in let f = interp_app cls in - ValCls f -| GTacCst (_, n, []) -> ValInt n -| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_unnamed el) -| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_unnamed el) + Tac2ffi.of_closure f +| GTacCst (_, n, []) -> Valexpr.make_int n +| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) +| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) | GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ | GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> anomaly (Pp.str "Term is not a syntactical value") diff --git a/src/tac2print.ml b/src/tac2print.ml index d39051c93e..45360a61f4 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -381,29 +381,27 @@ let rec pr_valexpr env sigma v t = match kind t with (** Shouldn't happen thanks to kind *) assert false | GTydAlg alg -> - begin match v with - | ValInt n -> pr_internal_constructor kn n true - | ValBlk (n, args) -> + if Valexpr.is_int v then + pr_internal_constructor kn (Tac2ffi.to_int v) true + else + let (n, args) = Tac2ffi.to_block v in let (id, tpe) = find_constructor n false alg.galg_constructors in let knc = change_kn_label kn id in let args = pr_constrargs env sigma params args tpe in hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - | _ -> str "" - end | GTydRec rcd -> str "{}" | GTydOpn -> - begin match v with - | ValOpn (knc, [||]) -> pr_constructor knc - | ValOpn (knc, args) -> + begin match Tac2ffi.to_open v with + | (knc, [||]) -> pr_constructor knc + | (knc, args) -> let data = Tac2env.interp_constructor knc in let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - | _ -> str "" end end | GTypArrow _ -> str "" | GTypRef (Tuple _, tl) -> - let blk = Array.to_list (block.r_to v) in + let blk = Array.to_list (snd (block.r_to v)) in if List.length blk == List.length tl then let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 5f61081a76..0e0eb116b3 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -22,17 +22,17 @@ let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () let thaw f = Tac2ffi.apply (Value.to_closure f) [v_unit] -let to_pair f g = function -| ValBlk (0, [| x; y |]) -> (f x, g y) +let to_pair f g v = match Value.to_tuple v with +| [| x; y |] -> (f x, g y) | _ -> assert false let to_name c = match Value.to_option Value.to_ident c with | None -> Anonymous | Some id -> Name id -let to_qhyp = function -| ValBlk (0, [| i |]) -> AnonHyp (Value.to_int i) -| ValBlk (1, [| id |]) -> NamedHyp (Value.to_ident id) +let to_qhyp v = match Value.to_block v with +| (0, [| i |]) -> AnonHyp (Value.to_int i) +| (1, [| id |]) -> NamedHyp (Value.to_ident id) | _ -> assert false let to_bindings = function @@ -43,8 +43,8 @@ let to_bindings = function ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) | _ -> assert false -let to_constr_with_bindings = function -| ValBlk (0, [| c; bnd |]) -> (Value.to_constr c, to_bindings bnd) +let to_constr_with_bindings v = match Value.to_tuple v with +| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) | _ -> assert false let to_int_or_var i = ArgArg (Value.to_int i) @@ -56,16 +56,16 @@ let to_occurrences f = function | ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list f vl) | _ -> assert false -let to_hyp_location_flag = function -| ValInt 0 -> InHyp -| ValInt 1 -> InHypTypeOnly -| ValInt 2 -> InHypValueOnly +let to_hyp_location_flag v = match Value.to_int v with +| 0 -> InHyp +| 1 -> InHypTypeOnly +| 2 -> InHypValueOnly | _ -> assert false -let to_clause = function -| ValBlk (0, [| hyps; concl |]) -> - let cast = function - | ValBlk (0, [| hyp; occ; flag |]) -> +let to_clause v = match Value.to_tuple v with +| [| hyps; concl |] -> + let cast v = match Value.to_tuple v with + | [| hyp; occ; flag |] -> ((to_occurrences to_int_or_var occ, Value.to_ident hyp), to_hyp_location_flag flag) | _ -> assert false in @@ -73,8 +73,8 @@ let to_clause = function { onhyps = hyps; concl_occs = to_occurrences to_int_or_var concl; } | _ -> assert false -let to_red_flag = function -| ValBlk (0, [| beta; iota; fix; cofix; zeta; delta; const |]) -> +let to_red_flag v = match Value.to_tuple v with +| [| beta; iota; fix; cofix; zeta; delta; const |] -> { rBeta = Value.to_bool beta; rMatch = Value.to_bool iota; @@ -92,10 +92,10 @@ let to_pattern_with_occs pat = let to_constr_with_occs c = to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) c -let rec to_intro_pattern = function -| ValBlk (0, [| b |]) -> IntroForthcoming (Value.to_bool b) -| ValBlk (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) -| ValBlk (2, [| act |]) -> IntroAction (to_intro_pattern_action act) +let rec to_intro_pattern v = match Value.to_block v with +| (0, [| b |]) -> IntroForthcoming (Value.to_bool b) +| (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) +| (2, [| act |]) -> IntroAction (to_intro_pattern_action act) | _ -> assert false and to_intro_pattern_naming = function @@ -116,26 +116,26 @@ and to_intro_pattern_action = function | ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) | _ -> assert false -and to_or_and_intro_pattern = function -| ValBlk (0, [| ill |]) -> +and to_or_and_intro_pattern v = match Value.to_block v with +| (0, [| ill |]) -> IntroOrPattern (Value.to_list to_intro_patterns ill) -| ValBlk (1, [| il |]) -> +| (1, [| il |]) -> IntroAndPattern (to_intro_patterns il) | _ -> assert false and to_intro_patterns il = Value.to_list to_intro_pattern il -let to_destruction_arg = function -| ValBlk (0, [| c |]) -> +let to_destruction_arg v = match Value.to_block v with +| (0, [| c |]) -> let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in ElimOnConstr c -| ValBlk (1, [| id |]) -> ElimOnIdent (Value.to_ident id) -| ValBlk (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) +| (1, [| id |]) -> ElimOnIdent (Value.to_ident id) +| (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) | _ -> assert false -let to_induction_clause = function -| ValBlk (0, [| arg; eqn; as_; in_ |]) -> +let to_induction_clause v = match Value.to_tuple v with +| [| arg; eqn; as_; in_ |] -> let arg = to_destruction_arg arg in let eqn = Value.to_option to_intro_pattern_naming eqn in let as_ = Value.to_option to_or_and_intro_pattern as_ in @@ -144,14 +144,14 @@ let to_induction_clause = function | _ -> assert false -let to_assertion = function -| ValBlk (0, [| ipat; t; tac |]) -> +let to_assertion v = match Value.to_block v with +| (0, [| ipat; t; tac |]) -> let to_tac t = Proofview.tclIGNORE (thaw t) in let ipat = Value.to_option to_intro_pattern ipat in let t = Value.to_constr t in let tac = Value.to_option to_tac tac in AssertType (ipat, t, tac) -| ValBlk (1, [| id; c |]) -> +| (1, [| id; c |]) -> AssertValue (Value.to_ident id, Value.to_constr c) | _ -> assert false @@ -162,30 +162,29 @@ let to_multi = function | ValInt 1 -> RepeatPlus | _ -> assert false -let to_rewriting = function -| ValBlk (0, [| orient; repeat; c |]) -> +let to_rewriting v = match Value.to_tuple v with +| [| orient; repeat; c |] -> let orient = Value.to_option Value.to_bool orient in let repeat = to_multi repeat in - (** FIXME: lost backtrace *) let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in (orient, repeat, c) | _ -> assert false -let to_debug = function -| ValInt 0 -> Hints.Off -| ValInt 1 -> Hints.Info -| ValInt 2 -> Hints.Debug +let to_debug v = match Value.to_int v with +| 0 -> Hints.Off +| 1 -> Hints.Info +| 2 -> Hints.Debug | _ -> assert false -let to_strategy = function -| ValInt 0 -> Class_tactics.Bfs -| ValInt 1 -> Class_tactics.Dfs +let to_strategy v = match Value.to_int v with +| 0 -> Class_tactics.Bfs +| 1 -> Class_tactics.Dfs | _ -> assert false -let to_inversion_kind = function -| ValInt 0 -> Misctypes.SimpleInversion -| ValInt 1 -> Misctypes.FullInversion -| ValInt 2 -> Misctypes.FullInversionClear +let to_inversion_kind v = match Value.to_int v with +| 0 -> Misctypes.SimpleInversion +| 1 -> Misctypes.FullInversion +| 2 -> Misctypes.FullInversionClear | _ -> assert false let to_move_location = function @@ -258,8 +257,8 @@ let () = define_prim2 "tac_case" begin fun ev c -> end let () = define_prim1 "tac_generalize" begin fun cl -> - let cast = function - | ValBlk (0, [| c; occs; na |]) -> + let cast v = match Value.to_tuple v with + | [| c; occs; na |] -> ((to_occurrences Value.to_int occs, Value.to_constr c), to_name na) | _ -> assert false in -- cgit v1.2.3 From 65be2f00dc464493edb8031544b61db6216d453c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 1 Oct 2017 14:42:01 +0200 Subject: Moving ML types used by Ltac2 to their proper interface. --- _CoqProject | 1 + src/tac2stdlib.ml | 14 +++++----- src/tac2tactics.ml | 51 +----------------------------------- src/tac2tactics.mli | 56 ++------------------------------------- src/tac2types.mli | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 86 insertions(+), 111 deletions(-) create mode 100644 src/tac2types.mli diff --git a/_CoqProject b/_CoqProject index fc9df4ee3f..43e9b76991 100644 --- a/_CoqProject +++ b/_CoqProject @@ -5,6 +5,7 @@ src/tac2dyn.ml src/tac2dyn.mli src/tac2expr.mli +src/tac2types.mli src/tac2env.ml src/tac2env.mli src/tac2print.ml diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 0e0eb116b3..13f150381a 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -9,10 +9,10 @@ open Names open Locus open Globnames -open Misctypes open Genredexpr open Tac2expr open Tac2ffi +open Tac2types open Tac2tactics open Proofview.Notations @@ -47,7 +47,7 @@ let to_constr_with_bindings v = match Value.to_tuple v with | [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) | _ -> assert false -let to_int_or_var i = ArgArg (Value.to_int i) +let to_int_or_var i = Misctypes.ArgArg (Value.to_int i) let to_occurrences f = function | ValInt 0 -> AllOccurrences @@ -188,10 +188,10 @@ let to_inversion_kind v = match Value.to_int v with | _ -> assert false let to_move_location = function -| ValInt 0 -> MoveFirst -| ValInt 1 -> MoveLast -| ValBlk (0, [|id|]) -> MoveAfter (Value.to_ident id) -| ValBlk (1, [|id|]) -> MoveBefore (Value.to_ident id) +| ValInt 0 -> Misctypes.MoveFirst +| ValInt 1 -> Misctypes.MoveLast +| ValBlk (0, [|id|]) -> Misctypes.MoveAfter (Value.to_ident id) +| ValBlk (1, [|id|]) -> Misctypes.MoveBefore (Value.to_ident id) | _ -> assert false (** Standard tactics sharing their implementation with Ltac1 *) @@ -502,7 +502,7 @@ end let () = define_prim2 "tac_intro" begin fun id mv -> let id = Value.to_option Value.to_ident id in let mv = Value.to_option to_move_location mv in - let mv = Option.default MoveLast mv in + let mv = Option.default Misctypes.MoveLast mv in Tactics.intro_move id mv end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index a6dd4e3a9f..42916a9578 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -11,47 +11,13 @@ open Util open Names open Globnames open Misctypes -open Tactypes +open Tac2types open Genredexpr open Proofview open Proofview.Notations let return = Proofview.tclUNIT -type explicit_bindings = (quantified_hypothesis * EConstr.t) list - -type bindings = -| ImplicitBindings of EConstr.t list -| ExplicitBindings of explicit_bindings -| NoBindings - -type constr_with_bindings = EConstr.constr * bindings - -type intro_pattern = -| IntroForthcoming of bool -| IntroNaming of intro_pattern_naming -| IntroAction of intro_pattern_action -and intro_pattern_naming = -| IntroIdentifier of Id.t -| IntroFresh of Id.t -| IntroAnonymous -and intro_pattern_action = -| IntroWildcard -| IntroOrAndPattern of or_and_intro_pattern -| IntroInjection of intro_pattern list -| IntroApplyOn of EConstr.t tactic * intro_pattern -| IntroRewrite of bool -and or_and_intro_pattern = -| IntroOrPattern of intro_pattern list list -| IntroAndPattern of intro_pattern list - -type core_destruction_arg = -| ElimOnConstr of constr_with_bindings tactic -| ElimOnIdent of Id.t -| ElimOnAnonHyp of int - -type destruction_arg = core_destruction_arg - let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; @@ -117,12 +83,6 @@ let apply adv ev cb cl = let cl = Option.map mk_intro_pattern cl in Tactics.apply_delayed_in adv ev id cb cl -type induction_clause = - destruction_arg * - intro_pattern_naming option * - or_and_intro_pattern option * - Locus.clause option - let mk_destruction_arg = function | ElimOnConstr c -> let c = c >>= fun c -> return (mk_with_bindings c) in @@ -165,15 +125,6 @@ let split_with_bindings ev bnd = let bnd = mk_bindings bnd in Tactics.split_with_bindings ev [bnd] -type rewriting = - bool option * - multi * - constr_with_bindings tactic - -type assertion = -| AssertType of intro_pattern option * EConstr.t * unit tactic option -| AssertValue of Id.t * EConstr.t - let rewrite ev rw cl by = let map_rw (orient, repeat, c) = let c = c >>= fun c -> return (mk_with_bindings c) in diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 8e15fb1392..842b09c22f 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -12,61 +12,9 @@ open Globnames open Tac2expr open EConstr open Genredexpr -open Misctypes -open Tactypes +open Tac2types open Proofview -(** Redefinition of Ltac1 data structures because of impedance mismatch *) - -type explicit_bindings = (quantified_hypothesis * EConstr.t) list - -type bindings = -| ImplicitBindings of EConstr.t list -| ExplicitBindings of explicit_bindings -| NoBindings - -type constr_with_bindings = EConstr.constr * bindings - -type core_destruction_arg = -| ElimOnConstr of constr_with_bindings tactic -| ElimOnIdent of Id.t -| ElimOnAnonHyp of int - -type destruction_arg = core_destruction_arg - -type intro_pattern = -| IntroForthcoming of bool -| IntroNaming of intro_pattern_naming -| IntroAction of intro_pattern_action -and intro_pattern_naming = -| IntroIdentifier of Id.t -| IntroFresh of Id.t -| IntroAnonymous -and intro_pattern_action = -| IntroWildcard -| IntroOrAndPattern of or_and_intro_pattern -| IntroInjection of intro_pattern list -| IntroApplyOn of EConstr.t tactic * intro_pattern -| IntroRewrite of bool -and or_and_intro_pattern = -| IntroOrPattern of intro_pattern list list -| IntroAndPattern of intro_pattern list - -type induction_clause = - destruction_arg * - intro_pattern_naming option * - or_and_intro_pattern option * - clause option - -type rewriting = - bool option * - multi * - constr_with_bindings tactic - -type assertion = -| AssertType of intro_pattern option * constr * unit tactic option -| AssertValue of Id.t * constr - (** Local reimplementations of tactics variants from Coq *) val intros_patterns : evars_flag -> intro_pattern list -> unit tactic @@ -161,7 +109,7 @@ val eauto : Hints.debug -> int option -> int option -> constr tactic list -> val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> Id.t list option -> unit Proofview.tactic -val inversion : inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic +val inversion : Misctypes.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic val contradiction : constr_with_bindings option -> unit tactic diff --git a/src/tac2types.mli b/src/tac2types.mli new file mode 100644 index 0000000000..6845de8c7c --- /dev/null +++ b/src/tac2types.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (Value.to_constr c, to_bindings bnd) | _ -> assert false -let to_int_or_var i = Misctypes.ArgArg (Value.to_int i) - -let to_occurrences f = function +let to_occurrences = function | ValInt 0 -> AllOccurrences -| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list f vl) +| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list Value.to_int vl) | ValInt 1 -> NoOccurrences -| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list f vl) +| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) | _ -> assert false let to_hyp_location_flag v = match Value.to_int v with @@ -66,11 +63,11 @@ let to_clause v = match Value.to_tuple v with | [| hyps; concl |] -> let cast v = match Value.to_tuple v with | [| hyp; occ; flag |] -> - ((to_occurrences to_int_or_var occ, Value.to_ident hyp), to_hyp_location_flag flag) + (Value.to_ident hyp, to_occurrences occ, to_hyp_location_flag flag) | _ -> assert false in let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in - { onhyps = hyps; concl_occs = to_occurrences to_int_or_var concl; } + { onhyps = hyps; concl_occs = to_occurrences concl; } | _ -> assert false let to_red_flag v = match Value.to_tuple v with @@ -87,10 +84,10 @@ let to_red_flag v = match Value.to_tuple v with | _ -> assert false let to_pattern_with_occs pat = - to_pair Value.to_pattern (fun occ -> to_occurrences to_int_or_var occ) pat + to_pair Value.to_pattern to_occurrences pat let to_constr_with_occs c = - to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) c + to_pair Value.to_constr to_occurrences c let rec to_intro_pattern v = match Value.to_block v with | (0, [| b |]) -> IntroForthcoming (Value.to_bool b) @@ -259,11 +256,11 @@ end let () = define_prim1 "tac_generalize" begin fun cl -> let cast v = match Value.to_tuple v with | [| c; occs; na |] -> - ((to_occurrences Value.to_int occs, Value.to_constr c), to_name na) + (Value.to_constr c, to_occurrences occs, to_name na) | _ -> assert false in let cl = Value.to_list cast cl in - Tactics.new_generalize_gen cl + Tac2tactics.generalize cl end let () = define_prim1 "tac_assert" begin fun ast -> @@ -291,7 +288,7 @@ let () = define_prim3 "tac_set" begin fun ev p cl -> Proofview.tclEVARMAP >>= fun sigma -> thaw p >>= fun p -> let (na, c) = to_pair to_name Value.to_constr p in - Tactics.letin_pat_tac ev None na (sigma, c) cl + Tac2tactics.letin_pat_tac ev None na (sigma, c) cl end let () = define_prim5 "tac_remember" begin fun ev na c eqpat cl -> @@ -326,12 +323,12 @@ end let () = define_prim1 "tac_red" begin fun cl -> let cl = to_clause cl in - Tactics.reduce (Red false) cl + Tac2tactics.reduce (Red false) cl end let () = define_prim1 "tac_hnf" begin fun cl -> let cl = to_clause cl in - Tactics.reduce Hnf cl + Tac2tactics.reduce Hnf cl end let () = define_prim3 "tac_simpl" begin fun flags where cl -> @@ -360,7 +357,7 @@ let () = define_prim2 "tac_lazy" begin fun flags cl -> end let () = define_prim2 "tac_unfold" begin fun refs cl -> - let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in + let map v = to_pair Value.to_reference to_occurrences v in let refs = Value.to_list map refs in let cl = to_clause cl in Tac2tactics.unfold refs cl @@ -369,7 +366,7 @@ end let () = define_prim2 "tac_fold" begin fun args cl -> let args = Value.to_list Value.to_constr args in let cl = to_clause cl in - Tactics.reduce (Fold args) cl + Tac2tactics.reduce (Fold args) cl end let () = define_prim2 "tac_pattern" begin fun where cl -> @@ -442,7 +439,7 @@ let () = define_red2 "eval_lazy" begin fun flags c -> end let () = define_red2 "eval_unfold" begin fun refs c -> - let map v = to_pair Value.to_reference (fun occ -> to_occurrences to_int_or_var occ) v in + let map v = to_pair Value.to_reference to_occurrences v in let refs = Value.to_list map refs in let c = Value.to_constr c in Tac2tactics.eval_unfold refs c @@ -455,7 +452,7 @@ let () = define_red2 "eval_fold" begin fun args c -> end let () = define_red2 "eval_pattern" begin fun where c -> - let where = Value.to_list (fun p -> to_pair Value.to_constr (fun occ -> to_occurrences to_int_or_var occ) p) where in + let where = Value.to_list (fun p -> to_pair Value.to_constr to_occurrences p) where in let c = Value.to_constr c in Tac2tactics.eval_pattern where c end @@ -569,7 +566,7 @@ end let () = define_prim1 "tac_symmetry" begin fun cl -> let cl = to_clause cl in - Tactics.intros_symmetry cl + Tac2tactics.symmetry cl end let () = define_prim2 "tac_split" begin fun ev bnd -> diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 42916a9578..b55bd5c1b8 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -67,6 +67,23 @@ and mk_or_and_intro_pattern = function let mk_intro_patterns ipat = List.map mk_intro_pattern ipat +let mk_occurrences f = function +| AllOccurrences -> Locus.AllOccurrences +| AllOccurrencesBut l -> Locus.AllOccurrencesBut (List.map f l) +| NoOccurrences -> Locus.NoOccurrences +| OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) + +let mk_occurrences_expr occ = + mk_occurrences (fun i -> Misctypes.ArgArg i) occ + +let mk_hyp_location (id, occs, h) = + ((mk_occurrences_expr occs, id), h) + +let mk_clause cl = { + Locus.onhyps = Option.map (fun l -> List.map mk_hyp_location l) cl.onhyps; + Locus.concl_occs = mk_occurrences_expr cl.concl_occs; +} + let intros_patterns ev ipat = let ipat = mk_intro_patterns ipat in Tactics.intro_patterns ev ipat @@ -93,6 +110,7 @@ let mk_destruction_arg = function let mk_induction_clause (arg, eqn, as_, occ) = let eqn = Option.map (fun ipat -> Loc.tag @@ mk_intro_pattern_naming ipat) eqn in let as_ = Option.map (fun ipat -> Loc.tag @@ mk_or_and_intro_pattern ipat) as_ in + let occ = Option.map mk_clause occ in ((None, mk_destruction_arg arg), (eqn, as_), occ) let induction_destruct isrec ev (ic : induction_clause list) using = @@ -105,6 +123,11 @@ let elim ev c copt = let copt = Option.map mk_with_bindings copt in Tactics.elim ev None c copt +let generalize pl = + let mk_occ occs = mk_occurrences (fun i -> i) occs in + let pl = List.map (fun (c, occs, na) -> (mk_occ occs, c), na) pl in + Tactics.new_generalize_gen pl + let general_case_analysis ev c = let c = mk_with_bindings c in Tactics.general_case_analysis ev None c @@ -131,9 +154,14 @@ let rewrite ev rw cl by = (Option.default true orient, repeat, None, delayed_of_tactic c) in let rw = List.map map_rw rw in + let cl = mk_clause cl in let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE tac, Equality.Naive) by in Equality.general_multi_rewrite ev rw cl by +let symmetry cl = + let cl = mk_clause cl in + Tactics.intros_symmetry cl + let forward fst tac ipat c = let ipat = Option.map mk_intro_pattern ipat in Tactics.forward fst tac ipat c @@ -148,6 +176,7 @@ let assert_ = function let letin_pat_tac ev ipat na c cl = let ipat = Option.map (fun (b, ipat) -> (b, Loc.tag @@ mk_intro_pattern_naming ipat)) ipat in + let cl = mk_clause cl in Tactics.letin_pat_tac ev ipat na c cl (** Ltac interface treats differently global references than other term @@ -155,9 +184,9 @@ let letin_pat_tac ev ipat na c cl = Instead, we parse indifferently any pattern and dispatch when the tactic is called. *) let map_pattern_with_occs (pat, occ) = match pat with -| Pattern.PRef (ConstRef cst) -> (occ, Inl (EvalConstRef cst)) -| Pattern.PRef (VarRef id) -> (occ, Inl (EvalVarRef id)) -| _ -> (occ, Inr pat) +| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) +| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| _ -> (mk_occurrences_expr occ, Inr pat) let get_evaluable_reference = function | VarRef id -> Proofview.tclUNIT (EvalVarRef id) @@ -167,44 +196,57 @@ let get_evaluable_reference = function Nametab.pr_global_env Id.Set.empty r ++ spc () ++ str "to an evaluable reference.") +let reduce r cl = + let cl = mk_clause cl in + Tactics.reduce r cl + let simpl flags where cl = let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in Tactics.reduce (Simpl (flags, where)) cl let cbv flags cl = + let cl = mk_clause cl in Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in Tactics.reduce (Cbv flags) cl let cbn flags cl = + let cl = mk_clause cl in Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in Tactics.reduce (Cbn flags) cl let lazy_ flags cl = + let cl = mk_clause cl in Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> let flags = { flags with rConst } in Tactics.reduce (Lazy flags) cl let unfold occs cl = + let cl = mk_clause cl in let map (gr, occ) = + let occ = mk_occurrences_expr occ in get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) in Proofview.Monad.List.map map occs >>= fun occs -> Tactics.reduce (Unfold occs) cl let pattern where cl = - let where = List.map (fun (c, occ) -> (occ, c)) where in + let where = List.map (fun (c, occ) -> (mk_occurrences_expr occ, c)) where in + let cl = mk_clause cl in Tactics.reduce (Pattern where) cl let vm where cl = let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in Tactics.reduce (CbvVm where) cl let native where cl = let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in Tactics.reduce (CbvNative where) cl let eval_fun red c = @@ -244,6 +286,7 @@ let eval_lazy flags c = let eval_unfold occs c = let map (gr, occ) = + let occ = mk_occurrences_expr occ in get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) in Proofview.Monad.List.map map occs >>= fun occs -> @@ -253,7 +296,7 @@ let eval_fold cl c = eval_fun (Fold cl) c let eval_pattern where c = - let where = List.map (fun (pat, occ) -> (occ, pat)) where in + let where = List.map (fun (pat, occ) -> (mk_occurrences_expr occ, pat)) where in eval_fun (Pattern where) c let eval_vm where c = @@ -303,6 +346,7 @@ let injection ev ipat arg = let autorewrite ~all by ids cl = let conds = if all then Some Equality.AllMatches else None in let ids = List.map Id.to_string ids in + let cl = mk_clause cl in match by with | None -> Autorewrite.auto_multi_rewrite ?conds ids cl | Some by -> Autorewrite.auto_multi_rewrite_with ?conds by ids cl diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 842b09c22f..3d64e7ec8c 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Locus open Globnames open Tac2expr open EConstr @@ -31,6 +30,8 @@ val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic +val generalize : (constr * occurrences * Name.t) list -> unit tactic + val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic val left_with_bindings : evars_flag -> bindings -> unit tactic @@ -40,6 +41,8 @@ val split_with_bindings : evars_flag -> bindings -> unit tactic val rewrite : evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic +val symmetry : clause -> unit tactic + val forward : bool -> unit tactic option option -> intro_pattern option -> constr -> unit tactic @@ -48,8 +51,10 @@ val assert_ : assertion -> unit tactic val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic +val reduce : Redexpr.red_expr -> clause -> unit tactic + val simpl : global_reference glob_red_flag -> - (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic + (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic val cbv : global_reference glob_red_flag -> clause -> unit tactic @@ -57,20 +62,20 @@ val cbn : global_reference glob_red_flag -> clause -> unit tactic val lazy_ : global_reference glob_red_flag -> clause -> unit tactic -val unfold : (global_reference * occurrences_expr) list -> clause -> unit tactic +val unfold : (global_reference * occurrences) list -> clause -> unit tactic -val pattern : (constr * occurrences_expr) list -> clause -> unit tactic +val pattern : (constr * occurrences) list -> clause -> unit tactic -val vm : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic +val vm : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic -val native : (Pattern.constr_pattern * occurrences_expr) option -> clause -> unit tactic +val native : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic val eval_red : constr -> constr tactic val eval_hnf : constr -> constr tactic val eval_simpl : global_reference glob_red_flag -> - (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic + (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic val eval_cbv : global_reference glob_red_flag -> constr -> constr tactic @@ -78,15 +83,15 @@ val eval_cbn : global_reference glob_red_flag -> constr -> constr tactic val eval_lazy : global_reference glob_red_flag -> constr -> constr tactic -val eval_unfold : (global_reference * occurrences_expr) list -> constr -> constr tactic +val eval_unfold : (global_reference * occurrences) list -> constr -> constr tactic val eval_fold : constr list -> constr -> constr tactic -val eval_pattern : (EConstr.t * occurrences_expr) list -> constr -> constr tactic +val eval_pattern : (EConstr.t * occurrences) list -> constr -> constr tactic -val eval_vm : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic +val eval_vm : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic -val eval_native : (Pattern.constr_pattern * occurrences_expr) option -> constr -> constr tactic +val eval_native : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic val discriminate : evars_flag -> destruction_arg option -> unit tactic diff --git a/src/tac2types.mli b/src/tac2types.mli index 6845de8c7c..1cacbefc88 100644 --- a/src/tac2types.mli +++ b/src/tac2types.mli @@ -53,11 +53,26 @@ and or_and_intro_pattern = | IntroOrPattern of intro_pattern list list | IntroAndPattern of intro_pattern list +type occurrences = +| AllOccurrences +| AllOccurrencesBut of int list +| NoOccurrences +| OnlyOccurrences of int list + +type hyp_location_flag = Locus.hyp_location_flag = +| InHyp | InHypTypeOnly | InHypValueOnly + +type hyp_location = Id.t * occurrences * hyp_location_flag + +type clause = + { onhyps : hyp_location list option; + concl_occs : occurrences } + type induction_clause = destruction_arg * intro_pattern_naming option * or_and_intro_pattern option * - Locus.clause option + clause option type multi = Misctypes.multi = | Precisely of int -- cgit v1.2.3 From 0145084daa86b35a1d2a8285c4e16a9a231e3652 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 1 Oct 2017 19:10:11 +0200 Subject: Using Ltac2 native closures in some tactic APIs. --- src/tac2ffi.ml | 1 + src/tac2ffi.mli | 1 + src/tac2stdlib.ml | 4 ++-- src/tac2tactics.ml | 7 ++++++- src/tac2types.mli | 6 ++++-- 5 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 7960d4d45f..923a29e5c5 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -329,6 +329,7 @@ let reference = { type ('a, 'b) fun1 = closure let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure +let to_fun1 r0 r1 f = to_closure f let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = fun arity f args -> match args, arity with diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 36743f3346..cb6d5a1e49 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -143,6 +143,7 @@ type ('a, 'b) fun1 val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic +val to_fun1 : 'a repr -> 'b repr -> valexpr -> ('a, 'b) fun1 val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr val valexpr : valexpr repr diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 4bcbe69b07..2828bbc53f 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -108,7 +108,7 @@ and to_intro_pattern_action = function let map ipat = to_intro_pattern ipat in IntroInjection (Value.to_list map inj) | ValBlk (2, [| c; ipat |]) -> - let c = thaw c >>= fun c -> return (Value.to_constr c) in + let c = Value.to_fun1 Value.unit Value.constr c in IntroApplyOn (c, to_intro_pattern ipat) | ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) | _ -> assert false @@ -143,7 +143,7 @@ let to_induction_clause v = match Value.to_tuple v with let to_assertion v = match Value.to_block v with | (0, [| ipat; t; tac |]) -> - let to_tac t = Proofview.tclIGNORE (thaw t) in + let to_tac t = Value.to_fun1 Value.unit Value.unit t in let ipat = Value.to_option to_intro_pattern ipat in let t = Value.to_constr t in let tac = Value.to_option to_tac tac in diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index b55bd5c1b8..0b25ebb378 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -17,6 +17,7 @@ open Proofview open Proofview.Notations let return = Proofview.tclUNIT +let thaw r f = Tac2ffi.app_fun1 f Tac2ffi.unit r () let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; @@ -31,6 +32,9 @@ let delayed_of_tactic tac env sigma = let c, pv, _, _ = Proofview.apply env tac pv in (sigma, c) +let delayed_of_thunk r tac env sigma = + delayed_of_tactic (thaw r tac) env sigma + let mk_bindings = function | ImplicitBindings l -> Misctypes.ImplicitBindings l | ExplicitBindings l -> @@ -55,7 +59,7 @@ and mk_intro_pattern_action = function | IntroOrAndPattern ipat -> Misctypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) | IntroInjection ipats -> Misctypes.IntroInjection (List.map mk_intro_pattern ipats) | IntroApplyOn (c, ipat) -> - let c = Loc.tag @@ delayed_of_tactic c in + let c = Loc.tag @@ delayed_of_thunk Tac2ffi.constr c in Misctypes.IntroApplyOn (c, mk_intro_pattern ipat) | IntroRewrite b -> Misctypes.IntroRewrite b @@ -172,6 +176,7 @@ let assert_ = function Tactics.forward true None (Some ipat) c | AssertType (ipat, c, tac) -> let ipat = Option.map mk_intro_pattern ipat in + let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in Tactics.forward true (Some tac) ipat c let letin_pat_tac ev ipat na c cl = diff --git a/src/tac2types.mli b/src/tac2types.mli index 1cacbefc88..a7b0ceed6e 100644 --- a/src/tac2types.mli +++ b/src/tac2types.mli @@ -15,6 +15,8 @@ open Proofview type evars_flag = bool type advanced_flag = bool +type 'a thunk = (unit, 'a) Tac2ffi.fun1 + type quantified_hypothesis = Misctypes.quantified_hypothesis = | AnonHyp of int | NamedHyp of Id.t @@ -47,7 +49,7 @@ and intro_pattern_action = | IntroWildcard | IntroOrAndPattern of or_and_intro_pattern | IntroInjection of intro_pattern list -| IntroApplyOn of EConstr.t tactic * intro_pattern +| IntroApplyOn of EConstr.t thunk * intro_pattern | IntroRewrite of bool and or_and_intro_pattern = | IntroOrPattern of intro_pattern list list @@ -86,5 +88,5 @@ type rewriting = constr_with_bindings tactic type assertion = -| AssertType of intro_pattern option * constr * unit tactic option +| AssertType of intro_pattern option * constr * unit thunk option | AssertValue of Id.t * constr -- cgit v1.2.3 From 78832226d6e472a6592dfffe91242613ec76841c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 1 Oct 2017 20:33:26 +0200 Subject: Abstracting away the implementation of value representations. --- src/tac2core.ml | 6 +++--- src/tac2ffi.ml | 3 +++ src/tac2ffi.mli | 10 ++++------ src/tac2print.ml | 2 +- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 9e3cefc6f5..1756e44f76 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -157,15 +157,15 @@ let define_primitive name arity f = let define0 name f = define_primitive name arity_one (fun _ -> f) let define1 name r0 f = define_primitive name arity_one begin fun x -> - f (r0.Value.r_to x) + f (Value.repr_to r0 x) end let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> - f (r0.Value.r_to x) (r1.Value.r_to y) + f (Value.repr_to r0 x) (Value.repr_to r1 y) end let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> - f (r0.Value.r_to x) (r1.Value.r_to y) (r2.Value.r_to z) + f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) end (** Printing *) diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 923a29e5c5..c612cb85a5 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -76,6 +76,9 @@ type 'a repr = { r_id : bool; } +let repr_of r x = r.r_of x +let repr_to r x = r.r_to x + (** Dynamic tags *) let val_exn = Val.create "exn" diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index cb6d5a1e49..9f200b439d 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -49,12 +49,10 @@ end (** {5 Ltac2 FFI} *) -type 'a repr = { - r_of : 'a -> valexpr; - r_to : valexpr -> 'a; - r_id : bool; - (** True if the functions above are physical identities. *) -} +type 'a repr + +val repr_of : 'a repr -> 'a -> valexpr +val repr_to : 'a repr -> valexpr -> 'a (** These functions allow to convert back and forth between OCaml and Ltac2 data representation. The [to_*] functions raise an anomaly whenever the data diff --git a/src/tac2print.ml b/src/tac2print.ml index 45360a61f4..018346ad6a 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -401,7 +401,7 @@ let rec pr_valexpr env sigma v t = match kind t with end | GTypArrow _ -> str "" | GTypRef (Tuple _, tl) -> - let blk = Array.to_list (snd (block.r_to v)) in + let blk = Array.to_list (snd (to_block v)) in if List.length blk == List.length tl then let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") -- cgit v1.2.3 From f0fb8686377815978556e7d554f27de6406d1fed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 7 Oct 2017 22:46:45 +0200 Subject: Fix coq/ltac2#30: Compilation broken since -safe-string PR got merged. --- src/tac2core.ml | 5 +++-- src/tac2ffi.mli | 6 +++--- src/tac2print.ml | 2 +- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1756e44f76..1489c50c13 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -234,11 +234,11 @@ let () = define2 "ident_equal" ident ident begin fun id1 id2 -> end let () = define1 "ident_to_string" ident begin fun id -> - return (Value.of_string (Id.to_string id)) + return (Value.of_string (Bytes.of_string (Id.to_string id))) end let () = define1 "ident_of_string" string begin fun s -> - let id = try Some (Id.of_string s) with _ -> None in + let id = try Some (Id.of_string (Bytes.to_string s)) with _ -> None in return (Value.of_option Value.of_ident id) end @@ -714,6 +714,7 @@ let () = define2 "abstract" (option ident) closure begin fun id f -> end let () = define2 "time" (option string) closure begin fun s f -> + let s = Option.map Bytes.to_string s in Proofview.tclTIME s (thaw f) end diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 9f200b439d..9c3b512036 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -74,9 +74,9 @@ val of_char : char -> valexpr val to_char : valexpr -> char val char : char repr -val of_string : string -> valexpr -val to_string : valexpr -> string -val string : string repr +val of_string : Bytes.t -> valexpr +val to_string : valexpr -> Bytes.t +val string : Bytes.t repr val of_list : ('a -> valexpr) -> 'a list -> valexpr val to_list : (valexpr -> 'a) -> valexpr -> 'a list diff --git a/src/tac2print.ml b/src/tac2print.ml index 018346ad6a..5f34b54ee6 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -426,7 +426,7 @@ end let () = register_init "string" begin fun s -> let s = to_string s in - Pp.quote (Pp.str s) + Pp.quote (Pp.str (Bytes.to_string s)) end let () = register_init "ident" begin fun id -> -- cgit v1.2.3 From 533b5ee5a3c5dd4c2e54d85dba9485722bb21db1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 7 Oct 2017 22:47:48 +0200 Subject: Remove unused warnings. --- src/tac2core.ml | 4 ---- src/tac2entries.ml | 1 - src/tac2env.ml | 2 -- src/tac2env.mli | 1 - src/tac2expr.mli | 1 - src/tac2ffi.ml | 1 - src/tac2intern.ml | 6 ------ src/tac2interp.ml | 1 - src/tac2print.ml | 1 - src/tac2quote.ml | 2 -- src/tac2quote.mli | 1 - src/tac2stdlib.ml | 2 -- src/tac2tactics.ml | 2 -- 13 files changed, 25 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1489c50c13..0304286639 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -6,13 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open CSig open Util open Pp open Names open Genarg open Tac2env -open Tac2dyn open Tac2expr open Tac2entries.Pltac open Proofview.Notations @@ -105,7 +103,6 @@ let err_matchfailure = let thaw f = Tac2ffi.apply f [v_unit] let fatal_flag : unit Exninfo.t = Exninfo.make () -let fatal_info = Exninfo.add Exninfo.null fatal_flag () let set_bt info = if !Tac2interp.print_ltac2_backtrace then @@ -397,7 +394,6 @@ let () = define1 "constr_kind" constr begin fun c -> end let () = define1 "constr_make" valexpr begin fun knd -> - let open Constr in let c = match Tac2ffi.to_block knd with | (0, [|n|]) -> let n = Value.to_int n in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index cd4b701ca7..f24c409ad7 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -16,7 +16,6 @@ open Nametab open Tac2expr open Tac2print open Tac2intern -open Vernacexpr (** Grammar entries *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 0aa2da77ae..2f1124c156 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -6,11 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open CErrors open Util open Names open Libnames -open Tac2dyn open Tac2expr open Tac2ffi diff --git a/src/tac2env.mli b/src/tac2env.mli index b82923765d..022c518143 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -10,7 +10,6 @@ open Genarg open Names open Libnames open Nametab -open Tac2dyn open Tac2expr open Tac2ffi diff --git a/src/tac2expr.mli b/src/tac2expr.mli index c787870c65..e57b0ba3ef 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -7,7 +7,6 @@ (************************************************************************) open Loc -open Genarg open Names open Libnames diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index c612cb85a5..19d4259b55 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -9,7 +9,6 @@ open Util open Names open Globnames -open Genarg open Tac2dyn open Tac2expr open Proofview.Notations diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 0efd9a3005..7b35cd55aa 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -8,7 +8,6 @@ open Pp open Util -open Genarg open CErrors open Names open Libnames @@ -23,13 +22,8 @@ let coq_type n = KerName.make2 Tac2env.coq_prefix (Label.make n) let t_int = coq_type "int" let t_string = coq_type "string" -let t_array = coq_type "array" -let t_list = coq_type "list" let t_constr = coq_type "constr" -let c_nil = GTacCst (Other t_list, 0, []) -let c_cons e el = GTacCst (Other t_list, 0, [e; el]) - (** Union find *) module UF : diff --git a/src/tac2interp.ml b/src/tac2interp.ml index db30f52772..6f158ac66e 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -9,7 +9,6 @@ open Util open Pp open CErrors -open Genarg open Names open Proofview.Notations open Tac2expr diff --git a/src/tac2print.ml b/src/tac2print.ml index 5f34b54ee6..8e4947e332 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -8,7 +8,6 @@ open Util open Pp -open Genarg open Names open Tac2expr open Tac2env diff --git a/src/tac2quote.ml b/src/tac2quote.ml index e89f37f2ba..e967067161 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -40,8 +40,6 @@ let pattern_core n = kername pattern_prefix n let global_ref ?loc kn = Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant kn)) -let dummy_loc = Loc.make_loc (-1, -1) - let constructor ?loc kn args = let cst = Loc.tag ?loc @@ CTacCst (AbsKn (Other kn)) in if List.is_empty args then cst diff --git a/src/tac2quote.mli b/src/tac2quote.mli index b9cae23e63..148e6818dd 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Loc open Names open Tac2dyn diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 2828bbc53f..99fa0370e1 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -7,12 +7,10 @@ (************************************************************************) open Names -open Globnames open Genredexpr open Tac2expr open Tac2ffi open Tac2types -open Tac2tactics open Proofview.Notations module Value = Tac2ffi diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 0b25ebb378..b496f5046f 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -10,10 +10,8 @@ open Pp open Util open Names open Globnames -open Misctypes open Tac2types open Genredexpr -open Proofview open Proofview.Notations let return = Proofview.tclUNIT -- cgit v1.2.3 From 0b26bfc8e068e1e95eeea9db0c3bda7436ac8338 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 29 Sep 2017 17:57:25 +0200 Subject: Implementing the Constr.in_context function. --- src/tac2core.ml | 32 ++++++++++++++++++++++++++++++++ theories/Constr.v | 5 +++++ 2 files changed, 37 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index 0304286639..468fddaddf 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -494,6 +494,38 @@ let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> return (Value.of_constr ans) end +let () = define3 "constr_in_context" ident constr closure begin fun id t c -> + Proofview.Goal.goals >>= function + | [gl] -> + gl >>= fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let has_var = + try + let _ = Environ.lookup_named_val id (Environ.named_context_val env) in + true + with Not_found -> false + in + if has_var then + Tacticals.New.tclZEROMSG (str "Variable already exists") + else + let open Context.Named.Declaration in + let nenv = EConstr.push_named (LocalAssum (id, t)) env in + let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in + let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS [evk] >>= fun () -> + thaw c >>= fun _ -> + Proofview.Unsafe.tclSETGOALS [Proofview.Goal.goal (Proofview.Goal.assume gl)] >>= fun () -> + let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in + let args = Array.of_list (EConstr.mkRel 1 :: args) in + let ans = EConstr.mkEvar (evk, args) in + let ans = EConstr.mkLambda (Name id, t, ans) in + return (Value.of_constr ans) + | _ -> + throw err_notfocussed +end + (** Patterns *) let () = define2 "pattern_matches" pattern constr begin fun pat c -> diff --git a/theories/Constr.v b/theories/Constr.v index 3e67a486cf..072c613920 100644 --- a/theories/Constr.v +++ b/theories/Constr.v @@ -58,3 +58,8 @@ Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "con [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) End Unsafe. + +Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". +(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a + focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is + the proof built by the tactic. *) -- cgit v1.2.3 From d4172d2c7a48d932b42248fe57c6c2a87ac57e30 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 25 Oct 2017 12:13:27 +0200 Subject: Stubs for goal matching: quotation and matching function. --- _CoqProject | 2 + src/g_ltac2.ml4 | 33 +++++-- src/ltac2_plugin.mlpack | 1 + src/tac2core.ml | 26 ++++++ src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2ffi.ml | 10 +++ src/tac2ffi.mli | 2 + src/tac2match.ml | 232 ++++++++++++++++++++++++++++++++++++++++++++++++ src/tac2match.mli | 33 +++++++ src/tac2qexpr.mli | 21 ++++- src/tac2quote.ml | 150 ++++++++++++++++++++++--------- src/tac2quote.mli | 2 + theories/Notations.v | 60 ++++++------- theories/Pattern.v | 29 +++++- 15 files changed, 515 insertions(+), 88 deletions(-) create mode 100644 src/tac2match.ml create mode 100644 src/tac2match.mli diff --git a/_CoqProject b/_CoqProject index 43e9b76991..df8cb00b76 100644 --- a/_CoqProject +++ b/_CoqProject @@ -21,6 +21,8 @@ src/tac2ffi.mli src/tac2qexpr.mli src/tac2quote.ml src/tac2quote.mli +src/tac2match.ml +src/tac2match.mli src/tac2core.ml src/tac2core.mli src/tac2tactics.ml diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index c92a242637..be6c2de5a9 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -376,7 +376,7 @@ GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching - q_hintdb q_move_location q_pose q_assert; + q_goal_matching q_hintdb q_move_location q_pose q_assert; anti: [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] ; @@ -682,14 +682,12 @@ GEXTEND Gram ; match_pattern: [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> (Some id, pat) - | pat = Constr.lconstr_pattern -> (None, pat) ] ] + "["; pat = Constr.lconstr_pattern; "]" -> Loc.tag ~loc:!@loc @@ QConstrMatchContext (id, pat) + | pat = Constr.lconstr_pattern -> Loc.tag ~loc:!@loc @@ QConstrMatchPattern pat ] ] ; match_rule: [ [ mp = match_pattern; "=>"; tac = tac2expr -> - match mp with - | None, pat -> Loc.tag ~loc:!@loc @@ QConstrMatchPattern (pat, tac) - | Some oid, pat -> Loc.tag ~loc:!@loc @@ QConstrMatchContext (oid, pat, tac) + Loc.tag ~loc:!@loc @@ (mp, tac) ] ] ; match_list: @@ -699,6 +697,29 @@ GEXTEND Gram q_constr_matching: [ [ m = match_list -> m ] ] ; + gmatch_hyp_pattern: + [ [ na = Prim.name; ":"; pat = match_pattern -> (na, pat) ] ] + ; + gmatch_pattern: + [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> + Loc.tag ~loc:!@loc @@ { + q_goal_match_concl = p; + q_goal_match_hyps = hl; + } + ] ] + ; + gmatch_rule: + [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + Loc.tag ~loc:!@loc @@ (mp, tac) + ] ] + ; + gmatch_list: + [ [ mrl = LIST1 gmatch_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl + | "|"; mrl = LIST1 gmatch_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl ] ] + ; + q_goal_matching: + [ [ m = gmatch_list -> m ] ] + ; move_location: [ [ "at"; IDENT "top" -> Loc.tag ~loc:!@loc @@ QMoveFirst | "at"; IDENT "bottom" -> Loc.tag ~loc:!@loc @@ QMoveLast diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index a2237f4d26..40b91e4b53 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -6,6 +6,7 @@ Tac2intern Tac2interp Tac2entries Tac2quote +Tac2match Tac2core Tac2tactics Tac2stdlib diff --git a/src/tac2core.ml b/src/tac2core.ml index 468fddaddf..c4502f8eae 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -528,6 +528,12 @@ end (** Patterns *) +let empty_context = EConstr.mkMeta Constr_matching.special_meta + +let () = define0 "pattern_empty_context" begin + return (Value.of_constr empty_context) +end + let () = define2 "pattern_matches" pattern constr begin fun pat c -> pf_apply begin fun env sigma -> let ans = @@ -592,6 +598,25 @@ let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c - end end +let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bool pattern) begin fun rev hp cp -> + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let mk_pattern (b, pat) = if b then Tac2match.MatchContext pat else Tac2match.MatchPattern pat in + let r = (List.map mk_pattern hp, mk_pattern cp) in + Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> + let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in + let hids = Value.of_array Value.of_ident (Array.map_of_list fst hyps) in + let hctx = Value.of_array of_ctxopt (Array.map_of_list snd hyps) in + let subs = Value.of_array Value.of_constr (Array.map_of_list snd (Id.Map.bindings subst)) in + let cctx = of_ctxopt ctx in + let ans = Value.of_tuple [| hids; hctx; subs; cctx |] in + Proofview.tclUNIT ans + end +end + let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> let ctx = EConstr.Unsafe.to_constr ctx in let c = EConstr.Unsafe.to_constr c in @@ -1146,6 +1171,7 @@ let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_locati let () = add_expr_scope "pose" q_pose Tac2quote.of_pose let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching +let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index f24c409ad7..04bf21f656 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -37,6 +37,7 @@ let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" let q_reference = Pcoq.Gram.entry_create "tactic:q_reference" let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" +let q_goal_matching = Pcoq.Gram.entry_create "tactic:q_goal_matching" let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" let q_pose = Pcoq.Gram.entry_create "tactic:q_pose" diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 7bd512651c..b2a2dd4846 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -77,6 +77,7 @@ val q_occurrences : occurrences Pcoq.Gram.entry val q_reference : Libnames.reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry +val q_goal_matching : goal_matching Pcoq.Gram.entry val q_hintdb : hintdb Pcoq.Gram.entry val q_move_location : move_location Pcoq.Gram.entry val q_pose : pose Pcoq.Gram.entry diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index 19d4259b55..b0c56cdf45 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -272,6 +272,16 @@ let to_tuple = function | ValBlk (0, cl) -> cl | _ -> assert false +let of_pair f g (x, y) = ValBlk (0, [|f x; g y|]) +let to_pair f g = function +| ValBlk (0, [|x; y|]) -> (f x, g y) +| _ -> assert false +let pair r0 r1 = { + r_of = (fun p -> of_pair r0.r_of r1.r_of p); + r_to = (fun p -> to_pair r0.r_to r1.r_to p); + r_id = false; +} + let of_array f vl = ValBlk (0, Array.map f vl) let to_array f = function | ValBlk (0, vl) -> Array.map f vl diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 9c3b512036..6d4867a453 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -109,6 +109,8 @@ val array : 'a repr -> 'a array repr val of_tuple : valexpr array -> valexpr val to_tuple : valexpr -> valexpr array +val pair : 'a repr -> 'b repr -> ('a * 'b) repr + val of_option : ('a -> valexpr) -> 'a option -> valexpr val to_option : (valexpr -> 'a) -> valexpr -> 'a option val option : 'a repr -> 'a option repr diff --git a/src/tac2match.ml b/src/tac2match.ml new file mode 100644 index 0000000000..7a22e91b6b --- /dev/null +++ b/src/tac2match.ml @@ -0,0 +1,232 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + Id.Map.merge merge s1 s2 + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> result -> 'r tac) -> result -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + } in + let eval x ctx = Proofview.tclUNIT (x, ctx) in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + let put_subst subst : unit m = + let s = { subst } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** {6 Pattern-matching} *) + + let pattern_match_term pat term = + match pat with + | MatchPattern p -> + begin + try + put_subst (Constr_matching.matches E.env E.sigma p term) <*> + return None + with Constr_matching.PatternMatchingFailure -> fail + end + | MatchContext p -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub = (_, subst); m_ctx }, s) -> + let nctx = { subst } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | Some nctx -> Proofview.tclOR (k (Some m_ctx) nctx) (fun e -> (map s e).stream k ctx) + } + in + map (Constr_matching.match_appsubterm E.env E.sigma p term) imatching_error + + let hyp_match_type pat hyps = + pick hyps >>= fun decl -> + let id = NamedDecl.get_id decl in + pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> + return (id, ctx) + + let hyp_match_body_and_type bodypat typepat hyps = + pick hyps >>= function + | LocalDef (id,body,hyp) -> + pattern_match_term bodypat body >>= fun ctx_body -> + pattern_match_term typepat hyp >>= fun ctx_typ -> + return (id, ctx_body, ctx_typ) + | LocalAssum (id,hyp) -> fail + + let hyp_match pat hyps = + match pat with + | typepat -> + hyp_match_type typepat hyps +(* | Def ((_,hypname),bodypat,typepat) -> *) +(* hyp_match_body_and_type hypname bodypat typepat hyps *) + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps accu = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun (matched_hyp, hyp_ctx) -> + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in + let hyps = CList.remove_first select_matched_hyp hyps in + hyp_pattern_list_match pats hyps ((matched_hyp, hyp_ctx) :: accu) + | [] -> return accu + + let rule_match_goal hyps concl = function + | (hyppats,conclpat) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term conclpat concl >>= fun ctx_concl -> + hyp_pattern_list_match hyppats hyps [] >>= fun hyps -> + return (hyps, ctx_concl) + +end + +let match_goal env sigma concl ~rev rule = + let open Proofview.Notations in + let hyps = EConstr.named_context env in + let hyps = if rev then List.rev hyps else hyps in + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.rule_match_goal hyps concl rule) >>= fun ((hyps, ctx_concl), subst) -> + Proofview.tclUNIT (hyps, ctx_concl, subst.subst) diff --git a/src/tac2match.mli b/src/tac2match.mli new file mode 100644 index 0000000000..cf64542f40 --- /dev/null +++ b/src/tac2match.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Evd.evar_map -> + constr -> + rev:bool -> + match_rule -> + ((Id.t * context option) list * (** List of hypotheses matching: name + context *) + context option * (** Context for conclusion *) + Pattern.patvar_map (** Pattern variable substitution *)) Proofview.tactic diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index cb43a980de..229cece7c4 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -118,14 +118,27 @@ type red_flag = red_flag_r located type strategy_flag = red_flag list located -type constr_match_branch_r = -| QConstrMatchPattern of Constrexpr.constr_expr * raw_tacexpr -| QConstrMatchContext of Id.t option * Constrexpr.constr_expr * raw_tacexpr +type constr_match_pattern_r = +| QConstrMatchPattern of Constrexpr.constr_expr +| QConstrMatchContext of Id.t option * Constrexpr.constr_expr -type constr_match_branch = constr_match_branch_r located +type constr_match_pattern = constr_match_pattern_r located + +type constr_match_branch = (constr_match_pattern * raw_tacexpr) located type constr_matching = constr_match_branch list located +type goal_match_pattern_r = { + q_goal_match_concl : constr_match_pattern; + q_goal_match_hyps : (Name.t located * constr_match_pattern) list; +} + +type goal_match_pattern = goal_match_pattern_r located + +type goal_match_branch = (goal_match_pattern * raw_tacexpr) located + +type goal_matching = goal_match_branch list located + type hintdb_r = | QHintAll | QHintDbs of Id.t located or_anti list diff --git a/src/tac2quote.ml b/src/tac2quote.ml index e967067161..9728c3af93 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -307,62 +307,126 @@ let of_hintdb (loc, hdb) = match hdb with | QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None | QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) +let check_pattern_id ?loc id = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) + let pattern_vars pat = let rec aux () accu pat = match pat.CAst.v with - | Constrexpr.CPatVar id -> Id.Set.add id accu - | Constrexpr.CEvar (id, []) -> Id.Set.add id accu + | Constrexpr.CPatVar id + | Constrexpr.CEvar (id, []) -> + let () = check_pattern_id ?loc:pat.CAst.loc id in + Id.Set.add id accu | _ -> Topconstr.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat in aux () Id.Set.empty pat -let of_constr_matching (loc, m) = - let check_id loc id = - if Tac2env.is_constructor (Libnames.qualid_of_ident id) then - CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) - in - let abstract_vars loc pat tac = - let vars = pattern_vars pat in - let na, tac = - if Id.Set.is_empty vars then (Anonymous, tac) - else - (** Trick: in order not to shadow a variable nor to choose an arbitrary - name, we reuse one which is going to be shadowed by the matched - variables anyways. *) - let id0 = Id.Set.choose vars in - let build_bindings id (n, accu) = - let () = check_id loc id in - let get = global_ref ?loc (kername array_prefix "get") in - let args = [of_variable (loc, id0); of_int (loc, n)] in - let e = Loc.tag ?loc @@ CTacApp (get, args) in - let accu = (Loc.tag ?loc @@ CPatVar (Name id), None, e) :: accu in - (n + 1, accu) - in - let (_, bnd) = Id.Set.fold build_bindings vars (0, []) in - let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in - (Name id0, tac) - in - Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], tac) +let abstract_vars loc vars tac = + let get_name = function Name id -> Some id | Anonymous -> None in + let def = try Some (List.find_map get_name vars) with Not_found -> None in + let na, tac = match def with + | None -> (Anonymous, tac) + | Some id0 -> + (** Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) + let build_bindings (n, accu) na = match na with + | Anonymous -> (n + 1, accu) + | Name _ -> + let get = global_ref ?loc (kername array_prefix "get") in + let args = [of_variable (loc, id0); of_int (loc, n)] in + let e = Loc.tag ?loc @@ CTacApp (get, args) in + let accu = (Loc.tag ?loc @@ CPatVar na, None, e) :: accu in + (n + 1, accu) + in + let (_, bnd) = List.fold_left build_bindings (0, []) vars in + let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in + (Name id0, tac) in - let map (loc, p) = match p with - | QConstrMatchPattern (pat, tac) -> - let e = abstract_vars loc pat tac in - let pat = inj_wit ?loc wit_pattern pat in - constructor ?loc (pattern_core "ConstrMatchPattern") [pat; e] - | QConstrMatchContext (id, pat, tac) -> - let e = abstract_vars loc pat tac in - let na = match id with - | None -> Anonymous - | Some id -> - let () = check_id loc id in - Name id + Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], tac) + +let extract_name ?loc oid = match oid with +| None -> Anonymous +| Some id -> + let () = check_pattern_id ?loc id in + Name id + +(** For every branch in the matching, generate a corresponding term of type + [(match_kind * pattern * (context -> constr array -> 'a))] + where the function binds the names from the pattern to the contents of the + constr array. *) +let of_constr_matching (loc, m) = + let map (loc, ((ploc, pat), tac)) = + let (knd, pat, na) = match pat with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (knd, pat, Anonymous) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (knd, pat, na) in + let vars = pattern_vars pat in + (** Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let vars = List.map (fun id -> Name id) vars in + let e = abstract_vars loc vars tac in let e = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], e) in - let pat = inj_wit ?loc wit_pattern pat in - constructor ?loc (pattern_core "ConstrMatchContext") [pat; e] + let pat = inj_wit ?loc:ploc wit_pattern pat in + of_tuple [knd; pat; e] in of_list ?loc map m +let of_pattern p = + inj_wit ?loc:p.CAst.loc wit_pattern p + +(** From the patterns and the body of the branch, generate: + - a goal pattern: (constr_match list * constr_match) + - a branch function (ident array -> context array -> constr array -> context -> 'a) +*) +let of_goal_matching (loc, gm) = + let mk_pat (loc, p) = match p with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (Anonymous, pat, knd) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (na, pat, knd) + in + let mk_gpat (loc, p) = + let concl_pat = p.q_goal_match_concl in + let hyps_pats = p.q_goal_match_hyps in + let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in + let vars = pattern_vars concl_pat in + let map accu (na, pat) = + let (ctx, pat, knd) = mk_pat pat in + let vars = pattern_vars pat in + (Id.Set.union vars accu, (na, ctx, pat, knd)) + in + let (vars, hyps_pats) = List.fold_left_map map vars hyps_pats in + let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in + let concl = of_tuple [concl_knd; of_pattern concl_pat] in + let r = of_tuple [of_list ?loc map hyps_pats; concl] in + let hyps = List.map (fun ((_, na), _, _, _) -> na) hyps_pats in + let map (_, na, _, _) = na in + let hctx = List.map map hyps_pats in + (** Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let subst = List.map (fun id -> Name id) vars in + (r, hyps, hctx, subst, concl_ctx) + in + let map (loc, (pat, tac)) = + let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in + let tac = abstract_vars loc hyps tac in + let tac = abstract_vars loc hctx tac in + let tac = abstract_vars loc subst tac in + let tac = abstract_vars loc [cctx] tac in + of_tuple ?loc [pat; tac] + in + of_list ?loc map gm + let of_move_location (loc, mv) = match mv with | QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] | QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 148e6818dd..403d333f38 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -80,6 +80,8 @@ val of_assertion : assertion -> raw_tacexpr val of_constr_matching : constr_matching -> raw_tacexpr +val of_goal_matching : goal_matching -> raw_tacexpr + (** {5 Generic arguments} *) val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag diff --git a/theories/Notations.v b/theories/Notations.v index 91025ea964..8523c0f524 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -15,22 +15,20 @@ Ltac2 lazy_match0 t pats := let rec interp m := match m with | [] => Control.zero Match_failure | p :: m => - match p with - | Pattern.ConstrMatchPattern pat f => - Control.plus - (fun _ => - let bind := Pattern.matches_vect pat t in - fun _ => f bind - ) - (fun _ => interp m) - | Pattern.ConstrMatchContext pat f => - Control.plus - (fun _ => - let ((context, bind)) := Pattern.matches_subterm_vect pat t in - fun _ => f context bind - ) - (fun _ => interp m) - end + let next _ := interp m in + let ((knd, pat, f)) := p in + let p := match knd with + | Pattern.MatchPattern => + (fun _ => + let context := Pattern.empty_context () in + let bind := Pattern.matches_vect pat t in + fun _ => f context bind) + | Pattern.MatchContext => + (fun _ => + let ((context, bind)) := Pattern.matches_subterm_vect pat t in + fun _ => f context bind) + end in + Control.plus p next end in let ans := Control.once (fun () => interp pats) in ans (). @@ -42,22 +40,20 @@ Ltac2 multi_match0 t pats := let rec interp m := match m with | [] => Control.zero Match_failure | p :: m => - match p with - | Pattern.ConstrMatchPattern pat f => - Control.plus - (fun _ => - let bind := Pattern.matches_vect pat t in - f bind - ) - (fun _ => interp m) - | Pattern.ConstrMatchContext pat f => - Control.plus - (fun _ => - let ((context, bind)) := Pattern.matches_subterm_vect pat t in - f context bind - ) - (fun _ => interp m) - end + let next _ := interp m in + let ((knd, pat, f)) := p in + let p := match knd with + | Pattern.MatchPattern => + (fun _ => + let context := Pattern.empty_context () in + let bind := Pattern.matches_vect pat t in + f context bind) + | Pattern.MatchContext => + (fun _ => + let ((context, bind)) := Pattern.matches_subterm_vect pat t in + f context bind) + end in + Control.plus p next end in interp pats. diff --git a/theories/Pattern.v b/theories/Pattern.v index a672ad0fe7..fb450d9dfa 100644 --- a/theories/Pattern.v +++ b/theories/Pattern.v @@ -12,11 +12,15 @@ Ltac2 Type t := pattern. Ltac2 Type context. -Ltac2 Type 'a constr_match := [ -| ConstrMatchPattern (pattern, constr array -> 'a) -| ConstrMatchContext (pattern, context -> constr array -> 'a) +Ltac2 Type match_kind := [ +| MatchPattern +| MatchContext ]. +Ltac2 @ external empty_context : unit -> context := + "ltac2" "pattern_empty_context". +(** A trivial context only made of the hole. *) + Ltac2 @ external matches : t -> constr -> (ident * constr) list := "ltac2" "pattern_matches". (** If the term matches the pattern, returns the bound variables. If it doesn't, @@ -38,6 +42,25 @@ Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := "ltac2" "pattern_matches_subterm_vect". (** Internal version of [matches_subterms] that does not return the identifiers. *) +Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t) -> + ident array * context array * constr array * context := + "ltac2" "pattern_matches_goal". +(** Given a list of patterns [hpats] for hypotheses and one pattern [cpat] for the + conclusion, [matches_goal rev hpats cpat] produces (a stream of) tuples of: + - An array of idents, whose size is the length of [hpats], corresponding to the + name of matched hypotheses. + - An array of contexts, whose size is the length of [hpats], corresponding to + the contexts matched for every hypothesis pattern. In case the match kind of + a hypothesis was [MatchPattern], the corresponding context is ensured to be empty. + - An array of terms, whose size is the total number of pattern variables without + duplicates. Terms are ordered by identifier order, e.g. ?a comes before ?b. + - A context corresponding to the conclusion, which is ensured to be empty if + the kind of [cpat] was [MatchPattern]. + This produces a backtracking stream of results containing all the possible + result combinations. The order of considered hypotheses is reversed if [rev] + is true. +*) + Ltac2 @ external instantiate : context -> constr -> constr := "ltac2" "pattern_instantiate". (** Fill the hole of a context with the given term. *) -- cgit v1.2.3 From 937b4a9ab459696fccd613e52601411c4f1dadef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 11:50:02 +0200 Subject: Fix relative meaning of Pattern vs. Context in match goal. --- src/tac2core.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index c4502f8eae..1cfb34c249 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -604,7 +604,7 @@ let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bo let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in - let mk_pattern (b, pat) = if b then Tac2match.MatchContext pat else Tac2match.MatchPattern pat in + let mk_pattern (b, pat) = if b then Tac2match.MatchPattern pat else Tac2match.MatchContext pat in let r = (List.map mk_pattern hp, mk_pattern cp) in Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in -- cgit v1.2.3 From bd462a21974caca5928ae172a7740a1f96ae0ae4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 14:48:34 +0200 Subject: Fix goal_matching quotation. --- src/tac2quote.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 9728c3af93..1275c939c5 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -419,10 +419,10 @@ let of_goal_matching (loc, gm) = in let map (loc, (pat, tac)) = let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in - let tac = abstract_vars loc hyps tac in - let tac = abstract_vars loc hctx tac in + let tac = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar cctx, None], tac) in let tac = abstract_vars loc subst tac in - let tac = abstract_vars loc [cctx] tac in + let tac = abstract_vars loc hctx tac in + let tac = abstract_vars loc hyps tac in of_tuple ?loc [pat; tac] in of_list ?loc map gm -- cgit v1.2.3 From e0fd7c668bc284924c63a1f0a0e36fb4856c49e1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 16:04:00 +0200 Subject: Adding a command to evaluate Ltac2 expressions. --- doc/ltac2.md | 14 ++++++++++++++ src/g_ltac2.ml4 | 9 +++++++-- src/tac2entries.ml | 31 +++++++++++++++++++++++++++++++ src/tac2expr.mli | 2 ++ 4 files changed, 54 insertions(+), 2 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index d7c8719a14..6cbe0988d0 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -727,6 +727,20 @@ foo 0 ↦ (fun x => x ()) (fun _ => 0) Note that abbreviations are not typechecked at all, and may result in typing errors after expansion. +# Evaluation + +Ltac2 features a toplevel loop that can be used to evaluate expressions. + +``` +VERNAC ::= +| "Ltac2" "Eval" TERM +``` + +This command evaluates the term in the current proof if there is one, or in the +global environment otherwise, and displays the resulting value to the user +together with its type. This function is pure in the sense that it does not +modify the state of the proof, and in particular all side-effects are discarded. + # Debug When the option `Ltac2 Backtrace` is set, toplevel failures will be printed with diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index be6c2de5a9..a979b1e9b8 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -88,6 +88,7 @@ let tac2def_typ = Gram.entry_create "tactic:tac2def_typ" let tac2def_ext = Gram.entry_create "tactic:tac2def_ext" let tac2def_syn = Gram.entry_create "tactic:tac2def_syn" let tac2def_mut = Gram.entry_create "tactic:tac2def_mut" +let tac2def_run = Gram.entry_create "tactic:tac2def_run" let tac2mode = Gram.entry_create "vernac:ltac2_command" (** FUCK YOU API *) @@ -109,7 +110,7 @@ let pattern_of_qualid ?loc id = GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut; + tac2def_mut tac2def_run; tac2pat: [ "1" LEFTA [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> @@ -273,6 +274,9 @@ GEXTEND Gram tac2def_mut: [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> StrMut (qid, e) ] ] ; + tac2def_run: + [ [ "Eval"; e = tac2expr -> StrRun e ] ] + ; tac2typ_knd: [ [ t = tac2type -> CTydDef (Some t) | "["; ".."; "]" -> CTydOpn @@ -801,11 +805,12 @@ PRINTED BY pr_ltac2entry | [ tac2def_ext(e) ] -> [ e ] | [ tac2def_syn(e) ] -> [ e ] | [ tac2def_mut(e) ] -> [ e ] +| [ tac2def_run(e) ] -> [ e ] END let classify_ltac2 = function | StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow -| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ -> Vernac_classifier.classify_as_sideeff +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernac_classifier.classify_as_sideeff VERNAC COMMAND EXTEND VernacDeclareTactic2Definition | [ "Ltac2" ltac2_entry(e) ] => [ classify_ltac2 e ] -> [ diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 04bf21f656..b803278929 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -739,6 +739,36 @@ let register_redefinition ?(local = false) (loc, qid) e = } in Lib.add_anonymous_leaf (inTac2Redefinition def) +let perform_eval e = + let open Proofview.Notations in + let env = Global.env () in + let (e, ty) = Tac2intern.intern ~strict:false e in + let v = Tac2interp.interp Tac2interp.empty_environment e in + let selector, proof = + try + Proof_bullet.get_default_goal_selector (), + Proof_global.give_me_the_proof () + with Proof_global.NoCurrentProof -> + let sigma = Evd.from_env env in + Vernacexpr.SelectAll, Proof.start sigma [] + in + let v = match selector with + | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i v + | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l v + | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id v + | Vernacexpr.SelectAll -> v + in + (** HACK: the API doesn't allow to return a value *) + let ans = ref None in + let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in + let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in + let sigma = Proof.in_proof proof (fun sigma -> sigma) in + let ans = match !ans with None -> assert false | Some r -> r in + let name = int_name () in + Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) + ++ spc () ++ str "=" ++ spc () ++ + Tac2print.pr_valexpr env sigma ans (snd ty)) + (** Toplevel entries *) let register_struct ?local str = match str with @@ -747,6 +777,7 @@ let register_struct ?local str = match str with | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e | StrMut (qid, e) -> register_redefinition ?local qid e +| StrRun e -> perform_eval e (** Toplevel exception *) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index e57b0ba3ef..89152dffe7 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -168,6 +168,8 @@ type strexpr = (** Syntactic extensions *) | StrMut of qualid located * raw_tacexpr (** Redefinition of mutable globals *) +| StrRun of raw_tacexpr + (** Toplevel evaluation of an expression *) (** {5 Dynamic semantics} *) -- cgit v1.2.3 From a7c83429db05866dfc9613fc4a488d62d31386fc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 18:42:02 +0200 Subject: Adding a notation for match goal. --- tests/matching.v | 25 +++++++++++++++++ theories/Notations.v | 71 +++++++++++++++------------------------------- theories/Pattern.v | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 127 insertions(+), 48 deletions(-) diff --git a/tests/matching.v b/tests/matching.v index f43e0121ef..6bc5706da7 100644 --- a/tests/matching.v +++ b/tests/matching.v @@ -1,5 +1,12 @@ Require Import Ltac2.Ltac2 Ltac2.Notations. +Ltac2 Type exn ::= [ Nope ]. + +Ltac2 check_id id id' := match Ident.equal id id' with +| true => () +| false => Control.throw Nope +end. + Goal True -> False. Proof. Fail @@ -25,3 +32,21 @@ let f c := in match! '(nat -> bool) with context [?a] => f a end. Abort. + +Goal forall (i j : unit) (x y : nat) (b : bool), True. +Proof. +Fail match! goal with +| [ h : ?t, h' : ?t |- _ ] => () +end. +intros i j x y b. +match! goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @x; + check_id h' @y +end. +match! reverse goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @j; + check_id h' @i +end. +Abort. diff --git a/theories/Notations.v b/theories/Notations.v index 8523c0f524..48f3ca0587 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -11,59 +11,34 @@ Require Ltac2.Control Ltac2.Pattern Ltac2.Array Ltac2.Int Ltac2.Std. (** Constr matching *) -Ltac2 lazy_match0 t pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let ((knd, pat, f)) := p in - let p := match knd with - | Pattern.MatchPattern => - (fun _ => - let context := Pattern.empty_context () in - let bind := Pattern.matches_vect pat t in - fun _ => f context bind) - | Pattern.MatchContext => - (fun _ => - let ((context, bind)) := Pattern.matches_subterm_vect pat t in - fun _ => f context bind) - end in - Control.plus p next - end in - let ans := Control.once (fun () => interp pats) in - ans (). - Ltac2 Notation "lazy_match!" t(tactic(6)) "with" m(constr_matching) "end" := - lazy_match0 t m. - -Ltac2 multi_match0 t pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let ((knd, pat, f)) := p in - let p := match knd with - | Pattern.MatchPattern => - (fun _ => - let context := Pattern.empty_context () in - let bind := Pattern.matches_vect pat t in - f context bind) - | Pattern.MatchContext => - (fun _ => - let ((context, bind)) := Pattern.matches_subterm_vect pat t in - f context bind) - end in - Control.plus p next - end in - interp pats. + Pattern.lazy_match0 t m. Ltac2 Notation "multi_match!" t(tactic(6)) "with" m(constr_matching) "end" := - multi_match0 t m. - -Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). + Pattern.multi_match0 t m. Ltac2 Notation "match!" t(tactic(6)) "with" m(constr_matching) "end" := - one_match0 t m. + Pattern.one_match0 t m. + +(** Goal matching *) + +Ltac2 Notation "lazy_match!" "goal" "with" m(goal_matching) "end" := + Pattern.lazy_goal_match0 false m. + +Ltac2 Notation "multi_match!" "goal" "with" m(goal_matching) "end" := + Pattern.multi_goal_match0 false m. + +Ltac2 Notation "match!" "goal" "with" m(goal_matching) "end" := + Pattern.one_goal_match0 false m. + +Ltac2 Notation "lazy_match!" "reverse" "goal" "with" m(goal_matching) "end" := + Pattern.lazy_goal_match0 true m. + +Ltac2 Notation "multi_match!" "reverse" "goal" "with" m(goal_matching) "end" := + Pattern.multi_goal_match0 true m. + +Ltac2 Notation "match!" "reverse" "goal" "with" m(goal_matching) "end" := + Pattern.one_goal_match0 true m. (** Tacticals *) diff --git a/theories/Pattern.v b/theories/Pattern.v index fb450d9dfa..2c93918aee 100644 --- a/theories/Pattern.v +++ b/theories/Pattern.v @@ -7,6 +7,7 @@ (************************************************************************) Require Import Ltac2.Init. +Require Ltac2.Control. Ltac2 Type t := pattern. @@ -64,3 +65,81 @@ Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t Ltac2 @ external instantiate : context -> constr -> constr := "ltac2" "pattern_instantiate". (** Fill the hole of a context with the given term. *) + +(** Implementation of Ltac matching over terms and goals *) + +Ltac2 lazy_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let ((knd, pat, f)) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + fun _ => f context bind) + | MatchContext => + (fun _ => + let ((context, bind)) := matches_subterm_vect pat t in + fun _ => f context bind) + end in + Control.plus p next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let ((knd, pat, f)) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + f context bind) + | MatchContext => + (fun _ => + let ((context, bind)) := matches_subterm_vect pat t in + f context bind) + end in + Control.plus p next + end in + interp pats. + +Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). + +Ltac2 lazy_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let ((pat, f)) := p in + let ((phyps, pconcl)) := pat in + let cur _ := + let ((hids, hctx, subst, cctx)) := matches_goal rev phyps pconcl in + fun _ => f hids hctx subst cctx + in + Control.plus cur next + end in + interp pats (). + +Ltac2 multi_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let ((pat, f)) := p in + let ((phyps, pconcl)) := pat in + let cur _ := + let ((hids, hctx, subst, cctx)) := matches_goal rev phyps pconcl in + f hids hctx subst cctx + in + Control.plus cur next + end in + interp pats. + +Ltac2 one_goal_match0 rev pats := Control.once (fun _ => multi_goal_match0 rev pats). -- cgit v1.2.3 From 216c5f25cf41d68871149f21f83518ec0a4f1cc9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 19:26:31 +0200 Subject: Adding an OPAM package. --- Makefile | 16 +++++++--------- opam/descr | 1 + opam/opam | 17 +++++++++++++++++ 3 files changed, 25 insertions(+), 9 deletions(-) create mode 100644 opam/descr create mode 100644 opam/opam diff --git a/Makefile b/Makefile index d555fea236..e0e197650d 100644 --- a/Makefile +++ b/Makefile @@ -1,16 +1,14 @@ -all: Makefile.coq - $(MAKE) -f Makefile.coq +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif -install: all - $(MAKE) -f Makefile.coq install - -clean: Makefile.coq - $(MAKE) -f Makefile.coq clean - rm -f Makefile.coq +%: Makefile.coq Makefile.coq: _CoqProject - $(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq tests: all @$(MAKE) -C tests -s clean @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/opam/descr b/opam/descr new file mode 100644 index 0000000000..82463c4f45 --- /dev/null +++ b/opam/descr @@ -0,0 +1 @@ +A tactic language for Coq. diff --git a/opam/opam b/opam/opam new file mode 100644 index 0000000000..e461b97942 --- /dev/null +++ b/opam/opam @@ -0,0 +1,17 @@ +opam-version: "1.2" +name: "coq-ltac2" +version: "0.1" +maintainer: "Pierre-Marie Pédrot " +author: "Pierre-Marie Pédrot " +license: "LGPL 2.1" +homepage: "https://github.com/ppedrot/ltac2" +dev-repo: "https://github.com/ppedrot/ltac2.git" +bug-reports: "https://github.com/ppedrot/ltac2/issues" +build: [ + [make "COQBIN=\"\"" "-j%{jobs}%"] +] +install: [make "install"] +remove: [make "uninstall"] +depends: [ + "coq" { = "dev" } +] -- cgit v1.2.3 From e6efa6c12dd4701dc7fbdd31580bad0ad676e30d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 19:45:29 +0200 Subject: Better printers for toplevel values. --- src/tac2print.ml | 53 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 42 insertions(+), 11 deletions(-) diff --git a/src/tac2print.ml b/src/tac2print.ml index 8e4947e332..8f61686988 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -320,7 +320,7 @@ let pr_glbexpr_gen lvl c = let kn = change_kn_label tpe id in pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg in - let args = prlist_with_sep (fun () -> str ";" ++ spc ()) pr_arg args in + let args = prlist_with_sep pr_semicolon pr_arg args in hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") | (GTydDef _ | GTydOpn) -> assert false in @@ -374,7 +374,9 @@ let rec pr_valexpr env sigma v t = match kind t with | Some pr -> pr.val_printer env sigma v params | None -> let n, repr = Tac2env.interp_type kn in - match repr with + if KerName.equal kn t_list then + pr_val_list env sigma (to_list (fun v -> repr_to valexpr v) v) (List.hd params) + else match repr with | GTydDef None -> str "" | GTydDef (Some _) -> (** Shouldn't happen thanks to kind *) @@ -388,7 +390,7 @@ let rec pr_valexpr env sigma v t = match kind t with let knc = change_kn_label kn id in let args = pr_constrargs env sigma params args tpe in hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - | GTydRec rcd -> str "{}" + | GTydRec rcd -> str "{ TODO }" | GTydOpn -> begin match Tac2ffi.to_open v with | (knc, [||]) -> pr_constructor knc @@ -399,6 +401,7 @@ let rec pr_valexpr env sigma v t = match kind t with end end | GTypArrow _ -> str "" +| GTypRef (Tuple 0, []) -> str "()" | GTypRef (Tuple _, tl) -> let blk = Array.to_list (snd (to_block v)) in if List.length blk == List.length tl then @@ -414,31 +417,59 @@ and pr_constrargs env sigma params args tpe = let args = List.combine args tpe in prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args +and pr_val_list env sigma args tpe = + let pr v = pr_valexpr env sigma v tpe in + str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" + let register_init n f = let kn = KerName.make2 Tac2env.coq_prefix (Label.make n) in - register_val_printer kn { val_printer = fun _ _ v _ -> f v } + register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } -let () = register_init "int" begin fun n -> +let () = register_init "int" begin fun _ _ n -> let n = to_int n in Pp.int n end -let () = register_init "string" begin fun s -> +let () = register_init "string" begin fun _ _ s -> let s = to_string s in - Pp.quote (Pp.str (Bytes.to_string s)) + Pp.quote (str (Bytes.to_string s)) end -let () = register_init "ident" begin fun id -> +let () = register_init "ident" begin fun _ _ id -> let id = to_ident id in - Pp.str "@" ++ Id.print id + str "@" ++ Id.print id +end + +let () = register_init "constr" begin fun env sigma c -> + let c = to_constr c in + let c = try Printer.pr_leconstr_env env sigma c with _ -> str "..." in + str "constr:(" ++ c ++ str ")" +end + +let () = register_init "pattern" begin fun env sigma c -> + let c = to_pattern c in + let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in + str "pattern:(" ++ c ++ str ")" end -let () = register_init "message" begin fun pp -> +let () = register_init "message" begin fun _ _ pp -> str "message:(" ++ to_pp pp ++ str ")" end -let () = register_init "err" begin fun e -> +let () = register_init "err" begin fun _ _ e -> let e = to_ext val_exn e in let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in str "err:(" ++ CErrors.print_no_report e ++ str ")" end + +let () = + let kn = KerName.make2 Tac2env.coq_prefix (Label.make "array") in + let val_printer env sigma v arg = match arg with + | [arg] -> + let (_, v) = to_block v in + str "[|" ++ spc () ++ + prvect_with_sep pr_semicolon (fun a -> pr_valexpr env sigma a arg) v ++ + spc () ++ str "|]" + | _ -> assert false + in + register_val_printer kn { val_printer } -- cgit v1.2.3 From 71208e3eee6745ed8849bd03f66db638d9897516 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 27 Oct 2017 21:07:50 +0200 Subject: Adding documentation --- doc/ltac2.md | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 83 insertions(+), 8 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 6cbe0988d0..cd0d8f4325 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -268,7 +268,7 @@ not to compute the argument, and `foo` would have e.g. type `(unit -> unit) -> unit`. ``` -foo (fun () -> let x := 0 in bar) +foo (fun () => let x := 0 in bar) ``` ## Typing @@ -559,7 +559,7 @@ for it. - `&x` as an Ltac2 expression expands to `hyp @x`. - `&x` as a Coq constr expression expands to - `ltac2:(refine (fun () => hyp @x))`. + `ltac2:(Control.refine (fun () => hyp @x))`. #### Dynamic semantics @@ -587,14 +587,86 @@ Many standard tactics perform type-checking of their argument before going further. It is your duty to ensure that terms are well-typed when calling such tactics. Failure to do so will result in non-recoverable exceptions. -## Patterns +## Trivial Term Antiquotations -Terms can be used in pattern position just as any Ltac constructor. The accepted -syntax is a subset of the constr syntax in Ltac term position. It does not -allow antiquotations. +It is possible to refer to a variable of type `constr` in the Ltac2 environment +through a specific syntax consistent with the antiquotations presented in +the notation section. -Patterns quotations are typically used with the matching functions provided -in the `Pattern` module. +``` +COQCONSTR ::= +| "$" LIDENT +``` + +In a Coq term, writing `$x` is semantically equivalent to +`ltac2:(Control.refine (fun () => x))`, up to re-typechecking. It allows to +insert in a concise way an Ltac2 variable of type `constr` into a Coq term. + +## Match over terms + +Ltac2 features a construction similar to Ltac1 `match` over terms, although +in a less hard-wired way. + +``` +TERM ::= +| "match!" TERM "with" CONSTR-MATCHING* "end" +| "lazy_match!" TERM "with" CONSTR-MATCHING* "end" +| "multi_match!" TERM "with" CONSTR-MATCHING*"end" + +CONSTR-MATCHING := +| "|" CONSTR-PATTERN "=>" TERM + +CONSTR-PATTERN := +| CONSTR +| "context" LIDENT? "[" CONSTR "]" +``` + +This construction is not primitive and is desugared at parsing time into +calls to term matching functions from the `Pattern` module. Internally, it is +implemented thanks to a specific scope accepting the `CONSTR-MATCHING` syntax. + +Variables from the `CONSTR-PATTERN` are statically bound in the body of the branch, to +values of type `constr` for the variables from the `CONSTR` pattern and to a +value of type `Pattern.context` for the variable `LIDENT`. + +Note that contrarily to Ltac, only lowercase identifiers are valid as Ltac2 +bindings, so that there will be a syntax error if one of the bound variables +starts with an uppercase character. + +The semantics of this construction is otherwise the same as the corresponding +one from Ltac1, except that it requires the goal to be focussed. + +## Match over goals + +Similarly, there is a way to match over goals in an elegant way, which is +just a notation desugared at parsing time. + +``` +TERM ::= +| "match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" +| "lazy_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" +| "multi_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING*"end" + +GOAL-MATCHING := +| "|" "[" HYP-MATCHING* "|-" CONSTR-PATTERN "]" "=>" TERM + +HYP-MATCHING := +| LIDENT ":" CONSTR-PATTERN + +MATCH-ORDER := +| "reverse" +``` + +Variables from `HYP-MATCHING` and `CONSTR-PATTERN` are bound in the body of the +branch. Their types are: +- `constr` for pattern variables appearing in a `CONSTR` +- `Pattern.context` for variables binding a context +- `ident` for variables binding a hypothesis name. + +The same identifier caveat as in the case of matching over constr applies, and +this features has the same semantics as in Ltac1. In particular, a `reverse` +flag can be specified to match hypotheses from the more recently introduced to +the least recently introduced one. # Notations @@ -656,6 +728,9 @@ The following scopes are built-in. of returning a useless unit value. It is forbidden for the various subscopes to refer to the global entry using self of next. +A few other specific scopes exist to handle Ltac1-like syntax, but their use is +discouraged and they are thus not documented. + For now there is no way to declare new scopes from Ltac2 side, but this is planned. -- cgit v1.2.3 From f18502f32fb25b29cafe26340edbbcedd463c646 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Oct 2017 11:40:49 +0100 Subject: Fix compilation after merge of Ltac_pretype interface. --- src/tac2core.ml | 2 +- src/tac2interp.mli | 4 ++-- src/tac2match.ml | 2 +- src/tac2match.mli | 2 +- src/tac2tactics.ml | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1cfb34c249..9ef88a7d56 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -828,7 +828,7 @@ let open_constr_no_classes_flags () = let to_lvar ist = let open Glob_ops in let lfun = Tac2interp.set_env ist Id.Map.empty in - { empty_lvar with Glob_term.ltac_genargs = lfun } + { empty_lvar with Ltac_pretype.ltac_genargs = lfun } let gtypref kn = GTypRef (Other kn, []) diff --git a/src/tac2interp.mli b/src/tac2interp.mli index 211ac95196..21fdcd03af 100644 --- a/src/tac2interp.mli +++ b/src/tac2interp.mli @@ -20,8 +20,8 @@ val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic (** {5 Cross-boundary encodings} *) -val get_env : Glob_term.unbound_ltac_var_map -> environment -val set_env : environment -> Glob_term.unbound_ltac_var_map -> Glob_term.unbound_ltac_var_map +val get_env : Ltac_pretype.unbound_ltac_var_map -> environment +val set_env : environment -> Ltac_pretype.unbound_ltac_var_map -> Ltac_pretype.unbound_ltac_var_map (** {5 Exceptions} *) diff --git a/src/tac2match.ml b/src/tac2match.ml index 7a22e91b6b..fef5647725 100644 --- a/src/tac2match.ml +++ b/src/tac2match.ml @@ -14,7 +14,7 @@ module NamedDecl = Context.Named.Declaration type context = EConstr.t type result = { - subst : Pattern.patvar_map ; + subst : Ltac_pretype.patvar_map ; } type match_pattern = diff --git a/src/tac2match.mli b/src/tac2match.mli index cf64542f40..7cfa1ed25f 100644 --- a/src/tac2match.mli +++ b/src/tac2match.mli @@ -30,4 +30,4 @@ val match_goal: match_rule -> ((Id.t * context option) list * (** List of hypotheses matching: name + context *) context option * (** Context for conclusion *) - Pattern.patvar_map (** Pattern variable substitution *)) Proofview.tactic + Ltac_pretype.patvar_map (** Pattern variable substitution *)) Proofview.tactic diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index b496f5046f..c68fdf9a7a 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -343,7 +343,7 @@ let discriminate ev arg = let injection ev ipat arg = let arg = Option.map (fun arg -> None, arg) arg in let ipat = Option.map mk_intro_patterns ipat in - let tac ev arg = Equality.injClause ipat ev arg in + let tac ev arg = Equality.injClause None ipat ev arg in on_destruction_arg tac ev arg let autorewrite ~all by ids cl = -- cgit v1.2.3 From a997ee7d78d90740b15b58502a1dc5e587b43ee3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Oct 2017 15:53:55 +0100 Subject: Introducing the change tactic. --- src/g_ltac2.ml4 | 12 ++++++- src/tac2core.ml | 1 + src/tac2entries.ml | 1 + src/tac2entries.mli | 1 + src/tac2qexpr.mli | 6 ++++ src/tac2quote.ml | 98 ++++++++++++++++++++++++++++++---------------------- src/tac2quote.mli | 2 ++ src/tac2stdlib.ml | 7 ++++ src/tac2tactics.ml | 12 +++++++ src/tac2tactics.mli | 2 ++ tests/example2.v | 6 ++++ theories/Notations.v | 6 ++++ theories/Std.v | 2 ++ 13 files changed, 113 insertions(+), 43 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index a979b1e9b8..557e2bcb9a 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -378,7 +378,7 @@ let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) GEXTEND Gram GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag + q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag q_destruction_arg q_reference q_with_bindings q_constr_matching q_goal_matching q_hintdb q_move_location q_pose q_assert; anti: @@ -585,6 +585,16 @@ GEXTEND Gram q_induction_clause: [ [ cl = induction_clause -> cl ] ] ; + conversion: + [ [ c = Constr.constr -> + Loc.tag ~loc:!@loc @@ QConvert c + | c1 = Constr.constr; "with"; c2 = Constr.constr -> + Loc.tag ~loc:!@loc @@ QConvertWith (c1, c2) + ] ] + ; + q_conversion: + [ [ c = conversion -> c ] ] + ; orient: [ [ "->" -> Loc.tag ~loc:!@loc (Some true) | "<-" -> Loc.tag ~loc:!@loc (Some false) diff --git a/src/tac2core.ml b/src/tac2core.ml index 9ef88a7d56..ce53b781f5 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1160,6 +1160,7 @@ let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause +let () = add_expr_scope "conversion" q_conversion Tac2quote.of_conversion let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting let () = add_expr_scope "clause" q_clause Tac2quote.of_clause let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb diff --git a/src/tac2entries.ml b/src/tac2entries.ml index b803278929..3ac3d14ef3 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -30,6 +30,7 @@ let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" let q_destruction_arg = Pcoq.Gram.entry_create "tactic:q_destruction_arg" let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" +let q_conversion = Pcoq.Gram.entry_create "tactic:q_conversion" let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" diff --git a/src/tac2entries.mli b/src/tac2entries.mli index b2a2dd4846..a92e149a85 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -70,6 +70,7 @@ val q_intropattern : intro_pattern Pcoq.Gram.entry val q_intropatterns : intro_pattern list located Pcoq.Gram.entry val q_destruction_arg : destruction_arg Pcoq.Gram.entry val q_induction_clause : induction_clause Pcoq.Gram.entry +val q_conversion : conversion Pcoq.Gram.entry val q_rewriting : rewriting Pcoq.Gram.entry val q_clause : clause Pcoq.Gram.entry val q_dispatch : dispatch Pcoq.Gram.entry diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 229cece7c4..ad52884ca6 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -84,6 +84,12 @@ type induction_clause_r = { type induction_clause = induction_clause_r located +type conversion_r = +| QConvert of Constrexpr.constr_expr +| QConvertWith of Constrexpr.constr_expr * Constrexpr.constr_expr + +type conversion = conversion_r located + type multi_r = | QPrecisely of int located | QUpTo of int located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 1275c939c5..399c1199bd 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -208,6 +208,62 @@ let of_induction_clause (loc, cl) = std_proj "indcl_in", in_; ]) +let check_pattern_id ?loc id = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) + +let pattern_vars pat = + let rec aux () accu pat = match pat.CAst.v with + | Constrexpr.CPatVar id + | Constrexpr.CEvar (id, []) -> + let () = check_pattern_id ?loc:pat.CAst.loc id in + Id.Set.add id accu + | _ -> + Topconstr.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat + in + aux () Id.Set.empty pat + +let abstract_vars loc vars tac = + let get_name = function Name id -> Some id | Anonymous -> None in + let def = try Some (List.find_map get_name vars) with Not_found -> None in + let na, tac = match def with + | None -> (Anonymous, tac) + | Some id0 -> + (** Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) + let build_bindings (n, accu) na = match na with + | Anonymous -> (n + 1, accu) + | Name _ -> + let get = global_ref ?loc (kername array_prefix "get") in + let args = [of_variable (loc, id0); of_int (loc, n)] in + let e = Loc.tag ?loc @@ CTacApp (get, args) in + let accu = (Loc.tag ?loc @@ CPatVar na, None, e) :: accu in + (n + 1, accu) + in + let (_, bnd) = List.fold_left build_bindings (0, []) vars in + let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in + (Name id0, tac) + in + Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], tac) + +let of_pattern p = + inj_wit ?loc:p.CAst.loc wit_pattern p + +let of_conversion (loc, c) = match c with +| QConvert c -> + let pat = of_option ?loc of_pattern None in + let c = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar Anonymous, None], of_constr c) in + of_tuple ?loc [pat; c] +| QConvertWith (pat, c) -> + let vars = pattern_vars pat in + let pat = of_option ?loc of_pattern (Some pat) in + let c = of_constr c in + (** Order is critical here *) + let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in + let c = abstract_vars loc vars c in + of_tuple [pat; c] + let of_repeat (loc, r) = match r with | QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] | QUpTo n -> std_constructor ?loc "UpTo" [of_int n] @@ -307,45 +363,6 @@ let of_hintdb (loc, hdb) = match hdb with | QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None | QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) -let check_pattern_id ?loc id = - if Tac2env.is_constructor (Libnames.qualid_of_ident id) then - CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) - -let pattern_vars pat = - let rec aux () accu pat = match pat.CAst.v with - | Constrexpr.CPatVar id - | Constrexpr.CEvar (id, []) -> - let () = check_pattern_id ?loc:pat.CAst.loc id in - Id.Set.add id accu - | _ -> - Topconstr.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat - in - aux () Id.Set.empty pat - -let abstract_vars loc vars tac = - let get_name = function Name id -> Some id | Anonymous -> None in - let def = try Some (List.find_map get_name vars) with Not_found -> None in - let na, tac = match def with - | None -> (Anonymous, tac) - | Some id0 -> - (** Trick: in order not to shadow a variable nor to choose an arbitrary - name, we reuse one which is going to be shadowed by the matched - variables anyways. *) - let build_bindings (n, accu) na = match na with - | Anonymous -> (n + 1, accu) - | Name _ -> - let get = global_ref ?loc (kername array_prefix "get") in - let args = [of_variable (loc, id0); of_int (loc, n)] in - let e = Loc.tag ?loc @@ CTacApp (get, args) in - let accu = (Loc.tag ?loc @@ CPatVar na, None, e) :: accu in - (n + 1, accu) - in - let (_, bnd) = List.fold_left build_bindings (0, []) vars in - let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in - (Name id0, tac) - in - Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], tac) - let extract_name ?loc oid = match oid with | None -> Anonymous | Some id -> @@ -378,9 +395,6 @@ let of_constr_matching (loc, m) = in of_list ?loc map m -let of_pattern p = - inj_wit ?loc:p.CAst.loc wit_pattern p - (** From the patterns and the body of the branch, generate: - a goal pattern: (constr_match list * constr_match) - a branch function (ident array -> context array -> constr array -> context -> 'a) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 403d333f38..3f6c9a55e5 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -51,6 +51,8 @@ val of_destruction_arg : destruction_arg -> raw_tacexpr val of_induction_clause : induction_clause -> raw_tacexpr +val of_conversion : conversion -> raw_tacexpr + val of_rewriting : rewriting -> raw_tacexpr val of_occurrences : occurrences -> raw_tacexpr diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 99fa0370e1..60b6e70d58 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -467,6 +467,13 @@ let () = define_red2 "eval_native" begin fun where c -> Tac2tactics.eval_native where c end +let () = define_prim3 "tac_change" begin fun pat c cl -> + let pat = Value.to_option (fun p -> Value.to_pattern p) pat in + let c = Value.to_fun1 (array constr) constr c in + let cl = to_clause cl in + Tac2tactics.change pat c cl +end + let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> let ev = Value.to_bool ev in let rw = Value.to_list to_rewriting rw in diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index c68fdf9a7a..5a5b259ee7 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -150,6 +150,18 @@ let split_with_bindings ev bnd = let bnd = mk_bindings bnd in Tactics.split_with_bindings ev [bnd] +let change pat c cl = + let open Tac2ffi in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let c subst sigma = + let subst = Array.map_of_list snd (Id.Map.bindings subst) in + delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma + in + let cl = mk_clause cl in + Tactics.change pat c cl + end + let rewrite ev rw cl by = let map_rw (orient, repeat, c) = let c = c >>= fun c -> return (mk_with_bindings c) in diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 3d64e7ec8c..7a4624ba2c 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -38,6 +38,8 @@ val left_with_bindings : evars_flag -> bindings -> unit tactic val right_with_bindings : evars_flag -> bindings -> unit tactic val split_with_bindings : evars_flag -> bindings -> unit tactic +val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic + val rewrite : evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic diff --git a/tests/example2.v b/tests/example2.v index 20819606db..46e4e43ed0 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -260,3 +260,9 @@ Proof. assert (H : 0 + 0 = 0) by reflexivity. intros x; exact x. Qed. + +Goal 1 + 1 = 2. +Proof. +change (?a + 1 = 2) with (2 = $a + 1). +reflexivity. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index 48f3ca0587..77f3e235f3 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -375,6 +375,12 @@ Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause Std.native pl (default_on_concl cl). Ltac2 Notation native_compute := native_compute. +Ltac2 change0 p cl := + let ((pat, c)) := p in + Std.change pat c (default_on_concl cl). + +Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. + Ltac2 rewrite0 ev rw cl tac := let cl := default_on_concl cl in Std.rewrite ev rw cl tac. diff --git a/theories/Std.v b/theories/Std.v index 7831baf046..389299f266 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -175,6 +175,8 @@ Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". +Ltac2 @ external change : pattern option -> (constr array -> constr) -> clause -> unit := "ltac2" "tac_change". + Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". -- cgit v1.2.3 From 2890c90d0d5900db4c47398e1f809f3c759e07e0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Oct 2017 17:55:02 +0100 Subject: Fix the semantics of introducing with empty intro patterns. --- src/tac2tactics.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 5a5b259ee7..f7ad057e86 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -88,7 +88,7 @@ let mk_clause cl = { let intros_patterns ev ipat = let ipat = mk_intro_patterns ipat in - Tactics.intro_patterns ev ipat + Tactics.intros_patterns ev ipat let apply adv ev cb cl = let map c = -- cgit v1.2.3 From 2f95db622428cf58968e8d13f2230fe51c31e97f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Oct 2017 18:11:26 +0100 Subject: Put notations in level 5 by default. --- src/tac2entries.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 3ac3d14ef3..cefb4b13b8 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -674,6 +674,7 @@ let register_notation ?(local = false) tkn lev body = match tkn, lev with let ids = List.fold_left fold Id.Set.empty entries in (** Globalize so that names are absolute *) let body = Tac2intern.globalize ids body in + let lev = match lev with Some _ -> lev | None -> Some 5 in let ext = { synext_tok = tkn; synext_exp = body; -- cgit v1.2.3 From de7483beb78e5bd81dc6449ba201fb9dfc490ba8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Oct 2017 18:16:18 +0100 Subject: Add a macro for the now tactic --- theories/Notations.v | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/theories/Notations.v b/theories/Notations.v index 77f3e235f3..dc09812254 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -555,3 +555,8 @@ Ltac2 Notation "firstorder" tac(opt(thunk(tactic))) refs(opt(seq("using", list1(reference, ",")))) ids(opt(seq("with", list1(ident)))) := firstorder0 tac refs ids. + +(** now *) + +Ltac2 now0 t := t (); ltac1:(easy). +Ltac2 Notation "now" t(thunk(self)) := now0 t. -- cgit v1.2.3 From 62606e17ff4afe6a897607d45471b7f4d3ef54b8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 2 Nov 2017 11:41:49 +0100 Subject: Binding the specialize tactic. --- src/tac2stdlib.ml | 6 ++++++ src/tac2tactics.ml | 5 +++++ src/tac2tactics.mli | 2 ++ tests/example2.v | 13 +++++++++++++ theories/Notations.v | 6 ++++++ theories/Std.v | 2 ++ 6 files changed, 34 insertions(+) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 60b6e70d58..6026b5b319 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -569,6 +569,12 @@ let () = define_prim3 "tac_constructorn" begin fun ev n bnd -> Tac2tactics.constructor_tac ev None n bnd end +let () = define_prim2 "tac_specialize" begin fun c ipat -> + let c = to_constr_with_bindings c in + let ipat = Value.to_option to_intro_pattern ipat in + Tac2tactics.specialize c ipat +end + let () = define_prim1 "tac_symmetry" begin fun cl -> let cl = to_clause cl in Tac2tactics.symmetry cl diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index f7ad057e86..eec0d2ab45 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -150,6 +150,11 @@ let split_with_bindings ev bnd = let bnd = mk_bindings bnd in Tactics.split_with_bindings ev [bnd] +let specialize c pat = + let c = mk_with_bindings c in + let pat = Option.map mk_intro_pattern pat in + Tactics.specialize c pat + let change pat c cl = let open Tac2ffi in Proofview.Goal.enter begin fun gl -> diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 7a4624ba2c..96c7b9214c 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -38,6 +38,8 @@ val left_with_bindings : evars_flag -> bindings -> unit tactic val right_with_bindings : evars_flag -> bindings -> unit tactic val split_with_bindings : evars_flag -> bindings -> unit tactic +val specialize : constr_with_bindings -> intro_pattern option -> unit tactic + val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic val rewrite : diff --git a/tests/example2.v b/tests/example2.v index 46e4e43ed0..c953d25061 100644 --- a/tests/example2.v +++ b/tests/example2.v @@ -266,3 +266,16 @@ Proof. change (?a + 1 = 2) with (2 = $a + 1). reflexivity. Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl). +destruct H. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl) as []. +Qed. diff --git a/theories/Notations.v b/theories/Notations.v index dc09812254..f16a3a9161 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -204,6 +204,12 @@ Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). Ltac2 Notation econstructor := econstructor. Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. +Ltac2 specialize0 c pat := + enter_h false (fun _ c => Std.specialize c pat) c. + +Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("as", intropattern))) := + specialize0 c ipat. + Ltac2 elim0 ev c bnd use := let f ev ((c, bnd, use)) := Std.elim ev (c, bnd) use in enter_h ev f (fun () => c (), bnd (), use ()). diff --git a/theories/Std.v b/theories/Std.v index 389299f266..73b2ba02c4 100644 --- a/theories/Std.v +++ b/theories/Std.v @@ -227,6 +227,8 @@ Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". +Ltac2 @ external specialize : constr_with_bindings -> intro_pattern option -> unit := "ltac2" "tac_specialize". + (** extratactics *) Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". -- cgit v1.2.3 From 7e7964ddcc41363151d95cddd1a68b3dc70bb070 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 2 Nov 2017 15:56:51 +0100 Subject: Moving pattern type constraints to pattern AST. --- src/g_ltac2.ml4 | 16 ++++++++++------ src/tac2entries.ml | 14 ++++++++------ src/tac2expr.mli | 5 +++-- src/tac2intern.ml | 53 +++++++++++++++++++++++++++++++++++++---------------- src/tac2quote.ml | 16 +++++++++------- 5 files changed, 67 insertions(+), 37 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 557e2bcb9a..fca1b3045c 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -220,15 +220,15 @@ GEXTEND Gram | None -> te | Some args -> Loc.tag ~loc:!@loc @@ CTacFun (args, te) in - (pat, None, te) + (pat, te) ] ] ; let_binder: [ [ pats = LIST1 input_fun -> match pats with - | [(_, CPatVar _) as pat, None] -> (pat, None) - | ((_, CPatVar (Name id)) as pat, None) :: args -> (pat, Some args) - | [pat, None] -> (pat, None) + | [(_, CPatVar _) as pat] -> (pat, None) + | ((_, CPatVar (Name id)) as pat) :: args -> (pat, Some args) + | [pat] -> (pat, None) | _ -> CErrors.user_err ~loc:!@loc (str "Invalid pattern") ] ] ; @@ -257,8 +257,12 @@ GEXTEND Gram | l = Prim.ident -> Loc.tag ~loc:!@loc (Name l) ] ] ; input_fun: - [ [ b = tac2pat LEVEL "0" -> (b, None) - | "("; b = tac2pat; t = OPT [ ":"; t = tac2type -> t ]; ")" -> (b, t) ] ] + [ [ b = tac2pat LEVEL "0" -> b + | "("; b = tac2pat; t = OPT [ ":"; t = tac2type -> t ]; ")" -> + match t with + | None -> b + | Some t -> Loc.tag ~loc:!@loc @@ CPatCnv (b, t) + ] ] ; tac2def_body: [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> diff --git a/src/tac2entries.ml b/src/tac2entries.ml index cefb4b13b8..e48bf02321 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -277,11 +277,15 @@ let fresh_var avoid x = in Namegen.next_ident_away_from (Id.of_string x) bad +let extract_pattern_type (loc, p as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + (** Mangle recursive tactics *) let inline_rec_tactic tactics = let avoid = List.fold_left (fun accu ((_, id), _) -> Id.Set.add id accu) Id.Set.empty tactics in let map (id, e) = match snd e with - | CTacFun (pat, _) -> (id, pat, e) + | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) | _ -> let loc, _ = id in user_err ?loc (str "Recursive tactic definitions must be functions") @@ -295,11 +299,9 @@ let inline_rec_tactic tactics = in (** Fresh variables to abstract over the function patterns *) let _, vars = List.fold_left fold_var (avoid, []) pat in - let map_body ((loc, id), _, e) = (Loc.tag ?loc @@ CPatVar (Name id)), None, e in + let map_body ((loc, id), _, e) = (Loc.tag ?loc @@ CPatVar (Name id)), e in let bnd = List.map map_body tactics in - let pat_of_id (loc, id) = - ((Loc.tag ?loc @@ CPatVar (Name id)), None) - in + let pat_of_id (loc, id) = (Loc.tag ?loc @@ CPatVar (Name id)) in let var_of_id (loc, id) = let qid = (loc, qualid_of_ident id) in Loc.tag ?loc @@ CTacRef (RelId qid) @@ -590,7 +592,7 @@ let perform_notation syn st = let mk loc args = let map (na, e) = let loc = loc_of_tacexpr e in - ((Loc.tag ?loc @@ CPatVar na), None, e) + ((Loc.tag ?loc @@ CPatVar na), e) in let bnd = List.map map args in Loc.tag ~loc @@ CTacLet (false, bnd, syn.synext_exp) diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 89152dffe7..60f10d360f 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -91,6 +91,7 @@ type atom = type raw_patexpr_r = | CPatVar of Name.t | CPatRef of ltac_constructor or_tuple or_relid * raw_patexpr list +| CPatCnv of raw_patexpr * raw_typexpr and raw_patexpr = raw_patexpr_r located @@ -98,9 +99,9 @@ type raw_tacexpr_r = | CTacAtm of atom | CTacRef of tacref or_relid | CTacCst of ltac_constructor or_tuple or_relid -| CTacFun of (raw_patexpr * raw_typexpr option) list * raw_tacexpr +| CTacFun of raw_patexpr list * raw_tacexpr | CTacApp of raw_tacexpr * raw_tacexpr list -| CTacLet of rec_flag * (raw_patexpr * raw_typexpr option * raw_tacexpr) list * raw_tacexpr +| CTacLet of rec_flag * (raw_patexpr * raw_tacexpr) list * raw_tacexpr | CTacCnv of raw_tacexpr * raw_typexpr | CTacSeq of raw_tacexpr * raw_tacexpr | CTacCse of raw_tacexpr * raw_taccase list diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 7b35cd55aa..9afdb3aedc 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -556,11 +556,13 @@ type glb_patexpr = | GPatVar of Name.t | GPatRef of ltac_constructor or_tuple * glb_patexpr list -let rec intern_patexpr env (_, pat) = match pat with +let rec intern_patexpr env (loc, pat) = match pat with | CPatVar na -> GPatVar na | CPatRef (qid, pl) -> let kn = get_constructor env qid in GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) +| CPatCnv (pat, ty) -> + user_err ?loc (str "Pattern not handled yet") type pattern_kind = | PKind_empty @@ -604,11 +606,16 @@ let rec ids_of_pattern accu (_, pat) = match pat with | CPatVar (Name id) -> Id.Set.add id accu | CPatRef (_, pl) -> List.fold_left ids_of_pattern accu pl +| CPatCnv (pat, _) -> ids_of_pattern accu pat let loc_of_relid = function | RelId (loc, _) -> loc | AbsKn _ -> None +let extract_pattern_type (loc, p as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + (** Expand pattern: [p => t] becomes [x => match x with p => t end] *) let expand_pattern avoid bnd = let fold (avoid, bnd) (pat, t) = @@ -667,6 +674,7 @@ let rec intern_rec env (loc, e) = match e with let kn = get_constructor env qid in intern_constructor env loc kn [] | CTacFun (bnd, e) -> + let bnd = List.map extract_pattern_type bnd in let map (_, t) = match t with | None -> GTypVar (fresh_id env) | Some t -> intern_type env t @@ -689,8 +697,9 @@ let rec intern_rec env (loc, e) = match e with let map arg = (** Thunk alias arguments *) let loc = loc_of_tacexpr arg in - let var = [Loc.tag ?loc @@ CPatVar Anonymous, Some (Loc.tag ?loc @@ CTypRef (AbsKn (Tuple 0), []))] in - Loc.tag ?loc @@ CTacFun (var, arg) + let t_unit = Loc.tag ?loc @@ CTypRef (AbsKn (Tuple 0), []) in + let var = Loc.tag ?loc @@ CPatCnv (Loc.tag ?loc @@ CPatVar Anonymous, t_unit) in + Loc.tag ?loc @@ CTacFun ([var], arg) in let args = List.map map args in intern_rec env (Loc.tag ?loc @@ CTacApp (e, args)) @@ -706,6 +715,11 @@ let rec intern_rec env (loc, e) = match e with let ret = unify_arrow ?loc env ft t in (GTacApp (f, args), ret) | CTacLet (is_rec, el, e) -> + let map (pat, e) = + let (pat, ty) = extract_pattern_type pat in + (pat, ty, e) + in + let el = List.map map el in let fold accu (pat, _, e) = let ids = ids_of_pattern Id.Set.empty pat in let common = Id.Set.inter ids accu in @@ -826,7 +840,7 @@ and intern_let_rec env loc ids el e = let (loc, pat) = pat in let na = match pat with | CPatVar na -> na - | CPatRef _ -> + | CPatRef _ | CPatCnv _ -> user_err ?loc (str "This kind of pattern is forbidden in let-rec bindings") in let id = fresh_id env in @@ -961,6 +975,8 @@ and intern_case env loc e pl = else warn_redundant_clause ?loc () in brT + | CPatCnv _ -> + user_err ?loc (str "Pattern not handled yet") in let () = unify ?loc:(loc_of_tacexpr br) env tbr ret in intern_branch rem @@ -1216,10 +1232,10 @@ let rec globalize ids (loc, er as e) = match er with let knc = get_constructor () qid in Loc.tag ?loc @@ CTacCst (AbsKn knc) | CTacFun (bnd, e) -> - let fold (pats, accu) (pat, t) = + let fold (pats, accu) pat = let accu = ids_of_pattern accu pat in let pat = globalize_pattern ids pat in - ((pat, t) :: pats, accu) + (pat :: pats, accu) in let bnd, ids = List.fold_left fold ([], ids) bnd in let bnd = List.rev bnd in @@ -1230,13 +1246,14 @@ let rec globalize ids (loc, er as e) = match er with let el = List.map (fun e -> globalize ids e) el in Loc.tag ?loc @@ CTacApp (e, el) | CTacLet (isrec, bnd, e) -> - let fold accu (pat, _, _) = ids_of_pattern accu pat in + let fold accu (pat, _) = ids_of_pattern accu pat in let ext = List.fold_left fold Id.Set.empty bnd in let eids = Id.Set.union ext ids in let e = globalize eids e in - let map (qid, t, e) = + let map (qid, e) = let ids = if isrec then eids else ids in - (qid, t, globalize ids e) + let qid = globalize_pattern ids qid in + (qid, globalize ids e) in let bnd = List.map map bnd in Loc.tag ?loc @@ CTacLet (isrec, bnd, e) @@ -1281,6 +1298,9 @@ and globalize_pattern ids (loc, pr as p) = match pr with let cst = AbsKn knc in let pl = List.map (fun p -> globalize_pattern ids p) pl in Loc.tag ?loc @@ CPatRef (cst, pl) +| CPatCnv (pat, ty) -> + let pat = globalize_pattern ids pat in + Loc.tag ?loc @@ CPatCnv (pat, ty) (** Kernel substitution *) @@ -1419,6 +1439,10 @@ let rec subst_rawpattern subst (loc, pr as p) = match pr with let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in let c' = subst_or_relid subst c in if pl' == pl && c' == c then p else Loc.tag ?loc @@ CPatRef (c', pl') +| CPatCnv (pat, ty) -> + let pat' = subst_rawpattern subst pat in + let ty' = subst_rawtype subst ty in + if pat' == pat && ty' == ty then p else Loc.tag ?loc @@ CPatCnv (pat', ty') (** Used for notations *) let rec subst_rawexpr subst (loc, tr as t) = match tr with @@ -1430,10 +1454,7 @@ let rec subst_rawexpr subst (loc, tr as t) = match tr with let ref' = subst_or_relid subst ref in if ref' == ref then t else Loc.tag ?loc @@ CTacCst ref' | CTacFun (bnd, e) -> - let map (na, t as p) = - let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in - if t' == t then p else (na, t') - in + let map pat = subst_rawpattern subst pat in let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in if bnd' == bnd && e' == e then t else Loc.tag ?loc @@ CTacFun (bnd', e') @@ -1442,10 +1463,10 @@ let rec subst_rawexpr subst (loc, tr as t) = match tr with let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in if e' == e && el' == el then t else Loc.tag ?loc @@ CTacApp (e', el') | CTacLet (isrec, bnd, e) -> - let map (na, t, e as p) = - let t' = Option.smartmap (fun t -> subst_rawtype subst t) t in + let map (na, e as p) = + let na' = subst_rawpattern subst na in let e' = subst_rawexpr subst e in - if t' == t && e' == e then p else (na, t', e') + if na' == na && e' == e then p else (na', e') in let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 399c1199bd..33c4a97de1 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -54,8 +54,10 @@ let std_proj ?loc name = let thunk e = let t_unit = coq_core "unit" in let loc = Tac2intern.loc_of_tacexpr e in - let var = [Loc.tag ?loc @@ CPatVar (Anonymous), Some (Loc.tag ?loc @@ CTypRef (AbsKn (Other t_unit), []))] in - Loc.tag ?loc @@ CTacFun (var, e) + let ty = Loc.tag ?loc @@ CTypRef (AbsKn (Other t_unit), []) in + let pat = Loc.tag ?loc @@ CPatVar (Anonymous) in + let pat = Loc.tag ?loc @@ CPatCnv (pat, ty) in + Loc.tag ?loc @@ CTacFun ([pat], e) let of_pair f g (loc, (e1, e2)) = Loc.tag ?loc @@ CTacApp (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 2)), [f e1; g e2]) @@ -238,14 +240,14 @@ let abstract_vars loc vars tac = let get = global_ref ?loc (kername array_prefix "get") in let args = [of_variable (loc, id0); of_int (loc, n)] in let e = Loc.tag ?loc @@ CTacApp (get, args) in - let accu = (Loc.tag ?loc @@ CPatVar na, None, e) :: accu in + let accu = (Loc.tag ?loc @@ CPatVar na, e) :: accu in (n + 1, accu) in let (_, bnd) = List.fold_left build_bindings (0, []) vars in let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in (Name id0, tac) in - Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], tac) + Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na], tac) let of_pattern p = inj_wit ?loc:p.CAst.loc wit_pattern p @@ -253,7 +255,7 @@ let of_pattern p = let of_conversion (loc, c) = match c with | QConvert c -> let pat = of_option ?loc of_pattern None in - let c = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar Anonymous, None], of_constr c) in + let c = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar Anonymous], of_constr c) in of_tuple ?loc [pat; c] | QConvertWith (pat, c) -> let vars = pattern_vars pat in @@ -389,7 +391,7 @@ let of_constr_matching (loc, m) = let vars = Id.Set.elements vars in let vars = List.map (fun id -> Name id) vars in let e = abstract_vars loc vars tac in - let e = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na, None], e) in + let e = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na], e) in let pat = inj_wit ?loc:ploc wit_pattern pat in of_tuple [knd; pat; e] in @@ -433,7 +435,7 @@ let of_goal_matching (loc, gm) = in let map (loc, (pat, tac)) = let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in - let tac = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar cctx, None], tac) in + let tac = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar cctx], tac) in let tac = abstract_vars loc subst tac in let tac = abstract_vars loc hctx tac in let tac = abstract_vars loc hyps tac in -- cgit v1.2.3 From 2d0336671971489f217d666afde6537295b8c44a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 2 Nov 2017 16:33:13 +0100 Subject: Factorizing entries for patterns with type constraints. --- src/g_ltac2.ml4 | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index fca1b3045c..080fba7103 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -127,9 +127,19 @@ GEXTEND Gram [ "_" -> Loc.tag ~loc:!@loc @@ CPatVar Anonymous | "()" -> Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id - | "("; pl = LIST0 tac2pat LEVEL "1" SEP ","; ")" -> - Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) ] - ] + | "("; p = atomic_tac2pat; ")" -> p + ] ] + ; + atomic_tac2pat: + [ [ -> + Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) + | p = tac2pat; ":"; t = tac2type -> + Loc.tag ~loc:!@loc @@ CPatCnv (p, t) + | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> + let pl = p :: pl in + Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) + | p = tac2pat -> p + ] ] ; tac2expr: [ "6" RIGHTA @@ -257,12 +267,7 @@ GEXTEND Gram | l = Prim.ident -> Loc.tag ~loc:!@loc (Name l) ] ] ; input_fun: - [ [ b = tac2pat LEVEL "0" -> b - | "("; b = tac2pat; t = OPT [ ":"; t = tac2type -> t ]; ")" -> - match t with - | None -> b - | Some t -> Loc.tag ~loc:!@loc @@ CPatCnv (b, t) - ] ] + [ [ b = tac2pat LEVEL "0" -> b ] ] ; tac2def_body: [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> -- cgit v1.2.3 From 290e9585ac3b0f6ece3f1966457fef3811f88d10 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 2 Nov 2017 16:44:57 +0100 Subject: Fix the horrible syntax that used to be valid for tuple matching. --- theories/Notations.v | 14 +++++++------- theories/Pattern.v | 20 ++++++++++---------- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/theories/Notations.v b/theories/Notations.v index f16a3a9161..f4621656d6 100644 --- a/theories/Notations.v +++ b/theories/Notations.v @@ -46,7 +46,7 @@ Ltac2 orelse t f := match Control.case t with | Err e => f e | Val ans => - let ((x, k)) := ans in + let (x, k) := ans in Control.plus (fun _ => x) k end. @@ -54,7 +54,7 @@ Ltac2 ifcatch t s f := match Control.case t with | Err e => f e | Val ans => - let ((x, k)) := ans in + let (x, k) := ans in Control.plus (fun _ => s x) (fun e => s (k e)) end. @@ -73,11 +73,11 @@ Ltac2 rec repeat0 (t : unit -> unit) := Ltac2 Notation repeat := repeat0. -Ltac2 dispatch0 t ((head, tail)) := +Ltac2 dispatch0 t (head, tail) := match tail with | None => Control.enter (fun _ => t (); Control.dispatch head) | Some tacs => - let ((def, rem)) := tacs in + let (def, rem) := tacs in Control.enter (fun _ => t (); Control.extend head def rem) end. @@ -211,7 +211,7 @@ Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("a specialize0 c ipat. Ltac2 elim0 ev c bnd use := - let f ev ((c, bnd, use)) := Std.elim ev (c, bnd) use in + let f ev (c, bnd, use) := Std.elim ev (c, bnd) use in enter_h ev f (fun () => c (), bnd (), use ()). Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) @@ -242,7 +242,7 @@ match cl with end. Ltac2 pose0 ev p := - enter_h ev (fun ev ((na, p)) => Std.pose na p) p. + enter_h ev (fun ev (na, p) => Std.pose na p) p. Ltac2 Notation "pose" p(thunk(pose)) := pose0 false p. @@ -382,7 +382,7 @@ Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause Ltac2 Notation native_compute := native_compute. Ltac2 change0 p cl := - let ((pat, c)) := p in + let (pat, c) := p in Std.change pat c (default_on_concl cl). Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. diff --git a/theories/Pattern.v b/theories/Pattern.v index 2c93918aee..ff7776b682 100644 --- a/theories/Pattern.v +++ b/theories/Pattern.v @@ -73,7 +73,7 @@ Ltac2 lazy_match0 t pats := | [] => Control.zero Match_failure | p :: m => let next _ := interp m in - let ((knd, pat, f)) := p in + let (knd, pat, f) := p in let p := match knd with | MatchPattern => (fun _ => @@ -82,7 +82,7 @@ Ltac2 lazy_match0 t pats := fun _ => f context bind) | MatchContext => (fun _ => - let ((context, bind)) := matches_subterm_vect pat t in + let (context, bind) := matches_subterm_vect pat t in fun _ => f context bind) end in Control.plus p next @@ -94,7 +94,7 @@ Ltac2 multi_match0 t pats := | [] => Control.zero Match_failure | p :: m => let next _ := interp m in - let ((knd, pat, f)) := p in + let (knd, pat, f) := p in let p := match knd with | MatchPattern => (fun _ => @@ -103,7 +103,7 @@ Ltac2 multi_match0 t pats := f context bind) | MatchContext => (fun _ => - let ((context, bind)) := matches_subterm_vect pat t in + let (context, bind) := matches_subterm_vect pat t in f context bind) end in Control.plus p next @@ -117,10 +117,10 @@ Ltac2 lazy_goal_match0 rev pats := | [] => Control.zero Match_failure | p :: m => let next _ := interp m in - let ((pat, f)) := p in - let ((phyps, pconcl)) := pat in + let (pat, f) := p in + let (phyps, pconcl) := pat in let cur _ := - let ((hids, hctx, subst, cctx)) := matches_goal rev phyps pconcl in + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in fun _ => f hids hctx subst cctx in Control.plus cur next @@ -132,10 +132,10 @@ Ltac2 multi_goal_match0 rev pats := | [] => Control.zero Match_failure | p :: m => let next _ := interp m in - let ((pat, f)) := p in - let ((phyps, pconcl)) := pat in + let (pat, f) := p in + let (phyps, pconcl) := pat in let cur _ := - let ((hids, hctx, subst, cctx)) := matches_goal rev phyps pconcl in + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in f hids hctx subst cctx in Control.plus cur next -- cgit v1.2.3 From 57f479f13c869408f51fbebc744c3b67a07d7f7c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 4 Nov 2017 23:16:26 +0100 Subject: A possible fix after PR#6047 (a generic printer for ltac values). --- src/tac2core.ml | 4 ++-- src/tac2env.ml | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index ce53b781f5..e476da7259 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -989,7 +989,7 @@ let () = let () = let pr_raw id = mt () in let pr_glb id = str "$" ++ Id.print id in - let pr_top _ = mt () in + let pr_top _ = Genprint.PrinterBasic mt in Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top (** Ltac2 in Ltac1 *) @@ -1017,7 +1017,7 @@ let () = let () = let pr_raw _ = mt () in let pr_glb e = Tac2print.pr_glbexpr e in - let pr_top _ = mt () in + let pr_top _ = Genprint.PrinterBasic mt in Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top (** Built-in notation scopes *) diff --git a/src/tac2env.ml b/src/tac2env.ml index 2f1124c156..d0f286b396 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -280,6 +280,8 @@ let std_prefix = let wit_ltac2 = Genarg.make0 "ltac2:value" let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" +let () = Geninterp.register_val0 wit_ltac2 None +let () = Geninterp.register_val0 wit_ltac2_quotation None let is_constructor qid = let (_, id) = repr_qualid qid in -- cgit v1.2.3 From f773caf67f46bdaf80d9fd13f49b53c9a21cb091 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 6 Nov 2017 16:27:35 +0100 Subject: Generalize the use of repr in Tac2stdlib. --- _CoqProject | 2 + src/ltac2_plugin.mlpack | 1 + src/tac2extffi.ml | 40 +++++ src/tac2extffi.mli | 16 ++ src/tac2ffi.ml | 2 + src/tac2ffi.mli | 4 + src/tac2stdlib.ml | 428 ++++++++++++++++-------------------------------- src/tac2tactics.ml | 18 +- src/tac2tactics.mli | 16 +- 9 files changed, 226 insertions(+), 301 deletions(-) create mode 100644 src/tac2extffi.ml create mode 100644 src/tac2extffi.mli diff --git a/_CoqProject b/_CoqProject index df8cb00b76..eec66dc75e 100644 --- a/_CoqProject +++ b/_CoqProject @@ -25,6 +25,8 @@ src/tac2match.ml src/tac2match.mli src/tac2core.ml src/tac2core.mli +src/tac2extffi.ml +src/tac2extffi.mli src/tac2tactics.ml src/tac2tactics.mli src/tac2stdlib.ml diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack index 40b91e4b53..2a25e825cb 100644 --- a/src/ltac2_plugin.mlpack +++ b/src/ltac2_plugin.mlpack @@ -8,6 +8,7 @@ Tac2entries Tac2quote Tac2match Tac2core +Tac2extffi Tac2tactics Tac2stdlib G_ltac2 diff --git a/src/tac2extffi.ml b/src/tac2extffi.ml new file mode 100644 index 0000000000..315c970f9e --- /dev/null +++ b/src/tac2extffi.ml @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false) f + +(** More ML representations *) + +let to_qhyp v = match Value.to_block v with +| (0, [| i |]) -> AnonHyp (Value.to_int i) +| (1, [| id |]) -> NamedHyp (Value.to_ident id) +| _ -> assert false + +let qhyp = make_to_repr to_qhyp + +let to_bindings = function +| ValInt 0 -> NoBindings +| ValBlk (0, [| vl |]) -> + ImplicitBindings (Value.to_list Value.to_constr vl) +| ValBlk (1, [| vl |]) -> + ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) +| _ -> assert false + +let bindings = make_to_repr to_bindings + +let to_constr_with_bindings v = match Value.to_tuple v with +| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) +| _ -> assert false + +let constr_with_bindings = make_to_repr to_constr_with_bindings diff --git a/src/tac2extffi.mli b/src/tac2extffi.mli new file mode 100644 index 0000000000..f5251c3d0d --- /dev/null +++ b/src/tac2extffi.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> valexpr val repr_to : 'a repr -> valexpr -> 'a +val make_repr : ('a -> valexpr) -> (valexpr -> 'a) -> 'a repr + (** These functions allow to convert back and forth between OCaml and Ltac2 data representation. The [to_*] functions raise an anomaly whenever the data has not expected shape. *) @@ -109,6 +111,8 @@ val array : 'a repr -> 'a array repr val of_tuple : valexpr array -> valexpr val to_tuple : valexpr -> valexpr array +val of_pair : ('a -> valexpr) -> ('b -> valexpr) -> 'a * 'b -> valexpr +val to_pair : (valexpr -> 'a) -> (valexpr -> 'b) -> valexpr -> 'a * 'b val pair : 'a repr -> 'b repr -> ('a * 'b) repr val of_option : ('a -> valexpr) -> 'a option -> valexpr diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 6026b5b319..28d4967874 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -11,38 +11,25 @@ open Genredexpr open Tac2expr open Tac2ffi open Tac2types +open Tac2extffi open Proofview.Notations module Value = Tac2ffi +(** Make a representation with a dummy from function *) +let make_to_repr f = Tac2ffi.make_repr (fun _ -> assert false) f + let return x = Proofview.tclUNIT x let v_unit = Value.of_unit () -let thaw f = Tac2ffi.apply (Value.to_closure f) [v_unit] - -let to_pair f g v = match Value.to_tuple v with -| [| x; y |] -> (f x, g y) -| _ -> assert false +let thaw r f = Tac2ffi.app_fun1 f unit r () +let uthaw r f = Tac2ffi.app_fun1 (to_fun1 unit r f) unit r () +let thunk r = fun1 unit r let to_name c = match Value.to_option Value.to_ident c with | None -> Anonymous | Some id -> Name id -let to_qhyp v = match Value.to_block v with -| (0, [| i |]) -> AnonHyp (Value.to_int i) -| (1, [| id |]) -> NamedHyp (Value.to_ident id) -| _ -> assert false - -let to_bindings = function -| ValInt 0 -> NoBindings -| ValBlk (0, [| vl |]) -> - ImplicitBindings (Value.to_list Value.to_constr vl) -| ValBlk (1, [| vl |]) -> - ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) -| _ -> assert false - -let to_constr_with_bindings v = match Value.to_tuple v with -| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) -| _ -> assert false +let name = make_to_repr to_name let to_occurrences = function | ValInt 0 -> AllOccurrences @@ -51,6 +38,8 @@ let to_occurrences = function | ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) | _ -> assert false +let occurrences = make_to_repr to_occurrences + let to_hyp_location_flag v = match Value.to_int v with | 0 -> InHyp | 1 -> InHypTypeOnly @@ -68,6 +57,8 @@ let to_clause v = match Value.to_tuple v with { onhyps = hyps; concl_occs = to_occurrences concl; } | _ -> assert false +let clause = make_to_repr to_clause + let to_red_flag v = match Value.to_tuple v with | [| beta; iota; fix; cofix; zeta; delta; const |] -> { @@ -81,11 +72,13 @@ let to_red_flag v = match Value.to_tuple v with } | _ -> assert false -let to_pattern_with_occs pat = - to_pair Value.to_pattern to_occurrences pat +let red_flags = make_to_repr to_red_flag + +let pattern_with_occs = pair pattern occurrences -let to_constr_with_occs c = - to_pair Value.to_constr to_occurrences c +let constr_with_occs = pair constr occurrences + +let reference_with_occs = pair reference occurrences let rec to_intro_pattern v = match Value.to_block v with | (0, [| b |]) -> IntroForthcoming (Value.to_bool b) @@ -121,14 +114,20 @@ and to_or_and_intro_pattern v = match Value.to_block v with and to_intro_patterns il = Value.to_list to_intro_pattern il +let intro_pattern = make_to_repr to_intro_pattern + +let intro_patterns = make_to_repr to_intro_patterns + let to_destruction_arg v = match Value.to_block v with | (0, [| c |]) -> - let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + let c = uthaw constr_with_bindings c in ElimOnConstr c | (1, [| id |]) -> ElimOnIdent (Value.to_ident id) | (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) | _ -> assert false +let destruction_arg = make_to_repr to_destruction_arg + let to_induction_clause v = match Value.to_tuple v with | [| arg; eqn; as_; in_ |] -> let arg = to_destruction_arg arg in @@ -139,6 +138,8 @@ let to_induction_clause v = match Value.to_tuple v with | _ -> assert false +let induction_clause = make_to_repr to_induction_clause + let to_assertion v = match Value.to_block v with | (0, [| ipat; t; tac |]) -> let to_tac t = Value.to_fun1 Value.unit Value.unit t in @@ -150,6 +151,8 @@ let to_assertion v = match Value.to_block v with AssertValue (Value.to_ident id, Value.to_constr c) | _ -> assert false +let assertion = make_to_repr to_assertion + let to_multi = function | ValBlk (0, [| n |]) -> Precisely (Value.to_int n) | ValBlk (1, [| n |]) -> UpTo (Value.to_int n) @@ -161,27 +164,35 @@ let to_rewriting v = match Value.to_tuple v with | [| orient; repeat; c |] -> let orient = Value.to_option Value.to_bool orient in let repeat = to_multi repeat in - let c = thaw c >>= fun c -> return (to_constr_with_bindings c) in + let c = uthaw constr_with_bindings c in (orient, repeat, c) | _ -> assert false +let rewriting = make_to_repr to_rewriting + let to_debug v = match Value.to_int v with | 0 -> Hints.Off | 1 -> Hints.Info | 2 -> Hints.Debug | _ -> assert false +let debug = make_to_repr to_debug + let to_strategy v = match Value.to_int v with | 0 -> Class_tactics.Bfs | 1 -> Class_tactics.Dfs | _ -> assert false +let strategy = make_to_repr to_strategy + let to_inversion_kind v = match Value.to_int v with | 0 -> Misctypes.SimpleInversion | 1 -> Misctypes.FullInversion | 2 -> Misctypes.FullInversionClear | _ -> assert false +let inversion_kind = make_to_repr to_inversion_kind + let to_move_location = function | ValInt 0 -> Misctypes.MoveFirst | ValInt 1 -> Misctypes.MoveLast @@ -189,6 +200,15 @@ let to_move_location = function | ValBlk (1, [|id|]) -> Misctypes.MoveBefore (Value.to_ident id) | _ -> assert false +let move_location = make_to_repr to_move_location + +let to_generalize_arg v = match Value.to_tuple v with +| [| c; occs; na |] -> + (Value.to_constr c, to_occurrences occs, to_name na) +| _ -> assert false + +let generalize_arg = make_to_repr to_generalize_arg + (** Standard tactics sharing their implementation with Ltac1 *) let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } @@ -199,189 +219,127 @@ let define_prim0 name tac = let tac _ = lift tac in Tac2env.define_primitive (pname name) (mk_closure arity_one tac) -let define_prim1 name tac = - let tac x = lift (tac x) in +let define_prim1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in Tac2env.define_primitive (pname name) (mk_closure arity_one tac) -let define_prim2 name tac = - let tac x y = lift (tac x y) in +let define_prim2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) -let define_prim3 name tac = - let tac x y z = lift (tac x y z) in +let define_prim3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) -let define_prim4 name tac = - let tac x y z u = lift (tac x y z u) in +let define_prim4 name r0 r1 r2 r3 f = + let tac x y z u = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u)) in Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) -let define_prim5 name tac = - let tac x y z u v = lift (tac x y z u v) in +let define_prim5 name r0 r1 r2 r3 r4 f = + let tac x y z u v = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u) (Value.repr_to r4 v)) in Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) (** Tactics from Tacexpr *) -let () = define_prim2 "tac_intros" begin fun ev ipat -> - let ev = Value.to_bool ev in - let ipat = to_intro_patterns ipat in +let () = define_prim2 "tac_intros" bool intro_patterns begin fun ev ipat -> Tac2tactics.intros_patterns ev ipat end -let () = define_prim4 "tac_apply" begin fun adv ev cb ipat -> - let adv = Value.to_bool adv in - let ev = Value.to_bool ev in - let map_cb c = thaw c >>= fun c -> return (to_constr_with_bindings c) in - let cb = Value.to_list map_cb cb in - let map p = Value.to_option to_intro_pattern p in - let map_ipat p = to_pair Value.to_ident map p in - let ipat = Value.to_option map_ipat ipat in +let () = define_prim4 "tac_apply" bool bool (list (thunk constr_with_bindings)) (option (pair ident (option intro_pattern))) begin fun adv ev cb ipat -> Tac2tactics.apply adv ev cb ipat end -let () = define_prim3 "tac_elim" begin fun ev c copt -> - let ev = Value.to_bool ev in - let c = to_constr_with_bindings c in - let copt = Value.to_option to_constr_with_bindings copt in +let () = define_prim3 "tac_elim" bool constr_with_bindings (option constr_with_bindings) begin fun ev c copt -> Tac2tactics.elim ev c copt end -let () = define_prim2 "tac_case" begin fun ev c -> - let ev = Value.to_bool ev in - let c = to_constr_with_bindings c in +let () = define_prim2 "tac_case" bool constr_with_bindings begin fun ev c -> Tac2tactics.general_case_analysis ev c end -let () = define_prim1 "tac_generalize" begin fun cl -> - let cast v = match Value.to_tuple v with - | [| c; occs; na |] -> - (Value.to_constr c, to_occurrences occs, to_name na) - | _ -> assert false - in - let cl = Value.to_list cast cl in +let () = define_prim1 "tac_generalize" (list generalize_arg) begin fun cl -> Tac2tactics.generalize cl end -let () = define_prim1 "tac_assert" begin fun ast -> - let ast = to_assertion ast in +let () = define_prim1 "tac_assert" assertion begin fun ast -> Tac2tactics.assert_ ast end -let () = define_prim3 "tac_enough" begin fun c tac ipat -> - let c = Value.to_constr c in - let of_tac t = Proofview.tclIGNORE (thaw t) in - let tac = Value.to_option (fun t -> Value.to_option of_tac t) tac in - let ipat = Value.to_option to_intro_pattern ipat in +let () = define_prim3 "tac_enough" constr (option (option (thunk unit))) (option intro_pattern) begin fun c tac ipat -> + let tac = Option.map (fun o -> Option.map (fun f -> thaw unit f) o) tac in Tac2tactics.forward false tac ipat c end -let () = define_prim2 "tac_pose" begin fun idopt c -> - let na = to_name idopt in - let c = Value.to_constr c in +let () = define_prim2 "tac_pose" name constr begin fun na c -> Tactics.letin_tac None na c None Locusops.nowhere end -let () = define_prim3 "tac_set" begin fun ev p cl -> - let ev = Value.to_bool ev in - let cl = to_clause cl in +let () = define_prim3 "tac_set" bool (thunk (pair name constr)) clause begin fun ev p cl -> Proofview.tclEVARMAP >>= fun sigma -> - thaw p >>= fun p -> - let (na, c) = to_pair to_name Value.to_constr p in + thaw (pair name constr) p >>= fun (na, c) -> Tac2tactics.letin_pat_tac ev None na (sigma, c) cl end -let () = define_prim5 "tac_remember" begin fun ev na c eqpat cl -> - let ev = Value.to_bool ev in - let na = to_name na in - let cl = to_clause cl in - let eqpat = Value.to_option to_intro_pattern eqpat in +let () = define_prim5 "tac_remember" bool name (thunk constr) (option intro_pattern) clause begin fun ev na c eqpat cl -> let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in match eqpat with | IntroNaming eqpat -> Proofview.tclEVARMAP >>= fun sigma -> - thaw c >>= fun c -> - let c = Value.to_constr c in + thaw constr c >>= fun c -> Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl | _ -> Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") end -let () = define_prim3 "tac_destruct" begin fun ev ic using -> - let ev = Value.to_bool ev in - let ic = Value.to_list to_induction_clause ic in - let using = Value.to_option to_constr_with_bindings using in +let () = define_prim3 "tac_destruct" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> Tac2tactics.induction_destruct false ev ic using end -let () = define_prim3 "tac_induction" begin fun ev ic using -> - let ev = Value.to_bool ev in - let ic = Value.to_list to_induction_clause ic in - let using = Value.to_option to_constr_with_bindings using in +let () = define_prim3 "tac_induction" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> Tac2tactics.induction_destruct true ev ic using end -let () = define_prim1 "tac_red" begin fun cl -> - let cl = to_clause cl in +let () = define_prim1 "tac_red" clause begin fun cl -> Tac2tactics.reduce (Red false) cl end -let () = define_prim1 "tac_hnf" begin fun cl -> - let cl = to_clause cl in +let () = define_prim1 "tac_hnf" clause begin fun cl -> Tac2tactics.reduce Hnf cl end -let () = define_prim3 "tac_simpl" begin fun flags where cl -> - let flags = to_red_flag flags in - let where = Value.to_option to_pattern_with_occs where in - let cl = to_clause cl in +let () = define_prim3 "tac_simpl" red_flags (option pattern_with_occs) clause begin fun flags where cl -> Tac2tactics.simpl flags where cl end -let () = define_prim2 "tac_cbv" begin fun flags cl -> - let flags = to_red_flag flags in - let cl = to_clause cl in +let () = define_prim2 "tac_cbv" red_flags clause begin fun flags cl -> Tac2tactics.cbv flags cl end -let () = define_prim2 "tac_cbn" begin fun flags cl -> - let flags = to_red_flag flags in - let cl = to_clause cl in +let () = define_prim2 "tac_cbn" red_flags clause begin fun flags cl -> Tac2tactics.cbn flags cl end -let () = define_prim2 "tac_lazy" begin fun flags cl -> - let flags = to_red_flag flags in - let cl = to_clause cl in +let () = define_prim2 "tac_lazy" red_flags clause begin fun flags cl -> Tac2tactics.lazy_ flags cl end -let () = define_prim2 "tac_unfold" begin fun refs cl -> - let map v = to_pair Value.to_reference to_occurrences v in - let refs = Value.to_list map refs in - let cl = to_clause cl in +let () = define_prim2 "tac_unfold" (list reference_with_occs) clause begin fun refs cl -> Tac2tactics.unfold refs cl end -let () = define_prim2 "tac_fold" begin fun args cl -> - let args = Value.to_list Value.to_constr args in - let cl = to_clause cl in +let () = define_prim2 "tac_fold" (list constr) clause begin fun args cl -> Tac2tactics.reduce (Fold args) cl end -let () = define_prim2 "tac_pattern" begin fun where cl -> - let where = Value.to_list to_constr_with_occs where in - let cl = to_clause cl in +let () = define_prim2 "tac_pattern" (list constr_with_occs) clause begin fun where cl -> Tac2tactics.pattern where cl end -let () = define_prim2 "tac_vm" begin fun where cl -> - let where = Value.to_option to_pattern_with_occs where in - let cl = to_clause cl in +let () = define_prim2 "tac_vm" (option pattern_with_occs) clause begin fun where cl -> Tac2tactics.vm where cl end -let () = define_prim2 "tac_native" begin fun where cl -> - let where = Value.to_option to_pattern_with_occs where in - let cl = to_clause cl in +let () = define_prim2 "tac_native" (option pattern_with_occs) clause begin fun where cl -> Tac2tactics.native where cl end @@ -389,105 +347,71 @@ end let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) -let define_red1 name tac = - let tac x = lift (tac x) in +let define_red1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in Tac2env.define_primitive (pname name) (mk_closure arity_one tac) -let define_red2 name tac = - let tac x y = lift (tac x y) in +let define_red2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) -let define_red3 name tac = - let tac x y z = lift (tac x y z) in +let define_red3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) -let () = define_red1 "eval_red" begin fun c -> - let c = Value.to_constr c in +let () = define_red1 "eval_red" constr begin fun c -> Tac2tactics.eval_red c end -let () = define_red1 "eval_hnf" begin fun c -> - let c = Value.to_constr c in +let () = define_red1 "eval_hnf" constr begin fun c -> Tac2tactics.eval_hnf c end -let () = define_red3 "eval_simpl" begin fun flags where c -> - let flags = to_red_flag flags in - let where = Value.to_option to_pattern_with_occs where in - let c = Value.to_constr c in +let () = define_red3 "eval_simpl" red_flags (option pattern_with_occs) constr begin fun flags where c -> Tac2tactics.eval_simpl flags where c end -let () = define_red2 "eval_cbv" begin fun flags c -> - let flags = to_red_flag flags in - let c = Value.to_constr c in +let () = define_red2 "eval_cbv" red_flags constr begin fun flags c -> Tac2tactics.eval_cbv flags c end -let () = define_red2 "eval_cbn" begin fun flags c -> - let flags = to_red_flag flags in - let c = Value.to_constr c in +let () = define_red2 "eval_cbn" red_flags constr begin fun flags c -> Tac2tactics.eval_cbn flags c end -let () = define_red2 "eval_lazy" begin fun flags c -> - let flags = to_red_flag flags in - let c = Value.to_constr c in +let () = define_red2 "eval_lazy" red_flags constr begin fun flags c -> Tac2tactics.eval_lazy flags c end -let () = define_red2 "eval_unfold" begin fun refs c -> - let map v = to_pair Value.to_reference to_occurrences v in - let refs = Value.to_list map refs in - let c = Value.to_constr c in +let () = define_red2 "eval_unfold" (list reference_with_occs) constr begin fun refs c -> Tac2tactics.eval_unfold refs c end -let () = define_red2 "eval_fold" begin fun args c -> - let args = Value.to_list Value.to_constr args in - let c = Value.to_constr c in +let () = define_red2 "eval_fold" (list constr) constr begin fun args c -> Tac2tactics.eval_fold args c end -let () = define_red2 "eval_pattern" begin fun where c -> - let where = Value.to_list (fun p -> to_pair Value.to_constr to_occurrences p) where in - let c = Value.to_constr c in +let () = define_red2 "eval_pattern" (list constr_with_occs) constr begin fun where c -> Tac2tactics.eval_pattern where c end -let () = define_red2 "eval_vm" begin fun where c -> - let where = Value.to_option to_pattern_with_occs where in - let c = Value.to_constr c in +let () = define_red2 "eval_vm" (option pattern_with_occs) constr begin fun where c -> Tac2tactics.eval_vm where c end -let () = define_red2 "eval_native" begin fun where c -> - let where = Value.to_option to_pattern_with_occs where in - let c = Value.to_constr c in +let () = define_red2 "eval_native" (option pattern_with_occs) constr begin fun where c -> Tac2tactics.eval_native where c end -let () = define_prim3 "tac_change" begin fun pat c cl -> - let pat = Value.to_option (fun p -> Value.to_pattern p) pat in - let c = Value.to_fun1 (array constr) constr c in - let cl = to_clause cl in +let () = define_prim3 "tac_change" (option pattern) (fun1 (array constr) constr) clause begin fun pat c cl -> Tac2tactics.change pat c cl end -let () = define_prim4 "tac_rewrite" begin fun ev rw cl by -> - let ev = Value.to_bool ev in - let rw = Value.to_list to_rewriting rw in - let cl = to_clause cl in - let to_tac t = Proofview.tclIGNORE (thaw t) in - let by = Value.to_option to_tac by in +let () = define_prim4 "tac_rewrite" bool (list rewriting) clause (option (thunk unit)) begin fun ev rw cl by -> Tac2tactics.rewrite ev rw cl by end -let () = define_prim4 "tac_inversion" begin fun knd arg pat ids -> - let knd = to_inversion_kind knd in - let arg = to_destruction_arg arg in - let pat = Value.to_option to_intro_pattern pat in - let ids = Value.to_option (fun l -> Value.to_list Value.to_ident l) ids in +let () = define_prim4 "tac_inversion" inversion_kind destruction_arg (option intro_pattern) (option (list ident)) begin fun knd arg pat ids -> Tac2tactics.inversion knd arg pat ids end @@ -495,15 +419,11 @@ end let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity -let () = define_prim2 "tac_move" begin fun id mv -> - let id = Value.to_ident id in - let mv = to_move_location mv in +let () = define_prim2 "tac_move" ident move_location begin fun id mv -> Tactics.move_hyp id mv end -let () = define_prim2 "tac_intro" begin fun id mv -> - let id = Value.to_option Value.to_ident id in - let mv = Value.to_option to_move_location mv in +let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> let mv = Option.default Misctypes.MoveLast mv in Tactics.intro_move id mv end @@ -518,150 +438,112 @@ END let () = define_prim0 "tac_assumption" Tactics.assumption -let () = define_prim1 "tac_transitivity" begin fun c -> - let c = Value.to_constr c in +let () = define_prim1 "tac_transitivity" constr begin fun c -> Tactics.intros_transitivity (Some c) end let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) -let () = define_prim1 "tac_cut" begin fun c -> - let c = Value.to_constr c in +let () = define_prim1 "tac_cut" constr begin fun c -> Tactics.cut c end -let () = define_prim2 "tac_left" begin fun ev bnd -> - let ev = Value.to_bool ev in - let bnd = to_bindings bnd in +let () = define_prim2 "tac_left" bool bindings begin fun ev bnd -> Tac2tactics.left_with_bindings ev bnd end -let () = define_prim2 "tac_right" begin fun ev bnd -> - let ev = Value.to_bool ev in - let bnd = to_bindings bnd in +let () = define_prim2 "tac_right" bool bindings begin fun ev bnd -> Tac2tactics.right_with_bindings ev bnd end -let () = define_prim1 "tac_introsuntil" begin fun h -> - Tactics.intros_until (to_qhyp h) +let () = define_prim1 "tac_introsuntil" qhyp begin fun h -> + Tactics.intros_until h end -let () = define_prim1 "tac_exactnocheck" begin fun c -> - Tactics.exact_no_check (Value.to_constr c) +let () = define_prim1 "tac_exactnocheck" constr begin fun c -> + Tactics.exact_no_check c end -let () = define_prim1 "tac_vmcastnocheck" begin fun c -> - Tactics.vm_cast_no_check (Value.to_constr c) +let () = define_prim1 "tac_vmcastnocheck" constr begin fun c -> + Tactics.vm_cast_no_check c end -let () = define_prim1 "tac_nativecastnocheck" begin fun c -> - Tactics.native_cast_no_check (Value.to_constr c) +let () = define_prim1 "tac_nativecastnocheck" constr begin fun c -> + Tactics.native_cast_no_check c end -let () = define_prim1 "tac_constructor" begin fun ev -> - let ev = Value.to_bool ev in +let () = define_prim1 "tac_constructor" bool begin fun ev -> Tactics.any_constructor ev None end -let () = define_prim3 "tac_constructorn" begin fun ev n bnd -> - let ev = Value.to_bool ev in - let n = Value.to_int n in - let bnd = to_bindings bnd in +let () = define_prim3 "tac_constructorn" bool int bindings begin fun ev n bnd -> Tac2tactics.constructor_tac ev None n bnd end -let () = define_prim2 "tac_specialize" begin fun c ipat -> - let c = to_constr_with_bindings c in - let ipat = Value.to_option to_intro_pattern ipat in +let () = define_prim2 "tac_specialize" constr_with_bindings (option intro_pattern) begin fun c ipat -> Tac2tactics.specialize c ipat end -let () = define_prim1 "tac_symmetry" begin fun cl -> - let cl = to_clause cl in +let () = define_prim1 "tac_symmetry" clause begin fun cl -> Tac2tactics.symmetry cl end -let () = define_prim2 "tac_split" begin fun ev bnd -> - let ev = Value.to_bool ev in - let bnd = to_bindings bnd in +let () = define_prim2 "tac_split" bool bindings begin fun ev bnd -> Tac2tactics.split_with_bindings ev bnd end -let () = define_prim1 "tac_rename" begin fun ids -> - let map c = match Value.to_tuple c with - | [|x; y|] -> (Value.to_ident x, Value.to_ident y) - | _ -> assert false - in - let ids = Value.to_list map ids in +let () = define_prim1 "tac_rename" (list (pair ident ident)) begin fun ids -> Tactics.rename_hyp ids end -let () = define_prim1 "tac_revert" begin fun ids -> - let ids = Value.to_list Value.to_ident ids in +let () = define_prim1 "tac_revert" (list ident) begin fun ids -> Tactics.revert ids end let () = define_prim0 "tac_admit" Proofview.give_up -let () = define_prim2 "tac_fix" begin fun idopt n -> - let idopt = Value.to_option Value.to_ident idopt in - let n = Value.to_int n in +let () = define_prim2 "tac_fix" (option ident) int begin fun idopt n -> Tactics.fix idopt n end -let () = define_prim1 "tac_cofix" begin fun idopt -> - let idopt = Value.to_option Value.to_ident idopt in +let () = define_prim1 "tac_cofix" (option ident) begin fun idopt -> Tactics.cofix idopt end -let () = define_prim1 "tac_clear" begin fun ids -> - let ids = Value.to_list Value.to_ident ids in +let () = define_prim1 "tac_clear" (list ident) begin fun ids -> Tactics.clear ids end -let () = define_prim1 "tac_keep" begin fun ids -> - let ids = Value.to_list Value.to_ident ids in +let () = define_prim1 "tac_keep" (list ident) begin fun ids -> Tactics.keep ids end -let () = define_prim1 "tac_clearbody" begin fun ids -> - let ids = Value.to_list Value.to_ident ids in +let () = define_prim1 "tac_clearbody" (list ident) begin fun ids -> Tactics.clear_body ids end (** Tactics from extratactics *) -let () = define_prim2 "tac_discriminate" begin fun ev arg -> - let ev = Value.to_bool ev in - let arg = Value.to_option to_destruction_arg arg in +let () = define_prim2 "tac_discriminate" bool (option destruction_arg) begin fun ev arg -> Tac2tactics.discriminate ev arg end -let () = define_prim3 "tac_injection" begin fun ev ipat arg -> - let ev = Value.to_bool ev in - let ipat = Value.to_option to_intro_patterns ipat in - let arg = Value.to_option to_destruction_arg arg in +let () = define_prim3 "tac_injection" bool (option intro_patterns) (option destruction_arg) begin fun ev ipat arg -> Tac2tactics.injection ev ipat arg end -let () = define_prim1 "tac_absurd" begin fun c -> - Contradiction.absurd (Value.to_constr c) +let () = define_prim1 "tac_absurd" constr begin fun c -> + Contradiction.absurd c end -let () = define_prim1 "tac_contradiction" begin fun c -> - let c = Value.to_option to_constr_with_bindings c in +let () = define_prim1 "tac_contradiction" (option constr_with_bindings) begin fun c -> Tac2tactics.contradiction c end -let () = define_prim4 "tac_autorewrite" begin fun all by ids cl -> - let all = Value.to_bool all in - let by = Value.to_option (fun tac -> Proofview.tclIGNORE (thaw tac)) by in - let ids = Value.to_list Value.to_ident ids in - let cl = to_clause cl in +let () = define_prim4 "tac_autorewrite" bool (option (thunk unit)) (list ident) clause begin fun all by ids cl -> Tac2tactics.autorewrite ~all by ids cl end -let () = define_prim1 "tac_subst" begin fun ids -> - let ids = Value.to_list Value.to_ident ids in +let () = define_prim1 "tac_subst" (list ident) begin fun ids -> Equality.subst ids end @@ -669,54 +551,28 @@ let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all (** Auto *) -let () = define_prim3 "tac_trivial" begin fun dbg lems dbs -> - let dbg = to_debug dbg in - let map c = thaw c >>= fun c -> return (Value.to_constr c) in - let lems = Value.to_list map lems in - let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in +let () = define_prim3 "tac_trivial" debug (list (thunk constr)) (option (list ident)) begin fun dbg lems dbs -> Tac2tactics.trivial dbg lems dbs end -let () = define_prim5 "tac_eauto" begin fun dbg n p lems dbs -> - let dbg = to_debug dbg in - let n = Value.to_option Value.to_int n in - let p = Value.to_option Value.to_int p in - let map c = thaw c >>= fun c -> return (Value.to_constr c) in - let lems = Value.to_list map lems in - let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in +let () = define_prim5 "tac_eauto" debug (option int) (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n p lems dbs -> Tac2tactics.eauto dbg n p lems dbs end -let () = define_prim4 "tac_auto" begin fun dbg n lems dbs -> - let dbg = to_debug dbg in - let n = Value.to_option Value.to_int n in - let map c = thaw c >>= fun c -> return (Value.to_constr c) in - let lems = Value.to_list map lems in - let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in +let () = define_prim4 "tac_auto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> Tac2tactics.auto dbg n lems dbs end -let () = define_prim4 "tac_newauto" begin fun dbg n lems dbs -> - let dbg = to_debug dbg in - let n = Value.to_option Value.to_int n in - let map c = thaw c >>= fun c -> return (Value.to_constr c) in - let lems = Value.to_list map lems in - let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in +let () = define_prim4 "tac_newauto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> Tac2tactics.new_auto dbg n lems dbs end -let () = define_prim3 "tac_typeclasses_eauto" begin fun str n dbs -> - let str = Value.to_option to_strategy str in - let n = Value.to_option Value.to_int n in - let dbs = Value.to_option (fun l -> Value.to_list Value.to_ident l) dbs in +let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> Tac2tactics.typeclasses_eauto str n dbs end (** Firstorder *) -let () = define_prim3 "tac_firstorder" begin fun tac refs ids -> - let tac = Value.to_option (fun t -> Proofview.tclIGNORE (thaw t)) tac in - let refs = Value.to_list Value.to_reference refs in - let ids = Value.to_list Value.to_ident ids in +let () = define_prim3 "tac_firstorder" (option (thunk unit)) (list reference) (list ident) begin fun tac refs ids -> Tac2tactics.firstorder tac refs ids end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index eec0d2ab45..cd5709b130 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -11,6 +11,7 @@ open Util open Names open Globnames open Tac2types +open Tac2extffi open Genredexpr open Proofview.Notations @@ -92,7 +93,7 @@ let intros_patterns ev ipat = let apply adv ev cb cl = let map c = - let c = c >>= fun c -> return (mk_with_bindings c) in + let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in None, Loc.tag (delayed_of_tactic c) in let cb = List.map map cb in @@ -174,7 +175,7 @@ let rewrite ev rw cl by = in let rw = List.map map_rw rw in let cl = mk_clause cl in - let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE tac, Equality.Naive) by in + let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE (thaw Tac2ffi.unit tac), Equality.Naive) by in Equality.general_multi_rewrite ev rw cl by let symmetry cl = @@ -369,23 +370,25 @@ let autorewrite ~all by ids cl = let cl = mk_clause cl in match by with | None -> Autorewrite.auto_multi_rewrite ?conds ids cl - | Some by -> Autorewrite.auto_multi_rewrite_with ?conds by ids cl + | Some by -> + let by = thaw Tac2ffi.unit by in + Autorewrite.auto_multi_rewrite_with ?conds by ids cl (** Auto *) let trivial debug lems dbs = - let lems = List.map delayed_of_tactic lems in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in Auto.h_trivial ~debug lems dbs let auto debug n lems dbs = - let lems = List.map delayed_of_tactic lems in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in Auto.h_auto ~debug n lems dbs let new_auto debug n lems dbs = let make_depth n = snd (Eauto.make_dimension n None) in - let lems = List.map delayed_of_tactic lems in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in match dbs with | None -> Auto.new_full_auto ~debug (make_depth n) lems | Some dbs -> @@ -393,7 +396,7 @@ let new_auto debug n lems dbs = Auto.new_auto ~debug (make_depth n) lems dbs let eauto debug n p lems dbs = - let lems = List.map delayed_of_tactic lems in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs @@ -447,6 +450,7 @@ let firstorder tac refs ids = let open Ground_plugin in (** FUCK YOU API *) let ids = List.map Id.to_string ids in + let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in let tac : unit API.Proofview.tactic option = Obj.magic (tac : unit Proofview.tactic option) in let refs : API.Globnames.global_reference list = Obj.magic (refs : Globnames.global_reference list) in let ids : API.Hints.hint_db_name list = Obj.magic (ids : Hints.hint_db_name list) in diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 96c7b9214c..52e8a94c19 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -19,7 +19,7 @@ open Proofview val intros_patterns : evars_flag -> intro_pattern list -> unit tactic val apply : advanced_flag -> evars_flag -> - constr_with_bindings tactic list -> + constr_with_bindings thunk list -> (Id.t * intro_pattern option) option -> unit tactic val induction_destruct : rec_flag -> evars_flag -> @@ -43,7 +43,7 @@ val specialize : constr_with_bindings -> intro_pattern option -> unit tactic val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic val rewrite : - evars_flag -> rewriting list -> clause -> unit tactic option -> unit tactic + evars_flag -> rewriting list -> clause -> unit thunk option -> unit tactic val symmetry : clause -> unit tactic @@ -101,18 +101,18 @@ val discriminate : evars_flag -> destruction_arg option -> unit tactic val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic -val autorewrite : all:bool -> unit tactic option -> Id.t list -> clause -> unit tactic +val autorewrite : all:bool -> unit thunk option -> Id.t list -> clause -> unit tactic -val trivial : Hints.debug -> constr tactic list -> Id.t list option -> +val trivial : Hints.debug -> constr thunk list -> Id.t list option -> unit Proofview.tactic -val auto : Hints.debug -> int option -> constr tactic list -> +val auto : Hints.debug -> int option -> constr thunk list -> Id.t list option -> unit Proofview.tactic -val new_auto : Hints.debug -> int option -> constr tactic list -> +val new_auto : Hints.debug -> int option -> constr thunk list -> Id.t list option -> unit Proofview.tactic -val eauto : Hints.debug -> int option -> int option -> constr tactic list -> +val eauto : Hints.debug -> int option -> int option -> constr thunk list -> Id.t list option -> unit Proofview.tactic val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> @@ -122,4 +122,4 @@ val inversion : Misctypes.inversion_kind -> destruction_arg -> intro_pattern opt val contradiction : constr_with_bindings option -> unit tactic -val firstorder : unit Proofview.tactic option -> global_reference list -> Id.t list -> unit tactic +val firstorder : unit thunk option -> global_reference list -> Id.t list -> unit tactic -- cgit v1.2.3 From d0305718b4141aa08675743d4f85238301f37ad7 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 21 Nov 2017 14:15:37 +0100 Subject: [coq] Adapt to Coq's new functional EXTEND API. See https://github.com/coq/coq/pull/6197 --- src/g_ltac2.ml4 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 080fba7103..c738cb65bd 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -831,10 +831,11 @@ let classify_ltac2 = function | StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow | StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernac_classifier.classify_as_sideeff -VERNAC COMMAND EXTEND VernacDeclareTactic2Definition +VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTactic2Definition | [ "Ltac2" ltac2_entry(e) ] => [ classify_ltac2 e ] -> [ - let local = Locality.LocalityFixme.consume () in - Tac2entries.register_struct ?local e + fun ~atts ~st -> let open Vernacinterp in + Tac2entries.register_struct ?local:atts.locality e; + st ] END -- cgit v1.2.3 From 2bd31e5fffbd6722f20016c3962088ab2008e2c0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 24 Nov 2017 19:00:13 +0100 Subject: A possible fix after PR#6158 (raw/glob generic printers for ltac values). Can the printers exploit the ability to now take an environment? --- src/tac2core.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index e476da7259..48cec86540 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -987,9 +987,9 @@ let () = Pretyping.register_constr_interp0 wit_ltac2_quotation interp let () = - let pr_raw id = mt () in - let pr_glb id = str "$" ++ Id.print id in - let pr_top _ = Genprint.PrinterBasic mt in + let pr_raw id = Genprint.PrinterBasic mt in + let pr_glb id = Genprint.PrinterBasic (fun () -> str "$" ++ Id.print id) in + let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top (** Ltac2 in Ltac1 *) @@ -1015,9 +1015,9 @@ let () = Geninterp.register_interp0 wit_ltac2 interp let () = - let pr_raw _ = mt () in - let pr_glb e = Tac2print.pr_glbexpr e in - let pr_top _ = Genprint.PrinterBasic mt in + let pr_raw _ = Genprint.PrinterBasic mt in + let pr_glb e = Genprint.PrinterBasic (fun () -> Tac2print.pr_glbexpr e) in + let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top (** Built-in notation scopes *) -- cgit v1.2.3 From 3c2b1b7f99a1e06ad86a3c5dbf8369d773928e85 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 15 Nov 2017 17:50:51 +0100 Subject: Adapt to removal of match_appsubterm. --- src/tac2core.ml | 4 ++-- src/tac2match.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 48cec86540..d21c1998da 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -561,7 +561,7 @@ let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> Proofview.tclOR (return ans) (fun _ -> of_ans s) in pf_apply begin fun env sigma -> - let ans = Constr_matching.match_appsubterm env sigma pat c in + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in of_ans ans end end @@ -593,7 +593,7 @@ let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c - Proofview.tclOR (return ans) (fun _ -> of_ans s) in pf_apply begin fun env sigma -> - let ans = Constr_matching.match_appsubterm env sigma pat c in + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in of_ans ans end end diff --git a/src/tac2match.ml b/src/tac2match.ml index fef5647725..5035c9dba6 100644 --- a/src/tac2match.ml +++ b/src/tac2match.ml @@ -173,7 +173,7 @@ module PatternMatching (E:StaticEnvironment) = struct | Some nctx -> Proofview.tclOR (k (Some m_ctx) nctx) (fun e -> (map s e).stream k ctx) } in - map (Constr_matching.match_appsubterm E.env E.sigma p term) imatching_error + map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error let hyp_match_type pat hyps = pick hyps >>= fun decl -> -- cgit v1.2.3 From 46dfd18cd1744adbe9fe8463423c5a4484ebeb70 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 25 Dec 2017 21:17:48 +0100 Subject: adapt to API.mli removal --- _CoqProject | 1 - src/g_ltac2.ml4 | 3 +-- src/tac2core.ml | 8 ++------ src/tac2tactics.ml | 6 +----- 4 files changed, 4 insertions(+), 14 deletions(-) diff --git a/_CoqProject b/_CoqProject index eec66dc75e..5af42197ea 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,6 +1,5 @@ -R theories/ Ltac2 -I src/ --bypass-API src/tac2dyn.ml src/tac2dyn.mli diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index c738cb65bd..31eb6d9db5 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -91,8 +91,7 @@ let tac2def_mut = Gram.entry_create "tactic:tac2def_mut" let tac2def_run = Gram.entry_create "tactic:tac2def_run" let tac2mode = Gram.entry_create "vernac:ltac2_command" -(** FUCK YOU API *) -let ltac1_expr = (Obj.magic Pltac.tactic_expr : Tacexpr.raw_tactic_expr Gram.entry) +let ltac1_expr = Pltac.tactic_expr let inj_wit wit loc x = Loc.tag ~loc @@ CTacExt (wit, x) let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c diff --git a/src/tac2core.ml b/src/tac2core.ml index d21c1998da..295b1b24ec 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -945,8 +945,7 @@ let () = let ist = { env_ist = Id.Map.empty } in let lfun = Tac2interp.set_env ist Id.Map.empty in let ist = Ltac_plugin.Tacinterp.default_ist () in - (** FUCK YOU API *) - let ist = { ist with API.Geninterp.lfun = (Obj.magic lfun) } in + let ist = { ist with Geninterp.lfun = lfun } in let tac = (Obj.magic Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in Proofview.tclOR tac wrap >>= fun () -> @@ -995,8 +994,7 @@ let () = (** Ltac2 in Ltac1 *) let () = - (** FUCK YOU API *) - let e = (Obj.magic Tac2entries.Pltac.tac2expr : _ API.Pcoq.Gram.entry) in + let e = Tac2entries.Pltac.tac2expr in let inject (loc, v) = Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) @@ -1004,8 +1002,6 @@ let () = let open Ltac_plugin in let open Tacinterp in let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in - (** FUCK YOU API *) - let idtac = (Obj.magic idtac : Geninterp.Val.t) in let interp ist tac = (* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) let ist = { env_ist = Id.Map.empty } in diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index cd5709b130..e7d5578b6e 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -448,10 +448,6 @@ let contradiction c = let firstorder tac refs ids = let open Ground_plugin in - (** FUCK YOU API *) let ids = List.map Id.to_string ids in let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in - let tac : unit API.Proofview.tactic option = Obj.magic (tac : unit Proofview.tactic option) in - let refs : API.Globnames.global_reference list = Obj.magic (refs : Globnames.global_reference list) in - let ids : API.Hints.hint_db_name list = Obj.magic (ids : Hints.hint_db_name list) in - (Obj.magic (G_ground.gen_ground_tac true tac refs ids : unit API.Proofview.tactic) : unit Proofview.tactic) + G_ground.gen_ground_tac true tac refs ids -- cgit v1.2.3 From 2e015ec8e2958c2848c33a152dd883e048069a7d Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 14 Feb 2018 06:24:02 +0100 Subject: [coq] Adapt to coq/coq#6745 Nothing remarkable. --- src/tac2intern.ml | 4 ++-- src/tac2qexpr.mli | 2 +- src/tac2quote.ml | 2 +- src/tac2tactics.ml | 6 +++--- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 9afdb3aedc..dc142043e8 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -505,7 +505,7 @@ let check_redundant_clause = function let get_variable0 mem var = match var with | RelId (loc, qid) -> let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp && mem id then ArgVar (loc, id) + if DirPath.is_empty dp && mem id then ArgVar CAst.(make ?loc id) else let kn = try Tac2env.locate_ltac qid @@ -652,7 +652,7 @@ let rec intern_rec env (loc, e) = match e with | CTacAtm atm -> intern_atm env atm | CTacRef qid -> begin match get_variable env qid with - | ArgVar (_, id) -> + | ArgVar {CAst.v=id} -> let sch = Id.Map.find id env.env_var in (GTacVar id, fresh_mix_type_scheme env sch) | ArgArg (TacConstant kn) -> diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index ad52884ca6..2f6c97f08b 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -136,7 +136,7 @@ type constr_matching = constr_match_branch list located type goal_match_pattern_r = { q_goal_match_concl : constr_match_pattern; - q_goal_match_hyps : (Name.t located * constr_match_pattern) list; + q_goal_match_hyps : (Misctypes.lname * constr_match_pattern) list; } type goal_match_pattern = goal_match_pattern_r located diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 33c4a97de1..d0c1365eff 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -425,7 +425,7 @@ let of_goal_matching (loc, gm) = let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in let concl = of_tuple [concl_knd; of_pattern concl_pat] in let r = of_tuple [of_list ?loc map hyps_pats; concl] in - let hyps = List.map (fun ((_, na), _, _, _) -> na) hyps_pats in + let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in let map (_, na, _, _) = na in let hctx = List.map map hyps_pats in (** Order of elements is crucial here! *) diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index e7d5578b6e..65cdef0f3f 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -107,7 +107,7 @@ let mk_destruction_arg = function | ElimOnConstr c -> let c = c >>= fun c -> return (mk_with_bindings c) in Misctypes.ElimOnConstr (delayed_of_tactic c) -| ElimOnIdent id -> Misctypes.ElimOnIdent (Loc.tag id) +| ElimOnIdent id -> Misctypes.ElimOnIdent CAst.(make id) | ElimOnAnonHyp n -> Misctypes.ElimOnAnonHyp n let mk_induction_clause (arg, eqn, as_, occ) = @@ -343,7 +343,7 @@ let on_destruction_arg tac ev arg = let flags = tactic_infer_flags ev in let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in Proofview.tclUNIT (Some sigma', Misctypes.ElimOnConstr (c, lbind)) - | ElimOnIdent id -> Proofview.tclUNIT (None, Misctypes.ElimOnIdent (Loc.tag id)) + | ElimOnIdent id -> Proofview.tclUNIT (None, Misctypes.ElimOnIdent CAst.(make id)) | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Misctypes.ElimOnAnonHyp n) in arg >>= fun (sigma', arg) -> @@ -429,7 +429,7 @@ let inversion knd arg pat ids = | None -> assert false | Some (_, Misctypes.ElimOnAnonHyp n) -> Inv.inv_clause knd pat ids (AnonHyp n) - | Some (_, Misctypes.ElimOnIdent (_, id)) -> + | Some (_, Misctypes.ElimOnIdent {CAst.v=id}) -> Inv.inv_clause knd pat ids (NamedHyp id) | Some (_, Misctypes.ElimOnConstr c) -> let open Misctypes in -- cgit v1.2.3 From cf1d983cfd42ae4a7e1e01c6cab348fc51233c65 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 6 Feb 2018 18:19:15 +0100 Subject: adapt to Coq#6676 --- src/tac2core.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 295b1b24ec..1afaea8bd9 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -514,9 +514,9 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.Unsafe.tclSETGOALS [evk] >>= fun () -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> thaw c >>= fun _ -> - Proofview.Unsafe.tclSETGOALS [Proofview.Goal.goal (Proofview.Goal.assume gl)] >>= fun () -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal (Proofview.Goal.assume gl))] >>= fun () -> let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in let args = Array.of_list (EConstr.mkRel 1 :: args) in let ans = EConstr.mkEvar (evk, args) in @@ -700,7 +700,7 @@ let () = define1 "new_goal" int begin fun ev -> let ev = Evar.unsafe_of_int ev in Proofview.tclEVARMAP >>= fun sigma -> if Evd.mem sigma ev then - Proofview.Unsafe.tclNEWGOALS [ev] <*> Proofview.tclUNIT v_unit + Proofview.Unsafe.tclNEWGOALS [Proofview.with_empty_state ev] <*> Proofview.tclUNIT v_unit else throw err_notfound end -- cgit v1.2.3 From 5cb74f82165e88c5e527ad757b007df1fbe5f1b3 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 14 Feb 2018 02:05:42 +0100 Subject: [api] Remove some deprecation warnings. Trivial commit. --- src/tac2core.ml | 4 +++- src/tac2ffi.mli | 2 +- src/tac2quote.ml | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 1afaea8bd9..c16e72b801 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -894,7 +894,9 @@ let () = let () = let intern self ist c = - let _, pat = Constrintern.intern_constr_pattern ist.Genintern.genv ~as_type:false c in + let env = ist.Genintern.genv in + let sigma = Evd.from_env env in + let _, pat = Constrintern.intern_constr_pattern env sigma ~as_type:false c in GlbVal pat, gtypref t_pattern in let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 4d77c989f3..1bf86b516a 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -165,7 +165,7 @@ val val_constant : Constant.t Val.tag val val_constructor : constructor Val.tag val val_projection : Projection.t Val.tag val val_case : Constr.case_info Val.tag -val val_univ : Univ.universe_level Val.tag +val val_univ : Univ.Level.t Val.tag val val_free : Id.Set.t Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag diff --git a/src/tac2quote.ml b/src/tac2quote.ml index d0c1365eff..829f13344c 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -221,7 +221,7 @@ let pattern_vars pat = let () = check_pattern_id ?loc:pat.CAst.loc id in Id.Set.add id accu | _ -> - Topconstr.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat + Constrexpr_ops.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat in aux () Id.Set.empty pat -- cgit v1.2.3 From ba27c2e21f80b41dfd837e6c6b15f82ca405cf04 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 14 Feb 2018 02:06:02 +0100 Subject: [coq] Adapt to coq/coq#6511 coq/coq#6511 contains EConstr-related changes. --- src/tac2entries.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index e48bf02321..fa498ab44f 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -344,7 +344,7 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = in let () = if exists then - user_err ?loc (str "Tactic " ++ Nameops.pr_id id ++ str " already exists") + user_err ?loc (str "Tactic " ++ Names.Id.print id ++ str " already exists") in (id, e, t) in @@ -539,7 +539,7 @@ let parse_scope = function if Id.Map.mem id !scope_table then Id.Map.find id !scope_table toks else - CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Nameops.pr_id id) + CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) | SexprStr (_, str) -> let v_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) in ScopeRule (Extend.Atoken (Tok.IDENT str), (fun _ -> v_unit)) -- cgit v1.2.3 From bfa24f9435d5ebeb9c5abb81b8ae0ef7e305f83f Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 5 Mar 2018 23:48:50 +0100 Subject: [coq] Adapt to correct LTAC module packing coq/coq#6869 --- src/tac2core.ml | 2 +- src/tac2quote.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index c16e72b801..62fc9db292 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -997,7 +997,7 @@ let () = let () = let e = Tac2entries.Pltac.tac2expr in - let inject (loc, v) = Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in + let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) let () = diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 3f6c9a55e5..1f22fe6c74 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -99,4 +99,4 @@ val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag -val wit_ltac1 : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr) Arg.tag +val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag -- cgit v1.2.3 From d2d1fe30e3defa18dd966bf8160df81fc1e72e31 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 9 Mar 2018 10:27:39 -0300 Subject: Fix compilation after the change of API in options. --- src/tac2entries.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index fa498ab44f..1631880c71 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -919,7 +919,7 @@ let load_ltac2_init _ (_, ()) = Hook.get f_register_constr_quotations () let open_ltac2_init _ (_, ()) = - Goptions.set_string_option_value_gen None ["Default"; "Proof"; "Mode"] "Ltac2" + Goptions.set_string_option_value_gen ["Default"; "Proof"; "Mode"] "Ltac2" (** Dummy object that register global rules when Require is called *) let inTac2Init : unit -> obj = -- cgit v1.2.3 From 123de18a0886233b047ef2bad4bd7b3694f2abcc Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 5 Mar 2018 22:10:45 +0100 Subject: [coq] Adapt to coq/coq#6831. This removes uses of `Loc.t` in favor of `CAst.t`. --- src/g_ltac2.ml4 | 302 ++++++++++++++++++++++++++-------------------------- src/tac2core.ml | 31 +++--- src/tac2entries.ml | 94 ++++++++-------- src/tac2entries.mli | 11 +- src/tac2expr.mli | 24 ++--- src/tac2intern.ml | 173 +++++++++++++++--------------- src/tac2intern.mli | 3 - src/tac2qexpr.mli | 99 +++++++++-------- src/tac2quote.ml | 129 +++++++++++----------- src/tac2quote.mli | 17 ++- src/tac2tactics.ml | 24 ++--- 11 files changed, 447 insertions(+), 460 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 31eb6d9db5..f4818f4ece 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -93,17 +93,17 @@ let tac2mode = Gram.entry_create "vernac:ltac2_command" let ltac1_expr = Pltac.tactic_expr -let inj_wit wit loc x = Loc.tag ~loc @@ CTacExt (wit, x) +let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e let pattern_of_qualid ?loc id = - if Tac2env.is_constructor (snd id) then Loc.tag ?loc @@ CPatRef (RelId id, []) + if Tac2env.is_constructor id.CAst.v then CAst.make ?loc @@ CPatRef (RelId id, []) else - let (dp, id) = Libnames.repr_qualid (snd id) in - if DirPath.is_empty dp then Loc.tag ?loc @@ CPatVar (Name id) + let (dp, id) = Libnames.repr_qualid id.CAst.v in + if DirPath.is_empty dp then CAst.make ?loc @@ CPatVar (Name id) else CErrors.user_err ?loc (Pp.str "Syntax error") @@ -113,73 +113,73 @@ GEXTEND Gram tac2pat: [ "1" LEFTA [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> - if Tac2env.is_constructor (snd id) then - Loc.tag ~loc:!@loc @@ CPatRef (RelId id, pl) + if Tac2env.is_constructor (id.CAst.v) then + CAst.make ~loc:!@loc @@ CPatRef (RelId id, pl) else CErrors.user_err ~loc:!@loc (Pp.str "Syntax error") | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id - | "["; "]" -> Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) + | "["; "]" -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) | p1 = tac2pat; "::"; p2 = tac2pat -> - Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) + CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) ] | "0" - [ "_" -> Loc.tag ~loc:!@loc @@ CPatVar Anonymous - | "()" -> Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) + [ "_" -> CAst.make ~loc:!@loc @@ CPatVar Anonymous + | "()" -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id | "("; p = atomic_tac2pat; ")" -> p ] ] ; atomic_tac2pat: [ [ -> - Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) + CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) | p = tac2pat; ":"; t = tac2type -> - Loc.tag ~loc:!@loc @@ CPatCnv (p, t) + CAst.make ~loc:!@loc @@ CPatCnv (p, t) | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> let pl = p :: pl in - Loc.tag ~loc:!@loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) + CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) | p = tac2pat -> p ] ] ; tac2expr: [ "6" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> Loc.tag ~loc:!@loc @@ CTacSeq (e1, e2) ] + [ e1 = SELF; ";"; e2 = SELF -> CAst.make ~loc:!@loc @@ CTacSeq (e1, e2) ] | "5" [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> - Loc.tag ~loc:!@loc @@ CTacFun (it, body) + CAst.make ~loc:!@loc @@ CTacFun (it, body) | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; e = tac2expr LEVEL "6" -> - Loc.tag ~loc:!@loc @@ CTacLet (isrec, lc, e) + CAst.make ~loc:!@loc @@ CTacLet (isrec, lc, e) | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> - Loc.tag ~loc:!@loc @@ CTacCse (e, bl) + CAst.make ~loc:!@loc @@ CTacCse (e, bl) ] | "4" LEFTA [ ] | "::" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> - Loc.tag ~loc:!@loc @@ CTacApp (Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) + CAst.make ~loc:!@loc @@ CTacApp (CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) ] | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> let el = e0 :: el in - Loc.tag ~loc:!@loc @@ CTacApp (Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) ] + CAst.make ~loc:!@loc @@ CTacApp (CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) ] | "1" LEFTA [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> - Loc.tag ~loc:!@loc @@ CTacApp (e, el) + CAst.make ~loc:!@loc @@ CTacApp (e, el) | e = SELF; ".("; qid = Prim.qualid; ")" -> - Loc.tag ~loc:!@loc @@ CTacPrj (e, RelId qid) + CAst.make ~loc:!@loc @@ CTacPrj (e, RelId qid) | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> - Loc.tag ~loc:!@loc @@ CTacSet (e, RelId qid, r) ] + CAst.make ~loc:!@loc @@ CTacSet (e, RelId qid, r) ] | "0" [ "("; a = SELF; ")" -> a | "("; a = SELF; ":"; t = tac2type; ")" -> - Loc.tag ~loc:!@loc @@ CTacCnv (a, t) + CAst.make ~loc:!@loc @@ CTacCnv (a, t) | "()" -> - Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) + CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) | "("; ")" -> - Loc.tag ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) + CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> Tac2quote.of_list ~loc:!@loc (fun x -> x) a | "{"; a = tac2rec_fieldexprs; "}" -> - Loc.tag ~loc:!@loc @@ CTacRec a + CAst.make ~loc:!@loc @@ CTacRec a | a = tactic_atom -> a ] ] ; @@ -204,14 +204,14 @@ GEXTEND Gram [ [ "'"; id = Prim.ident -> id ] ] ; tactic_atom: - [ [ n = Prim.integer -> Loc.tag ~loc:!@loc @@ CTacAtm (AtmInt n) - | s = Prim.string -> Loc.tag ~loc:!@loc @@ CTacAtm (AtmStr s) + [ [ n = Prim.integer -> CAst.make ~loc:!@loc @@ CTacAtm (AtmInt n) + | s = Prim.string -> CAst.make ~loc:!@loc @@ CTacAtm (AtmStr s) | id = Prim.qualid -> - if Tac2env.is_constructor (snd id) then - Loc.tag ~loc:!@loc @@ CTacCst (RelId id) + if Tac2env.is_constructor id.CAst.v then + CAst.make ~loc:!@loc @@ CTacCst (RelId id) else - Loc.tag ~loc:!@loc @@ CTacRef (RelId id) - | "@"; id = Prim.ident -> Tac2quote.of_ident (Loc.tag ~loc:!@loc id) + CAst.make ~loc:!@loc @@ CTacRef (RelId id) + | "@"; id = Prim.ident -> Tac2quote.of_ident (CAst.make ~loc:!@loc id) | "&"; id = lident -> Tac2quote.of_hyp ~loc:!@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_constr c @@ -227,7 +227,7 @@ GEXTEND Gram let (pat, fn) = binder in let te = match fn with | None -> te - | Some args -> Loc.tag ~loc:!@loc @@ CTacFun (args, te) + | Some args -> CAst.make ~loc:!@loc @@ CTacFun (args, te) in (pat, te) ] ] @@ -235,42 +235,42 @@ GEXTEND Gram let_binder: [ [ pats = LIST1 input_fun -> match pats with - | [(_, CPatVar _) as pat] -> (pat, None) - | ((_, CPatVar (Name id)) as pat) :: args -> (pat, Some args) + | [{CAst.v=CPatVar _} as pat] -> (pat, None) + | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) | [pat] -> (pat, None) | _ -> CErrors.user_err ~loc:!@loc (str "Invalid pattern") ] ] ; tac2type: [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> Loc.tag ~loc:!@loc @@ CTypArrow (t1, t2) ] + [ t1 = tac2type; "->"; t2 = tac2type -> CAst.make ~loc:!@loc @@ CTypArrow (t1, t2) ] | "2" [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> let tl = t :: tl in - Loc.tag ~loc:!@loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) ] + CAst.make ~loc:!@loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) ] | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> Loc.tag ~loc:!@loc @@ CTypRef (RelId qid, [t]) ] + [ t = SELF; qid = Prim.qualid -> CAst.make ~loc:!@loc @@ CTypRef (RelId qid, [t]) ] | "0" [ "("; t = tac2type LEVEL "5"; ")" -> t - | id = typ_param -> Loc.tag ~loc:!@loc @@ CTypVar (Name id) - | "_" -> Loc.tag ~loc:!@loc @@ CTypVar Anonymous - | qid = Prim.qualid -> Loc.tag ~loc:!@loc @@ CTypRef (RelId qid, []) + | id = typ_param -> CAst.make ~loc:!@loc @@ CTypVar (Name id) + | "_" -> CAst.make ~loc:!@loc @@ CTypVar Anonymous + | qid = Prim.qualid -> CAst.make ~loc:!@loc @@ CTypRef (RelId qid, []) | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - Loc.tag ~loc:!@loc @@ CTypRef (RelId qid, p) ] + CAst.make ~loc:!@loc @@ CTypRef (RelId qid, p) ] ]; locident: - [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] + [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] ; binder: - [ [ "_" -> Loc.tag ~loc:!@loc Anonymous - | l = Prim.ident -> Loc.tag ~loc:!@loc (Name l) ] ] + [ [ "_" -> CAst.make ~loc:!@loc Anonymous + | l = Prim.ident -> CAst.make ~loc:!@loc (Name l) ] ] ; input_fun: [ [ b = tac2pat LEVEL "0" -> b ] ] ; tac2def_body: [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> - let e = if List.is_empty it then e else Loc.tag ~loc:!@loc @@ CTacFun (it, e) in + let e = if List.is_empty it then e else CAst.make ~loc:!@loc @@ CTacFun (it, e) in (name, e) ] ] ; @@ -319,8 +319,8 @@ GEXTEND Gram ; tac2typ_prm: [ [ -> [] - | id = typ_param -> [Loc.tag ~loc:!@loc id] - | "("; ids = LIST1 [ id = typ_param -> Loc.tag ~loc:!@loc id ] SEP "," ;")" -> ids + | id = typ_param -> [CAst.make ~loc:!@loc id] + | "("; ids = LIST1 [ id = typ_param -> CAst.make ~loc:!@loc id ] SEP "," ;")" -> ids ] ] ; tac2typ_def: @@ -345,13 +345,13 @@ GEXTEND Gram ] ] ; syn_node: - [ [ "_" -> Loc.tag ~loc:!@loc None - | id = Prim.ident -> Loc.tag ~loc:!@loc (Some id) + [ [ "_" -> CAst.make ~loc:!@loc None + | id = Prim.ident -> CAst.make ~loc:!@loc (Some id) ] ] ; sexpr: - [ [ s = Prim.string -> SexprStr (Loc.tag ~loc:!@loc s) - | n = Prim.integer -> SexprInt (Loc.tag ~loc:!@loc n) + [ [ s = Prim.string -> SexprStr (CAst.make ~loc:!@loc s) + | n = Prim.integer -> SexprInt (CAst.make ~loc:!@loc n) | id = syn_node -> SexprRec (!@loc, id, []) | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> SexprRec (!@loc, id, tok) @@ -369,11 +369,11 @@ GEXTEND Gram ] ] ; lident: - [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] + [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] ; globref: [ [ "&"; id = Prim.ident -> Libnames.Ident (Loc.tag ~loc:!@loc id) - | qid = Prim.qualid -> Libnames.Qualid qid + | qid = Prim.qualid -> Libnames.Qualid (Loc.tag ~loc:!@loc qid.CAst.v) ] ] ; END @@ -390,38 +390,38 @@ GEXTEND Gram q_destruction_arg q_reference q_with_bindings q_constr_matching q_goal_matching q_hintdb q_move_location q_pose q_assert; anti: - [ [ "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) ] ] + [ [ "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; ident_or_anti: [ [ id = lident -> QExpr id - | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; lident: - [ [ id = Prim.ident -> Loc.tag ~loc:!@loc id ] ] + [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] ; lnatural: - [ [ n = Prim.natural -> Loc.tag ~loc:!@loc n ] ] + [ [ n = Prim.natural -> CAst.make ~loc:!@loc n ] ] ; q_ident: [ [ id = ident_or_anti -> id ] ] ; qhyp: [ [ x = anti -> x - | n = lnatural -> QExpr (Loc.tag ~loc:!@loc @@ QAnonHyp n) - | id = lident -> QExpr (Loc.tag ~loc:!@loc @@ QNamedHyp id) + | n = lnatural -> QExpr (CAst.make ~loc:!@loc @@ QAnonHyp n) + | id = lident -> QExpr (CAst.make ~loc:!@loc @@ QNamedHyp id) ] ] ; simple_binding: [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (h, c) + CAst.make ~loc:!@loc (h, c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - Loc.tag ~loc:!@loc @@ QExplicitBindings bl + CAst.make ~loc:!@loc @@ QExplicitBindings bl | bl = LIST1 Constr.constr -> - Loc.tag ~loc:!@loc @@ QImplicitBindings bl + CAst.make ~loc:!@loc @@ QImplicitBindings bl ] ] ; q_bindings: @@ -431,53 +431,53 @@ GEXTEND Gram [ [ bl = with_bindings -> bl ] ] ; intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> Loc.tag ~loc:!@loc l ]] + [ [ l = LIST0 nonsimple_intropattern -> CAst.make ~loc:!@loc l ]] ; (* ne_intropatterns: *) (* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) (* ; *) or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> Loc.tag ~loc:!@loc @@ QIntroOrPattern tc - | "()" -> Loc.tag ~loc:!@loc @@ QIntroAndPattern (Loc.tag ~loc:!@loc []) - | "("; si = simple_intropattern; ")" -> Loc.tag ~loc:!@loc @@ QIntroAndPattern (Loc.tag ~loc:!@loc [si]) + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> CAst.make ~loc:!@loc @@ QIntroOrPattern tc + | "()" -> CAst.make ~loc:!@loc @@ QIntroAndPattern (CAst.make ~loc:!@loc []) + | "("; si = simple_intropattern; ")" -> CAst.make ~loc:!@loc @@ QIntroAndPattern (CAst.make ~loc:!@loc [si]) | "("; si = simple_intropattern; ","; tc = LIST1 simple_intropattern SEP "," ; ")" -> - Loc.tag ~loc:!@loc @@ QIntroAndPattern (Loc.tag ~loc:!@loc (si::tc)) + CAst.make ~loc:!@loc @@ QIntroAndPattern (CAst.make ~loc:!@loc (si::tc)) | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function - | ([]|[_]|[_;_]) as l -> Loc.tag ~loc:!@loc l + | ([]|[_]|[_;_]) as l -> CAst.make ~loc:!@loc l | t::q -> let q = - Loc.tag ~loc:!@loc @@ - QIntroAction (Loc.tag ~loc:!@loc @@ - QIntroOrAndPattern (Loc.tag ~loc:!@loc @@ + CAst.make ~loc:!@loc @@ + QIntroAction (CAst.make ~loc:!@loc @@ + QIntroOrAndPattern (CAst.make ~loc:!@loc @@ QIntroAndPattern (pairify q))) in - Loc.tag ~loc:!@loc [t; q] - in Loc.tag ~loc:!@loc @@ QIntroAndPattern (pairify (si::tc)) ] ] + CAst.make ~loc:!@loc [t; q] + in CAst.make ~loc:!@loc @@ QIntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: - [ [ "->" -> Loc.tag ~loc:!@loc @@ QIntroRewrite true - | "<-" -> Loc.tag ~loc:!@loc @@ QIntroRewrite false - | "[="; tc = intropatterns; "]" -> Loc.tag ~loc:!@loc @@ QIntroInjection tc ] ] + [ [ "->" -> CAst.make ~loc:!@loc @@ QIntroRewrite true + | "<-" -> CAst.make ~loc:!@loc @@ QIntroRewrite false + | "[="; tc = intropatterns; "]" -> CAst.make ~loc:!@loc @@ QIntroInjection tc ] ] ; naming_intropattern: [ [ LEFTQMARK; id = lident -> - Loc.tag ~loc:!@loc @@ QIntroFresh (QExpr id) + CAst.make ~loc:!@loc @@ QIntroFresh (QExpr id) | "?$"; id = lident -> - Loc.tag ~loc:!@loc @@ QIntroFresh (QAnti id) + CAst.make ~loc:!@loc @@ QIntroFresh (QAnti id) | "?" -> - Loc.tag ~loc:!@loc @@ QIntroAnonymous + CAst.make ~loc:!@loc @@ QIntroAnonymous | id = ident_or_anti -> - Loc.tag ~loc:!@loc @@ QIntroIdentifier id + CAst.make ~loc:!@loc @@ QIntroIdentifier id ] ] ; nonsimple_intropattern: [ [ l = simple_intropattern -> l - | "*" -> Loc.tag ~loc:!@loc @@ QIntroForthcoming true - | "**" -> Loc.tag ~loc:!@loc @@ QIntroForthcoming false ]] + | "*" -> CAst.make ~loc:!@loc @@ QIntroForthcoming true + | "**" -> CAst.make ~loc:!@loc @@ QIntroForthcoming false ]] ; simple_intropattern: [ [ pat = simple_intropattern_closed -> @@ -488,13 +488,13 @@ GEXTEND Gram ; simple_intropattern_closed: [ [ pat = or_and_intropattern -> - Loc.tag ~loc:!@loc @@ QIntroAction (Loc.tag ~loc:!@loc @@ QIntroOrAndPattern pat) + CAst.make ~loc:!@loc @@ QIntroAction (CAst.make ~loc:!@loc @@ QIntroOrAndPattern pat) | pat = equality_intropattern -> - Loc.tag ~loc:!@loc @@ QIntroAction pat + CAst.make ~loc:!@loc @@ QIntroAction pat | "_" -> - Loc.tag ~loc:!@loc @@ QIntroAction (Loc.tag ~loc:!@loc @@ QIntroWildcard) + CAst.make ~loc:!@loc @@ QIntroAction (CAst.make ~loc:!@loc @@ QIntroWildcard) | pat = naming_intropattern -> - Loc.tag ~loc:!@loc @@ QIntroNaming pat + CAst.make ~loc:!@loc @@ QIntroNaming pat ] ] ; q_intropatterns: @@ -505,7 +505,7 @@ GEXTEND Gram ; nat_or_anti: [ [ n = lnatural -> QExpr n - | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; eqn_ipat: @@ -514,15 +514,15 @@ GEXTEND Gram ] ] ; with_bindings: - [ [ "with"; bl = bindings -> bl | -> Loc.tag ~loc:!@loc @@ QNoBindings ] ] + [ [ "with"; bl = bindings -> bl | -> CAst.make ~loc:!@loc @@ QNoBindings ] ] ; constr_with_bindings: - [ [ c = Constr.constr; l = with_bindings -> Loc.tag ~loc:!@loc @@ (c, l) ] ] + [ [ c = Constr.constr; l = with_bindings -> CAst.make ~loc:!@loc @@ (c, l) ] ] ; destruction_arg: - [ [ n = lnatural -> Loc.tag ~loc:!@loc @@ QElimOnAnonHyp n - | id = lident -> Loc.tag ~loc:!@loc @@ QElimOnIdent id - | c = constr_with_bindings -> Loc.tag ~loc:!@loc @@ QElimOnConstr c + [ [ n = lnatural -> CAst.make ~loc:!@loc @@ QElimOnAnonHyp n + | id = lident -> CAst.make ~loc:!@loc @@ QElimOnIdent id + | c = constr_with_bindings -> CAst.make ~loc:!@loc @@ QElimOnConstr c ] ] ; q_destruction_arg: @@ -534,13 +534,13 @@ GEXTEND Gram ] ] ; occs_nums: - [ [ nl = LIST1 nat_or_anti -> Loc.tag ~loc:!@loc @@ QOnlyOccurrences nl + [ [ nl = LIST1 nat_or_anti -> CAst.make ~loc:!@loc @@ QOnlyOccurrences nl | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> - Loc.tag ~loc:!@loc @@ QAllOccurrencesBut (n::nl) + CAst.make ~loc:!@loc @@ QAllOccurrencesBut (n::nl) ] ] ; occs: - [ [ "at"; occs = occs_nums -> occs | -> Loc.tag ~loc:!@loc QAllOccurrences ] ] + [ [ "at"; occs = occs_nums -> occs | -> CAst.make ~loc:!@loc QAllOccurrences ] ] ; hypident: [ [ id = ident_or_anti -> @@ -562,13 +562,13 @@ GEXTEND Gram | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> { q_onhyps = Some hl; q_concl_occs = occs } | hl = LIST0 hypident_occ SEP "," -> - { q_onhyps = Some hl; q_concl_occs = Loc.tag ~loc:!@loc QNoOccurrences } + { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc:!@loc QNoOccurrences } ] ] ; clause: - [ [ "in"; cl = in_clause -> Loc.tag ~loc:!@loc @@ cl + [ [ "in"; cl = in_clause -> CAst.make ~loc:!@loc @@ cl | "at"; occs = occs_nums -> - Loc.tag ~loc:!@loc @@ { q_onhyps = Some []; q_concl_occs = occs } + CAst.make ~loc:!@loc @@ { q_onhyps = Some []; q_concl_occs = occs } ] ] ; q_clause: @@ -576,13 +576,13 @@ GEXTEND Gram ; concl_occ: [ [ "*"; occs = occs -> occs - | -> Loc.tag ~loc:!@loc QNoOccurrences + | -> CAst.make ~loc:!@loc QNoOccurrences ] ] ; induction_clause: [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; cl = OPT clause -> - Loc.tag ~loc:!@loc @@ { + CAst.make ~loc:!@loc @@ { indcl_arg = c; indcl_eqn = eq; indcl_as = pat; @@ -595,38 +595,38 @@ GEXTEND Gram ; conversion: [ [ c = Constr.constr -> - Loc.tag ~loc:!@loc @@ QConvert c + CAst.make ~loc:!@loc @@ QConvert c | c1 = Constr.constr; "with"; c2 = Constr.constr -> - Loc.tag ~loc:!@loc @@ QConvertWith (c1, c2) + CAst.make ~loc:!@loc @@ QConvertWith (c1, c2) ] ] ; q_conversion: [ [ c = conversion -> c ] ] ; orient: - [ [ "->" -> Loc.tag ~loc:!@loc (Some true) - | "<-" -> Loc.tag ~loc:!@loc (Some false) - | -> Loc.tag ~loc:!@loc None + [ [ "->" -> CAst.make ~loc:!@loc (Some true) + | "<-" -> CAst.make ~loc:!@loc (Some false) + | -> CAst.make ~loc:!@loc None ]] ; rewriter: [ [ "!"; c = constr_with_bindings -> - (Loc.tag ~loc:!@loc @@ QRepeatPlus,c) + (CAst.make ~loc:!@loc @@ QRepeatPlus,c) | ["?"| LEFTQMARK]; c = constr_with_bindings -> - (Loc.tag ~loc:!@loc @@ QRepeatStar,c) + (CAst.make ~loc:!@loc @@ QRepeatStar,c) | n = lnatural; "!"; c = constr_with_bindings -> - (Loc.tag ~loc:!@loc @@ QPrecisely n,c) + (CAst.make ~loc:!@loc @@ QPrecisely n,c) | n = lnatural; ["?" | LEFTQMARK]; c = constr_with_bindings -> - (Loc.tag ~loc:!@loc @@ QUpTo n,c) + (CAst.make ~loc:!@loc @@ QUpTo n,c) | n = lnatural; c = constr_with_bindings -> - (Loc.tag ~loc:!@loc @@ QPrecisely n,c) + (CAst.make ~loc:!@loc @@ QPrecisely n,c) | c = constr_with_bindings -> - (Loc.tag ~loc:!@loc @@ QPrecisely (Loc.tag 1), c) + (CAst.make ~loc:!@loc @@ QPrecisely (CAst.make 1), c) ] ] ; oriented_rewriter: [ [ b = orient; (m, c) = rewriter -> - Loc.tag ~loc:!@loc @@ { + CAst.make ~loc:!@loc @@ { rew_orient = b; rew_repeat = m; rew_equatn = c; @@ -651,52 +651,52 @@ GEXTEND Gram ] ] ; q_dispatch: - [ [ d = tactic_then_gen -> Loc.tag ~loc:!@loc d ] ] + [ [ d = tactic_then_gen -> CAst.make ~loc:!@loc d ] ] ; q_occurrences: [ [ occs = occs -> occs ] ] ; red_flag: - [ [ IDENT "beta" -> Loc.tag ~loc:!@loc @@ QBeta - | IDENT "iota" -> Loc.tag ~loc:!@loc @@ QIota - | IDENT "match" -> Loc.tag ~loc:!@loc @@ QMatch - | IDENT "fix" -> Loc.tag ~loc:!@loc @@ QFix - | IDENT "cofix" -> Loc.tag ~loc:!@loc @@ QCofix - | IDENT "zeta" -> Loc.tag ~loc:!@loc @@ QZeta + [ [ IDENT "beta" -> CAst.make ~loc:!@loc @@ QBeta + | IDENT "iota" -> CAst.make ~loc:!@loc @@ QIota + | IDENT "match" -> CAst.make ~loc:!@loc @@ QMatch + | IDENT "fix" -> CAst.make ~loc:!@loc @@ QFix + | IDENT "cofix" -> CAst.make ~loc:!@loc @@ QCofix + | IDENT "zeta" -> CAst.make ~loc:!@loc @@ QZeta | IDENT "delta"; d = delta_flag -> d ] ] ; refglobal: [ [ "&"; id = Prim.ident -> QExpr (Libnames.Ident (Loc.tag ~loc:!@loc id)) - | qid = Prim.qualid -> QExpr (Libnames.Qualid qid) - | "$"; id = Prim.ident -> QAnti (Loc.tag ~loc:!@loc id) + | qid = Prim.qualid -> QExpr (Libnames.Qualid Loc.(tag ~loc:!@loc qid.CAst.v)) + | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; q_reference: [ [ r = refglobal -> r ] ] ; refglobals: - [ [ gl = LIST1 refglobal -> Loc.tag ~loc:!@loc gl ] ] + [ [ gl = LIST1 refglobal -> CAst.make ~loc:!@loc gl ] ] ; delta_flag: - [ [ "-"; "["; idl = refglobals; "]" -> Loc.tag ~loc:!@loc @@ QDeltaBut idl - | "["; idl = refglobals; "]" -> Loc.tag ~loc:!@loc @@ QConst idl - | -> Loc.tag ~loc:!@loc @@ QDeltaBut (Loc.tag ~loc:!@loc []) + [ [ "-"; "["; idl = refglobals; "]" -> CAst.make ~loc:!@loc @@ QDeltaBut idl + | "["; idl = refglobals; "]" -> CAst.make ~loc:!@loc @@ QConst idl + | -> CAst.make ~loc:!@loc @@ QDeltaBut (CAst.make ~loc:!@loc []) ] ] ; strategy_flag: - [ [ s = LIST1 red_flag -> Loc.tag ~loc:!@loc s + [ [ s = LIST1 red_flag -> CAst.make ~loc:!@loc s | d = delta_flag -> - Loc.tag ~loc:!@loc - [Loc.tag ~loc:!@loc QBeta; Loc.tag ~loc:!@loc QIota; Loc.tag ~loc:!@loc QZeta; d] + CAst.make ~loc:!@loc + [CAst.make ~loc:!@loc QBeta; CAst.make ~loc:!@loc QIota; CAst.make ~loc:!@loc QZeta; d] ] ] ; q_strategy_flag: [ [ flag = strategy_flag -> flag ] ] ; hintdb: - [ [ "*" -> Loc.tag ~loc:!@loc @@ QHintAll - | l = LIST1 ident_or_anti -> Loc.tag ~loc:!@loc @@ QHintDbs l + [ [ "*" -> CAst.make ~loc:!@loc @@ QHintAll + | l = LIST1 ident_or_anti -> CAst.make ~loc:!@loc @@ QHintDbs l ] ] ; q_hintdb: @@ -704,17 +704,17 @@ GEXTEND Gram ; match_pattern: [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> Loc.tag ~loc:!@loc @@ QConstrMatchContext (id, pat) - | pat = Constr.lconstr_pattern -> Loc.tag ~loc:!@loc @@ QConstrMatchPattern pat ] ] + "["; pat = Constr.lconstr_pattern; "]" -> CAst.make ~loc:!@loc @@ QConstrMatchContext (id, pat) + | pat = Constr.lconstr_pattern -> CAst.make ~loc:!@loc @@ QConstrMatchPattern pat ] ] ; match_rule: [ [ mp = match_pattern; "=>"; tac = tac2expr -> - Loc.tag ~loc:!@loc @@ (mp, tac) + CAst.make ~loc:!@loc @@ (mp, tac) ] ] ; match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl ] ] + [ [ mrl = LIST1 match_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl ] ] ; q_constr_matching: [ [ m = match_list -> m ] ] @@ -724,7 +724,7 @@ GEXTEND Gram ; gmatch_pattern: [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> - Loc.tag ~loc:!@loc @@ { + CAst.make ~loc:!@loc @@ { q_goal_match_concl = p; q_goal_match_hyps = hl; } @@ -732,21 +732,21 @@ GEXTEND Gram ; gmatch_rule: [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> - Loc.tag ~loc:!@loc @@ (mp, tac) + CAst.make ~loc:!@loc @@ (mp, tac) ] ] ; gmatch_list: - [ [ mrl = LIST1 gmatch_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl - | "|"; mrl = LIST1 gmatch_rule SEP "|" -> Loc.tag ~loc:!@loc @@ mrl ] ] + [ [ mrl = LIST1 gmatch_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl + | "|"; mrl = LIST1 gmatch_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl ] ] ; q_goal_matching: [ [ m = gmatch_list -> m ] ] ; move_location: - [ [ "at"; IDENT "top" -> Loc.tag ~loc:!@loc @@ QMoveFirst - | "at"; IDENT "bottom" -> Loc.tag ~loc:!@loc @@ QMoveLast - | IDENT "after"; id = ident_or_anti -> Loc.tag ~loc:!@loc @@ QMoveAfter id - | IDENT "before"; id = ident_or_anti -> Loc.tag ~loc:!@loc @@ QMoveBefore id + [ [ "at"; IDENT "top" -> CAst.make ~loc:!@loc @@ QMoveFirst + | "at"; IDENT "bottom" -> CAst.make ~loc:!@loc @@ QMoveLast + | IDENT "after"; id = ident_or_anti -> CAst.make ~loc:!@loc @@ QMoveAfter id + | IDENT "before"; id = ident_or_anti -> CAst.make ~loc:!@loc @@ QMoveBefore id ] ] ; q_move_location: @@ -759,8 +759,8 @@ GEXTEND Gram ; pose: [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (Some id, c) - | c = Constr.constr; na = as_name -> Loc.tag ~loc:!@loc (na, c) + CAst.make ~loc:!@loc (Some id, c) + | c = Constr.constr; na = as_name -> CAst.make ~loc:!@loc (na, c) ] ] ; q_pose: @@ -778,13 +778,13 @@ GEXTEND Gram ; assertion: [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - Loc.tag ~loc:!@loc (QAssertValue (id, c)) + CAst.make ~loc:!@loc (QAssertValue (id, c)) | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> let loc = !@loc in - let ipat = Loc.tag ~loc @@ QIntroNaming (Loc.tag ~loc @@ QIntroIdentifier id) in - Loc.tag ~loc (QAssertType (Some ipat, c, tac)) + let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in + CAst.make ~loc (QAssertType (Some ipat, c, tac)) | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> - Loc.tag ~loc:!@loc (QAssertType (ipat, c, tac)) + CAst.make ~loc:!@loc (QAssertType (ipat, c, tac)) ] ] ; q_assert: @@ -801,7 +801,7 @@ GEXTEND Gram let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) | test_ampersand_ident; "&"; id = Prim.ident -> - let tac = Tac2quote.of_exact_hyp ~loc:!@loc (Loc.tag ~loc:!@loc id) in + let tac = Tac2quote.of_exact_hyp ~loc:!@loc (CAst.make ~loc:!@loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) | test_dollar_ident; "$"; id = Prim.ident -> diff --git a/src/tac2core.ml b/src/tac2core.ml index c16e72b801..c6c3f26b6b 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -516,7 +516,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> thaw c >>= fun _ -> - Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal (Proofview.Goal.assume gl))] >>= fun () -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in let args = Array.of_list (EConstr.mkRel 1 :: args) in let ans = EConstr.mkEvar (evk, args) in @@ -744,7 +744,6 @@ end let () = define1 "refine" closure begin fun c -> let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in Proofview.Goal.enter begin fun gl -> - let gl = Proofview.Goal.assume gl in Refine.generic_refine ~typecheck:true c gl end >>= fun () -> return v_unit end @@ -1023,10 +1022,10 @@ let () = let add_scope s f = Tac2entries.register_scope (Id.of_string s) f -let rec pr_scope = function -| SexprStr (_, s) -> qstring s -| SexprInt (_, n) -> Pp.int n -| SexprRec (_, (_, na), args) -> +let rec pr_scope = let open CAst in function +| SexprStr {v=s} -> qstring s +| SexprInt {v=n} -> Pp.int n +| SexprRec (_, {v=na}, args) -> let na = match na with | None -> str "_" | Some id -> Id.print id @@ -1037,27 +1036,29 @@ let scope_fail s args = let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) -let q_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) +let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) let add_generic_scope s entry arg = let parse = function | [] -> let scope = Extend.Aentry entry in - let act x = Loc.tag @@ CTacExt (arg, x) in + let act x = CAst.make @@ CTacExt (arg, x) in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail s arg in add_scope s parse +open CAst + let () = add_scope "keyword" begin function -| [SexprStr (loc, s)] -> +| [SexprStr {loc;v=s}] -> let scope = Extend.Atoken (Tok.KEYWORD s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "keyword" arg end let () = add_scope "terminal" begin function -| [SexprStr (loc, s)] -> +| [SexprStr {loc;v=s}] -> let scope = Extend.Atoken (CLexer.terminal s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "terminal" arg @@ -1069,7 +1070,7 @@ let () = add_scope "list0" begin function let scope = Extend.Alist0 scope in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr (_, str)] -> +| [tok; SexprStr {v=str}] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let sep = Extend.Atoken (CLexer.terminal str) in let scope = Extend.Alist0sep (scope, sep) in @@ -1084,7 +1085,7 @@ let () = add_scope "list1" begin function let scope = Extend.Alist1 scope in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr (_, str)] -> +| [tok; SexprStr {v=str}] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in let sep = Extend.Atoken (CLexer.terminal str) in let scope = Extend.Alist1sep (scope, sep) in @@ -1099,9 +1100,9 @@ let () = add_scope "opt" begin function let scope = Extend.Aopt scope in let act opt = match opt with | None -> - Loc.tag @@ CTacCst (AbsKn (Other Core.c_none)) + CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) | Some x -> - Loc.tag @@ CTacApp (Loc.tag @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) + CAst.make @@ CTacApp (CAst.make @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "opt" arg @@ -1129,7 +1130,7 @@ let () = add_scope "tactic" begin function let scope = Extend.Aentryl (tac2expr, 5) in let act tac = tac in Tac2entries.ScopeRule (scope, act) -| [SexprInt (loc, n)] as arg -> +| [SexprInt {loc;v=n}] as arg -> let () = if n < 0 || n > 6 then scope_fail "tactic" arg in let scope = Extend.Aentryl (tac2expr, n) in let act tac = tac in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 1631880c71..e4bddf439b 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -8,6 +8,7 @@ open Pp open Util +open CAst open CErrors open Names open Libnames @@ -277,62 +278,61 @@ let fresh_var avoid x = in Namegen.next_ident_away_from (Id.of_string x) bad -let extract_pattern_type (loc, p as pat) = match p with +let extract_pattern_type ({loc;v=p} as pat) = match p with | CPatCnv (pat, ty) -> pat, Some ty | CPatVar _ | CPatRef _ -> pat, None (** Mangle recursive tactics *) let inline_rec_tactic tactics = - let avoid = List.fold_left (fun accu ((_, id), _) -> Id.Set.add id accu) Id.Set.empty tactics in - let map (id, e) = match snd e with + let avoid = List.fold_left (fun accu ({v=id}, _) -> Id.Set.add id accu) Id.Set.empty tactics in + let map (id, e) = match e.v with | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) | _ -> - let loc, _ = id in - user_err ?loc (str "Recursive tactic definitions must be functions") + user_err ?loc:id.loc (str "Recursive tactic definitions must be functions") in let tactics = List.map map tactics in let map (id, pat, e) = let fold_var (avoid, ans) (pat, _) = let id = fresh_var avoid "x" in - let loc = loc_of_patexpr pat in - (Id.Set.add id avoid, Loc.tag ?loc id :: ans) + let loc = pat.loc in + (Id.Set.add id avoid, CAst.make ?loc id :: ans) in (** Fresh variables to abstract over the function patterns *) let _, vars = List.fold_left fold_var (avoid, []) pat in - let map_body ((loc, id), _, e) = (Loc.tag ?loc @@ CPatVar (Name id)), e in + let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in let bnd = List.map map_body tactics in - let pat_of_id (loc, id) = (Loc.tag ?loc @@ CPatVar (Name id)) in - let var_of_id (loc, id) = - let qid = (loc, qualid_of_ident id) in - Loc.tag ?loc @@ CTacRef (RelId qid) + let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in + let var_of_id {loc;v=id} = + let qid = CAst.make ?loc @@ qualid_of_ident id in + CAst.make ?loc @@ CTacRef (RelId qid) in - let loc0 = loc_of_tacexpr e in + let loc0 = e.loc in let vpat = List.map pat_of_id vars in let varg = List.map var_of_id vars in - let e = Loc.tag ?loc:loc0 @@ CTacLet (true, bnd, Loc.tag ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in - (id, Loc.tag ?loc:loc0 @@ CTacFun (vpat, e)) + let e = CAst.make ?loc:loc0 @@ CTacLet (true, bnd, CAst.make ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in + (id, CAst.make ?loc:loc0 @@ CTacFun (vpat, e)) in List.map map tactics -let check_lowercase (loc, id) = +let check_lowercase {loc;v=id} = if Tac2env.is_constructor (Libnames.qualid_of_ident id) then user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") let register_ltac ?(local = false) ?(mut = false) isrec tactics = - let map ((loc, na), e) = + let map ({loc;v=na}, e) = let id = match na with | Anonymous -> user_err ?loc (str "Tactic definition must have a name") | Name id -> id in - let () = check_lowercase (loc, id) in - ((loc, id), e) + let () = check_lowercase CAst.(make ?loc id) in + (CAst.(make ?loc id), e) in let tactics = List.map map tactics in let tactics = if isrec then inline_rec_tactic tactics else tactics in - let map ((loc, id), e) = + let map ({loc;v=id}, e) = let (e, t) = intern ~strict:true e in let () = if not (is_value e) then @@ -360,23 +360,23 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = in List.iter iter defs -let qualid_to_ident (loc, qid) = +let qualid_to_ident {loc;v=qid} = let (dp, id) = Libnames.repr_qualid qid in - if DirPath.is_empty dp then (loc, id) + if DirPath.is_empty dp then CAst.make ?loc id else user_err ?loc (str "Identifier expected") let register_typedef ?(local = false) isrec types = - let same_name ((_, id1), _) ((_, id2), _) = Id.equal id1 id2 in + let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in let () = match List.duplicates same_name types with | [] -> () - | ((loc, id), _) :: _ -> + | ({loc;v=id}, _) :: _ -> user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) in - let check ((loc, id), (params, def)) = - let same_name (_, id1) (_, id2) = Id.equal id1 id2 in + let check ({loc;v=id}, (params, def)) = + let same_name {v=id1} {v=id2} = Id.equal id1 id2 in let () = match List.duplicates same_name params with | [] -> () - | (loc, id) :: _ -> + | {loc;v=id} :: _ -> user_err ?loc (str "The type parameter " ++ Id.print id ++ str " occurs several times") in @@ -409,13 +409,13 @@ let register_typedef ?(local = false) isrec types = let () = List.iter check types in let self = if isrec then - let fold accu ((_, id), (params, _)) = + let fold accu ({v=id}, (params, _)) = Id.Map.add id (Lib.make_kn id, List.length params) accu in List.fold_left fold Id.Map.empty types else Id.Map.empty in - let map ((_, id), def) = + let map ({v=id}, def) = let typdef = { typdef_local = local; typdef_expr = intern_typedef self def; @@ -426,7 +426,7 @@ let register_typedef ?(local = false) isrec types = let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in List.iter iter types -let register_primitive ?(local = false) (loc, id) t ml = +let register_primitive ?(local = false) {loc;v=id} t ml = let t = intern_open_type t in let rec count_arrow = function | GTypArrow (_, t) -> 1 + count_arrow t @@ -453,7 +453,7 @@ let register_primitive ?(local = false) (loc, id) t ml = } in ignore (Lib.add_leaf id (inTacDef def)) -let register_open ?(local = false) (loc, qid) (params, def) = +let register_open ?(local = false) {loc;v=qid} (params, def) = let kn = try Tac2env.locate_type qid with Not_found -> @@ -496,14 +496,13 @@ let register_open ?(local = false) (loc, qid) (params, def) = let register_type ?local isrec types = match types with | [qid, true, def] -> - let (loc, _) = qid in + let {loc} = qid in let () = if isrec then user_err ?loc (str "Extensions cannot be recursive") in register_open ?local qid def | _ -> let map (qid, redef, def) = - let (loc, _) = qid in let () = if redef then - user_err ?loc (str "Types can only be extended one by one") + user_err ?loc:qid.loc (str "Types can only be extended one by one") in (qualid_to_ident qid, def) in @@ -530,26 +529,26 @@ module ParseToken = struct let loc_of_token = function -| SexprStr (loc, _) -> loc -| SexprInt (loc, _) -> loc +| SexprStr {loc} -> loc +| SexprInt {loc} -> loc | SexprRec (loc, _, _) -> Some loc let parse_scope = function -| SexprRec (_, (loc, Some id), toks) -> +| SexprRec (_, {loc;v=Some id}, toks) -> if Id.Map.mem id !scope_table then Id.Map.find id !scope_table toks else CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) -| SexprStr (_, str) -> - let v_unit = Loc.tag @@ CTacCst (AbsKn (Tuple 0)) in +| SexprStr {v=str} -> + let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in ScopeRule (Extend.Atoken (Tok.IDENT str), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in CErrors.user_err ?loc (str "Invalid parsing token") let parse_token = function -| SexprStr (_, s) -> TacTerm s -| SexprRec (_, (_, na), [tok]) -> +| SexprStr {v=s} -> TacTerm s +| SexprRec (_, {v=na}, [tok]) -> let na = match na with None -> Anonymous | Some id -> Name id in let scope = parse_scope tok in TacNonTerm (na, scope) @@ -591,11 +590,10 @@ let perform_notation syn st = let KRule (rule, act) = get_rule tok in let mk loc args = let map (na, e) = - let loc = loc_of_tacexpr e in - ((Loc.tag ?loc @@ CPatVar na), e) + ((CAst.make ?loc:e.loc @@ CPatVar na), e) in let bnd = List.map map args in - Loc.tag ~loc @@ CTacLet (false, bnd, syn.synext_exp) + CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) in let rule = Extend.Rule (rule, act mk) in let lev = match syn.synext_lev with @@ -659,9 +657,9 @@ let inTac2Abbreviation : abbreviation -> obj = classify_function = classify_abbreviation} let register_notation ?(local = false) tkn lev body = match tkn, lev with -| [SexprRec (_, (loc, Some id), [])], None -> +| [SexprRec (_, {loc;v=Some id}, [])], None -> (** Tactic abbreviation *) - let () = check_lowercase (loc, id) in + let () = check_lowercase CAst.(make ?loc id) in let body = Tac2intern.globalize Id.Set.empty body in let abbr = { abbr_body = body } in ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) @@ -780,7 +778,7 @@ let register_struct ?local str = match str with | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e -| StrMut (qid, e) -> register_redefinition ?local qid e +| StrMut (qid, e) -> register_redefinition ?local CAst.(qid.loc, qid.v) e | StrRun e -> perform_eval e (** Toplevel exception *) @@ -876,7 +874,7 @@ let solve default tac = if not status then Feedback.feedback Feedback.AddedAxiom let call ~default e = - let loc = loc_of_tacexpr e in + let loc = e.loc in let (e, t) = intern ~strict:false e in let () = check_unit ?loc t in let tac = Tac2interp.interp Tac2interp.empty_environment e in diff --git a/src/tac2entries.mli b/src/tac2entries.mli index a92e149a85..cfb58ea383 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Libnames open Tac2expr @@ -14,13 +13,13 @@ open Tac2expr (** {5 Toplevel definitions} *) val register_ltac : ?local:bool -> ?mut:bool -> rec_flag -> - (Name.t located * raw_tacexpr) list -> unit + (Misctypes.lname * raw_tacexpr) list -> unit val register_type : ?local:bool -> rec_flag -> - (qualid located * redef_flag * raw_quant_typedef) list -> unit + (qualid CAst.t * redef_flag * raw_quant_typedef) list -> unit val register_primitive : ?local:bool -> - Id.t located -> raw_typexpr -> ml_tactic_name -> unit + Misctypes.lident -> raw_typexpr -> ml_tactic_name -> unit val register_struct : ?local:bool -> strexpr -> unit @@ -63,11 +62,11 @@ val tac2expr : raw_tacexpr Pcoq.Gram.entry open Tac2qexpr -val q_ident : Id.t located or_anti Pcoq.Gram.entry +val q_ident : Id.t CAst.t or_anti Pcoq.Gram.entry val q_bindings : bindings Pcoq.Gram.entry val q_with_bindings : bindings Pcoq.Gram.entry val q_intropattern : intro_pattern Pcoq.Gram.entry -val q_intropatterns : intro_pattern list located Pcoq.Gram.entry +val q_intropatterns : intro_pattern list CAst.t Pcoq.Gram.entry val q_destruction_arg : destruction_arg Pcoq.Gram.entry val q_induction_clause : induction_clause Pcoq.Gram.entry val q_conversion : conversion Pcoq.Gram.entry diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 60f10d360f..ddffd13a31 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -27,7 +27,7 @@ type tacref = | TacAlias of ltac_alias type 'a or_relid = -| RelId of qualid located +| RelId of qualid CAst.t | AbsKn of 'a (** {5 Misc} *) @@ -48,7 +48,7 @@ type raw_typexpr_r = | CTypArrow of raw_typexpr * raw_typexpr | CTypRef of type_constant or_tuple or_relid * raw_typexpr list -and raw_typexpr = raw_typexpr_r located +and raw_typexpr = raw_typexpr_r CAst.t type raw_typedef = | CTydDef of raw_typexpr option @@ -78,7 +78,7 @@ type glb_typedef = type type_scheme = int * int glb_typexpr -type raw_quant_typedef = Id.t located list * raw_typedef +type raw_quant_typedef = Misctypes.lident list * raw_typedef type glb_quant_typedef = int * glb_typedef (** {5 Term syntax} *) @@ -93,7 +93,7 @@ type raw_patexpr_r = | CPatRef of ltac_constructor or_tuple or_relid * raw_patexpr list | CPatCnv of raw_patexpr * raw_typexpr -and raw_patexpr = raw_patexpr_r located +and raw_patexpr = raw_patexpr_r CAst.t type raw_tacexpr_r = | CTacAtm of atom @@ -110,7 +110,7 @@ type raw_tacexpr_r = | CTacSet of raw_tacexpr * ltac_projection or_relid * raw_tacexpr | CTacExt : ('a, _) Tac2dyn.Arg.tag * 'a -> raw_tacexpr_r -and raw_tacexpr = raw_tacexpr_r located +and raw_tacexpr = raw_tacexpr_r CAst.t and raw_taccase = raw_patexpr * raw_tacexpr @@ -152,22 +152,22 @@ type exp_level = | E0 type sexpr = -| SexprStr of string located -| SexprInt of int located -| SexprRec of Loc.t * Id.t option located * sexpr list +| SexprStr of string CAst.t +| SexprInt of int CAst.t +| SexprRec of Loc.t * Id.t option CAst.t * sexpr list (** {5 Toplevel statements} *) type strexpr = -| StrVal of mutable_flag * rec_flag * (Name.t located * raw_tacexpr) list +| StrVal of mutable_flag * rec_flag * (Misctypes.lname * raw_tacexpr) list (** Term definition *) -| StrTyp of rec_flag * (qualid located * redef_flag * raw_quant_typedef) list +| StrTyp of rec_flag * (qualid CAst.t * redef_flag * raw_quant_typedef) list (** Type definition *) -| StrPrm of Id.t located * raw_typexpr * ml_tactic_name +| StrPrm of Misctypes.lident * raw_typexpr * ml_tactic_name (** External definition *) | StrSyn of sexpr list * int option * raw_tacexpr (** Syntactic extensions *) -| StrMut of qualid located * raw_tacexpr +| StrMut of qualid CAst.t * raw_tacexpr (** Redefinition of mutable globals *) | StrRun of raw_tacexpr (** Toplevel evaluation of an expression *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index dc142043e8..b1dd8f7f51 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -8,6 +8,7 @@ open Pp open Util +open CAst open CErrors open Names open Libnames @@ -172,7 +173,7 @@ let drop_ltac2_env store = let fresh_id env = UF.fresh env.env_cst -let get_alias (loc, id) env = +let get_alias {loc;v=id} env = try Id.Map.find id env.env_als.contents with Not_found -> if env.env_opn then @@ -185,10 +186,6 @@ let push_name id t env = match id with | Anonymous -> env | Name id -> { env with env_var = Id.Map.add id t env.env_var } -let loc_of_tacexpr (loc, _) : Loc.t option = loc - -let loc_of_patexpr (loc, _) : Loc.t option = loc - let error_nargs_mismatch ?loc kn nargs nfound = let cstr = Tac2env.shortest_qualid_of_constructor kn in user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ @@ -206,12 +203,12 @@ let rec subst_type subst (t : 'a glb_typexpr) = match t with | GTypRef (qid, args) -> GTypRef (qid, List.map (fun t -> subst_type subst t) args) -let rec intern_type env ((loc, t) : raw_typexpr) : UF.elt glb_typexpr = match t with -| CTypVar (Name id) -> GTypVar (get_alias (Loc.tag ?loc id) env) +let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (Name id) -> GTypVar (get_alias (CAst.make ?loc id) env) | CTypVar Anonymous -> GTypVar (fresh_id env) | CTypRef (rel, args) -> let (kn, nparams) = match rel with - | RelId (loc, qid) -> + | RelId {loc;v=qid} -> let (dp, id) = repr_qualid qid in if DirPath.is_empty dp && Id.Map.mem id env.env_rec then let (kn, n) = Id.Map.find id env.env_rec in @@ -233,9 +230,9 @@ let rec intern_type env ((loc, t) : raw_typexpr) : UF.elt glb_typexpr = match t let nargs = List.length args in let () = if not (Int.equal nparams nargs) then - let loc, qid = match rel with + let {loc;v=qid} = match rel with | RelId lid -> lid - | AbsKn (Other kn) -> loc, shortest_qualid_of_type kn + | AbsKn (Other kn) -> CAst.make ?loc @@ shortest_qualid_of_type kn | AbsKn (Tuple _) -> assert false in user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ @@ -500,10 +497,10 @@ let check_unit ?loc t = let check_redundant_clause = function | [] -> () -| (p, _) :: _ -> warn_redundant_clause ?loc:(loc_of_patexpr p) () +| (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () let get_variable0 mem var = match var with -| RelId (loc, qid) -> +| RelId {loc;v=qid} -> let (dp, id) = repr_qualid qid in if DirPath.is_empty dp && mem id then ArgVar CAst.(make ?loc id) else @@ -520,7 +517,7 @@ let get_variable env var = get_variable0 mem var let get_constructor env var = match var with -| RelId (loc, qid) -> +| RelId {loc;v=qid} -> let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in begin match c with | Some knc -> Other knc @@ -530,7 +527,7 @@ let get_constructor env var = match var with | AbsKn knc -> knc let get_projection var = match var with -| RelId (loc, qid) -> +| RelId {loc;v=qid} -> let kn = try Tac2env.locate_projection qid with Not_found -> user_err ?loc (pr_qualid qid ++ str " is not a projection") in @@ -556,7 +553,7 @@ type glb_patexpr = | GPatVar of Name.t | GPatRef of ltac_constructor or_tuple * glb_patexpr list -let rec intern_patexpr env (loc, pat) = match pat with +let rec intern_patexpr env {loc;v=pat} = match pat with | CPatVar na -> GPatVar na | CPatRef (qid, pl) -> let kn = get_constructor env qid in @@ -601,7 +598,7 @@ let add_name accu = function | Name id -> Id.Set.add id accu | Anonymous -> accu -let rec ids_of_pattern accu (_, pat) = match pat with +let rec ids_of_pattern accu {v=pat} = match pat with | CPatVar Anonymous -> accu | CPatVar (Name id) -> Id.Set.add id accu | CPatRef (_, pl) -> @@ -609,24 +606,23 @@ let rec ids_of_pattern accu (_, pat) = match pat with | CPatCnv (pat, _) -> ids_of_pattern accu pat let loc_of_relid = function -| RelId (loc, _) -> loc +| RelId {loc} -> loc | AbsKn _ -> None -let extract_pattern_type (loc, p as pat) = match p with +let extract_pattern_type ({loc;v=p} as pat) = match p with | CPatCnv (pat, ty) -> pat, Some ty | CPatVar _ | CPatRef _ -> pat, None (** Expand pattern: [p => t] becomes [x => match x with p => t end] *) let expand_pattern avoid bnd = let fold (avoid, bnd) (pat, t) = - let na, expand = match snd pat with + let na, expand = match pat.v with | CPatVar na -> (** Don't expand variable patterns *) na, None | _ -> - let loc = loc_of_patexpr pat in let id = fresh_var avoid in - let qid = RelId (Loc.tag ?loc (qualid_of_ident id)) in + let qid = RelId (CAst.make ?loc:pat.loc (qualid_of_ident id)) in Name id, Some qid in let avoid = ids_of_pattern avoid pat in @@ -638,7 +634,7 @@ let expand_pattern avoid bnd = | None -> e | Some qid -> let loc = loc_of_relid qid in - Loc.tag ?loc @@ CTacCse (Loc.tag ?loc @@ CTacRef qid, [pat, e]) + CAst.make ?loc @@ CTacCse (CAst.make ?loc @@ CTacRef qid, [pat, e]) in let expand e = List.fold_left fold e bnd in let nas = List.rev_map (fun (na, _, _) -> na) bnd in @@ -648,7 +644,7 @@ let is_alias env qid = match get_variable env qid with | ArgArg (TacAlias _) -> true | ArgVar _ | (ArgArg (TacConstant _)) -> false -let rec intern_rec env (loc, e) = match e with +let rec intern_rec env {loc;v=e} = match e with | CTacAtm atm -> intern_atm env atm | CTacRef qid -> begin match get_variable env qid with @@ -685,10 +681,10 @@ let rec intern_rec env (loc, e) = match e with let (e, t) = intern_rec env (exp e) in let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in (GTacFun (nas, e), t) -| CTacApp ((loc, CTacCst qid), args) -> +| CTacApp ({loc;v=CTacCst qid}, args) -> let kn = get_constructor env qid in intern_constructor env loc kn args -| CTacApp ((_, CTacRef qid), args) when is_alias env qid -> +| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> let kn = match get_variable env qid with | ArgArg (TacAlias kn) -> kn | ArgVar _ | (ArgArg (TacConstant _)) -> assert false @@ -696,18 +692,18 @@ let rec intern_rec env (loc, e) = match e with let e = Tac2env.interp_alias kn in let map arg = (** Thunk alias arguments *) - let loc = loc_of_tacexpr arg in - let t_unit = Loc.tag ?loc @@ CTypRef (AbsKn (Tuple 0), []) in - let var = Loc.tag ?loc @@ CPatCnv (Loc.tag ?loc @@ CPatVar Anonymous, t_unit) in - Loc.tag ?loc @@ CTacFun ([var], arg) + let loc = arg.loc in + let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in + let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in + CAst.make ?loc @@ CTacFun ([var], arg) in let args = List.map map args in - intern_rec env (Loc.tag ?loc @@ CTacApp (e, args)) + intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) | CTacApp (f, args) -> - let loc = loc_of_tacexpr f in + let loc = f.loc in let (f, ft) = intern_rec env f in let fold arg (args, t) = - let loc = loc_of_tacexpr arg in + let loc = arg.loc in let (arg, argt) = intern_rec env arg in (arg :: args, (loc, argt) :: t) in @@ -726,8 +722,7 @@ let rec intern_rec env (loc, e) = match e with if Id.Set.is_empty common then Id.Set.union ids accu else let id = Id.Set.choose common in - let loc = loc_of_patexpr pat in - user_err ?loc (str "Variable " ++ Id.print id ++ str " is bound several \ + user_err ?loc:pat.loc (str "Variable " ++ Id.print id ++ str " is bound several \ times in this matching") in let ids = List.fold_left fold Id.Set.empty el in @@ -739,7 +734,7 @@ let rec intern_rec env (loc, e) = match e with let () = unify ?loc env t tc in (e, tc) | CTacSeq (e1, e2) -> - let loc1 = loc_of_tacexpr e1 in + let loc1 = e1.loc in let (e1, t1) = intern_rec env e1 in let (e2, t2) = intern_rec env e2 in let () = check_elt_unit loc1 env t1 in @@ -750,7 +745,7 @@ let rec intern_rec env (loc, e) = match e with intern_record env loc fs | CTacPrj (e, proj) -> let pinfo = get_projection proj in - let loc = loc_of_tacexpr e in + let loc = e.loc in let (e, t) = intern_rec env e in let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in let params = Array.map_to_list (fun i -> GTypVar i) subst in @@ -764,7 +759,7 @@ let rec intern_rec env (loc, e) = match e with let () = if not pinfo.pdata_mutb then let loc = match proj with - | RelId (loc, _) -> loc + | RelId {CAst.loc} -> loc | AbsKn _ -> None in user_err ?loc (str "Field is not mutable") @@ -806,10 +801,9 @@ let rec intern_rec env (loc, e) = match e with (e, tpe) and intern_rec_with_constraint env e exp = - let loc = loc_of_tacexpr e in - let (e, t) = intern_rec env e in - let () = unify ?loc env t exp in - e + let (er, t) = intern_rec env e in + let () = unify ?loc:e.loc env t exp in + er and intern_let env loc ids el e = let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in @@ -837,11 +831,10 @@ and intern_let env loc ids el e = and intern_let_rec env loc ids el e = let map env (pat, t, e) = - let (loc, pat) = pat in - let na = match pat with + let na = match pat.v with | CPatVar na -> na | CPatRef _ | CPatCnv _ -> - user_err ?loc (str "This kind of pattern is forbidden in let-rec bindings") + user_err ?loc:pat.loc (str "This kind of pattern is forbidden in let-rec bindings") in let id = fresh_id env in let env = push_name na (monomorphic (GTypVar id)) env in @@ -849,7 +842,7 @@ and intern_let_rec env loc ids el e = in let (env, el) = List.fold_map map env el in let fold (loc, na, tc, e, id) (el, tl) = - let loc_e = loc_of_tacexpr e in + let loc_e = e.loc in let (e, t) = intern_rec env e in let () = if not (is_rec_rhs e) then @@ -891,7 +884,7 @@ and intern_case env loc e pl = (GTacCse (e', Other kn, [||], [||]), GTypVar r) | PKind_variant kn -> let subst, tc = fresh_reftype env kn in - let () = unify ?loc:(loc_of_tacexpr e) env t tc in + let () = unify ?loc:e.loc env t tc in let (nconst, nnonconst, arities) = match kn with | Tuple 0 -> 1, 0, [0] | Tuple n -> 0, 1, [n] @@ -907,9 +900,9 @@ and intern_case env loc e pl = let rec intern_branch = function | [] -> () | (pat, br) :: rem -> - let tbr = match snd pat with + let tbr = match pat.v with | CPatVar (Name _) -> - let loc = loc_of_patexpr pat in + let loc = pat.loc in todo ?loc () | CPatVar Anonymous -> let () = check_redundant_clause rem in @@ -932,7 +925,7 @@ and intern_case env loc e pl = let _ = List.fold_left fill (0, 0) arities in brT | CPatRef (qid, args) -> - let loc = loc_of_patexpr pat in + let loc = pat.loc in let knc = get_constructor env qid in let kn', index, arity = match knc with | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) @@ -946,8 +939,8 @@ and intern_case env loc e pl = invalid_pattern ?loc kn kn' in let get_id pat = match pat with - | _, CPatVar na -> na - | loc, _ -> todo ?loc () + | {v=CPatVar na} -> na + | {loc} -> todo ?loc () in let ids = List.map get_id args in let nids = List.length ids in @@ -978,7 +971,7 @@ and intern_case env loc e pl = | CPatCnv _ -> user_err ?loc (str "Pattern not handled yet") in - let () = unify ?loc:(loc_of_tacexpr br) env tbr ret in + let () = unify ?loc:br.loc env tbr ret in intern_branch rem in let () = intern_branch pl in @@ -995,7 +988,7 @@ and intern_case env loc e pl = (ce, ret) | PKind_open kn -> let subst, tc = fresh_reftype env (Other kn) in - let () = unify ?loc:(loc_of_tacexpr e) env t tc in + let () = unify ?loc:e.loc env t tc in let ret = GTypVar (fresh_id env) in let rec intern_branch map = function | [] -> @@ -1014,7 +1007,7 @@ and intern_case env loc e pl = | GPatRef _ -> user_err ?loc (str "TODO: Unhandled match case") (** FIXME *) in - let loc = loc_of_patexpr pat in + let loc = pat.loc in let knc = match knc with | Other knc -> knc | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) @@ -1080,7 +1073,7 @@ and intern_constructor env loc kn args = match kn with and intern_record env loc fs = let map (proj, e) = let loc = match proj with - | RelId (loc, _) -> loc + | RelId {CAst.loc} -> loc | AbsKn _ -> None in let proj = get_projection proj in @@ -1213,24 +1206,24 @@ let check_subtype t1 t2 = (** Globalization *) let get_projection0 var = match var with -| RelId (loc, qid) -> +| RelId {CAst.loc;v=qid} -> let kn = try Tac2env.locate_projection qid with Not_found -> user_err ?loc (pr_qualid qid ++ str " is not a projection") in kn | AbsKn kn -> kn -let rec globalize ids (loc, er as e) = match er with +let rec globalize ids ({loc;v=er} as e) = match er with | CTacAtm _ -> e | CTacRef ref -> let mem id = Id.Set.mem id ids in begin match get_variable0 mem ref with | ArgVar _ -> e - | ArgArg kn -> Loc.tag ?loc @@ CTacRef (AbsKn kn) + | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) end | CTacCst qid -> let knc = get_constructor () qid in - Loc.tag ?loc @@ CTacCst (AbsKn knc) + CAst.make ?loc @@ CTacCst (AbsKn knc) | CTacFun (bnd, e) -> let fold (pats, accu) pat = let accu = ids_of_pattern accu pat in @@ -1240,11 +1233,11 @@ let rec globalize ids (loc, er as e) = match er with let bnd, ids = List.fold_left fold ([], ids) bnd in let bnd = List.rev bnd in let e = globalize ids e in - Loc.tag ?loc @@ CTacFun (bnd, e) + CAst.make ?loc @@ CTacFun (bnd, e) | CTacApp (e, el) -> let e = globalize ids e in let el = List.map (fun e -> globalize ids e) el in - Loc.tag ?loc @@ CTacApp (e, el) + CAst.make ?loc @@ CTacApp (e, el) | CTacLet (isrec, bnd, e) -> let fold accu (pat, _) = ids_of_pattern accu pat in let ext = List.fold_left fold Id.Set.empty bnd in @@ -1256,34 +1249,34 @@ let rec globalize ids (loc, er as e) = match er with (qid, globalize ids e) in let bnd = List.map map bnd in - Loc.tag ?loc @@ CTacLet (isrec, bnd, e) + CAst.make ?loc @@ CTacLet (isrec, bnd, e) | CTacCnv (e, t) -> let e = globalize ids e in - Loc.tag ?loc @@ CTacCnv (e, t) + CAst.make ?loc @@ CTacCnv (e, t) | CTacSeq (e1, e2) -> let e1 = globalize ids e1 in let e2 = globalize ids e2 in - Loc.tag ?loc @@ CTacSeq (e1, e2) + CAst.make ?loc @@ CTacSeq (e1, e2) | CTacCse (e, bl) -> let e = globalize ids e in let bl = List.map (fun b -> globalize_case ids b) bl in - Loc.tag ?loc @@ CTacCse (e, bl) + CAst.make ?loc @@ CTacCse (e, bl) | CTacRec r -> let map (p, e) = let p = get_projection0 p in let e = globalize ids e in (AbsKn p, e) in - Loc.tag ?loc @@ CTacRec (List.map map r) + CAst.make ?loc @@ CTacRec (List.map map r) | CTacPrj (e, p) -> let e = globalize ids e in let p = get_projection0 p in - Loc.tag ?loc @@ CTacPrj (e, AbsKn p) + CAst.make ?loc @@ CTacPrj (e, AbsKn p) | CTacSet (e, p, e') -> let e = globalize ids e in let p = get_projection0 p in let e' = globalize ids e' in - Loc.tag ?loc @@ CTacSet (e, AbsKn p, e') + CAst.make ?loc @@ CTacSet (e, AbsKn p, e') | CTacExt (tag, arg) -> let arg = str (Tac2dyn.Arg.repr tag) in CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) @@ -1291,16 +1284,16 @@ let rec globalize ids (loc, er as e) = match er with and globalize_case ids (p, e) = (globalize_pattern ids p, globalize ids e) -and globalize_pattern ids (loc, pr as p) = match pr with +and globalize_pattern ids ({loc;v=pr} as p) = match pr with | CPatVar _ -> p | CPatRef (cst, pl) -> let knc = get_constructor () cst in let cst = AbsKn knc in let pl = List.map (fun p -> globalize_pattern ids p) pl in - Loc.tag ?loc @@ CPatRef (cst, pl) + CAst.make ?loc @@ CPatRef (cst, pl) | CPatCnv (pat, ty) -> let pat = globalize_pattern ids pat in - Loc.tag ?loc @@ CPatCnv (pat, ty) + CAst.make ?loc @@ CPatCnv (pat, ty) (** Kernel substitution *) @@ -1407,16 +1400,16 @@ let subst_or_relid subst ref = match ref with let kn' = subst_or_tuple subst_kn subst kn in if kn' == kn then ref else AbsKn kn' -let rec subst_rawtype subst (loc, tr as t) = match tr with +let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with | CTypVar _ -> t | CTypArrow (t1, t2) -> let t1' = subst_rawtype subst t1 in let t2' = subst_rawtype subst t2 in - if t1' == t1 && t2' == t2 then t else Loc.tag ?loc @@ CTypArrow (t1', t2') + if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') | CTypRef (ref, tl) -> let ref' = subst_or_relid subst ref in let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in - if ref' == ref && tl' == tl then t else Loc.tag ?loc @@ CTypRef (ref', tl') + if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') let subst_tacref subst ref = match ref with | RelId _ -> ref @@ -1433,35 +1426,35 @@ let subst_projection subst prj = match prj with let kn' = subst_kn subst kn in if kn' == kn then prj else AbsKn kn' -let rec subst_rawpattern subst (loc, pr as p) = match pr with +let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with | CPatVar _ -> p | CPatRef (c, pl) -> let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in let c' = subst_or_relid subst c in - if pl' == pl && c' == c then p else Loc.tag ?loc @@ CPatRef (c', pl') + if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') | CPatCnv (pat, ty) -> let pat' = subst_rawpattern subst pat in let ty' = subst_rawtype subst ty in - if pat' == pat && ty' == ty then p else Loc.tag ?loc @@ CPatCnv (pat', ty') + if pat' == pat && ty' == ty then p else CAst.make ?loc @@ CPatCnv (pat', ty') (** Used for notations *) -let rec subst_rawexpr subst (loc, tr as t) = match tr with +let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with | CTacAtm _ -> t | CTacRef ref -> let ref' = subst_tacref subst ref in - if ref' == ref then t else Loc.tag ?loc @@ CTacRef ref' + if ref' == ref then t else CAst.make ?loc @@ CTacRef ref' | CTacCst ref -> let ref' = subst_or_relid subst ref in - if ref' == ref then t else Loc.tag ?loc @@ CTacCst ref' + if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' | CTacFun (bnd, e) -> let map pat = subst_rawpattern subst pat in let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else Loc.tag ?loc @@ CTacFun (bnd', e') + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') | CTacApp (e, el) -> let e' = subst_rawexpr subst e in let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in - if e' == e && el' == el then t else Loc.tag ?loc @@ CTacApp (e', el') + if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') | CTacLet (isrec, bnd, e) -> let map (na, e as p) = let na' = subst_rawpattern subst na in @@ -1470,15 +1463,15 @@ let rec subst_rawexpr subst (loc, tr as t) = match tr with in let bnd' = List.smartmap map bnd in let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else Loc.tag ?loc @@ CTacLet (isrec, bnd', e') + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') | CTacCnv (e, c) -> let e' = subst_rawexpr subst e in let c' = subst_rawtype subst c in - if c' == c && e' == e then t else Loc.tag ?loc @@ CTacCnv (e', c') + if c' == c && e' == e then t else CAst.make ?loc @@ CTacCnv (e', c') | CTacSeq (e1, e2) -> let e1' = subst_rawexpr subst e1 in let e2' = subst_rawexpr subst e2 in - if e1' == e1 && e2' == e2 then t else Loc.tag ?loc @@ CTacSeq (e1', e2') + if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') | CTacCse (e, bl) -> let map (p, e as x) = let p' = subst_rawpattern subst p in @@ -1487,7 +1480,7 @@ let rec subst_rawexpr subst (loc, tr as t) = match tr with in let e' = subst_rawexpr subst e in let bl' = List.smartmap map bl in - if e' == e && bl' == bl then t else Loc.tag ?loc @@ CTacCse (e', bl') + if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') | CTacRec el -> let map (prj, e as p) = let prj' = subst_projection subst prj in @@ -1495,16 +1488,16 @@ let rec subst_rawexpr subst (loc, tr as t) = match tr with if prj' == prj && e' == e then p else (prj', e') in let el' = List.smartmap map el in - if el' == el then t else Loc.tag ?loc @@ CTacRec el' + if el' == el then t else CAst.make ?loc @@ CTacRec el' | CTacPrj (e, prj) -> let prj' = subst_projection subst prj in let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then t else Loc.tag ?loc @@ CTacPrj (e', prj') + if prj' == prj && e' == e then t else CAst.make ?loc @@ CTacPrj (e', prj') | CTacSet (e, prj, r) -> let prj' = subst_projection subst prj in let e' = subst_rawexpr subst e in let r' = subst_rawexpr subst r in - if prj' == prj && e' == e && r' == r then t else Loc.tag ?loc @@ CTacSet (e', prj', r') + if prj' == prj && e' == e && r' == r then t else CAst.make ?loc @@ CTacSet (e', prj', r') | CTacExt _ -> assert false (** Should not be generated by globalization *) (** Registering *) @@ -1520,7 +1513,7 @@ let () = else { env with env_str = false } | Some env -> env in - let loc = loc_of_tacexpr tac in + let loc = tac.loc in let (tac, t) = intern_rec env tac in let () = check_elt_unit loc env t in (ist, tac) diff --git a/src/tac2intern.mli b/src/tac2intern.mli index 4b02f91caa..d646b5cda5 100644 --- a/src/tac2intern.mli +++ b/src/tac2intern.mli @@ -10,9 +10,6 @@ open Names open Mod_subst open Tac2expr -val loc_of_tacexpr : raw_tacexpr -> Loc.t option -val loc_of_patexpr : raw_patexpr -> Loc.t option - val intern : strict:bool -> raw_tacexpr -> glb_tacexpr * type_scheme val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef val intern_open_type : raw_typexpr -> type_scheme diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 2f6c97f08b..05b9f4141f 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Tac2expr @@ -15,65 +14,65 @@ open Tac2expr type 'a or_anti = | QExpr of 'a -| QAnti of Id.t located +| QAnti of Id.t CAst.t type quantified_hypothesis = -| QAnonHyp of int located -| QNamedHyp of Id.t located +| QAnonHyp of int CAst.t +| QNamedHyp of Id.t CAst.t type bindings_r = | QImplicitBindings of Constrexpr.constr_expr list -| QExplicitBindings of (quantified_hypothesis located or_anti * Constrexpr.constr_expr) located list +| QExplicitBindings of (quantified_hypothesis CAst.t or_anti * Constrexpr.constr_expr) CAst.t list | QNoBindings -type bindings = bindings_r located +type bindings = bindings_r CAst.t type intro_pattern_r = | QIntroForthcoming of bool | QIntroNaming of intro_pattern_naming | QIntroAction of intro_pattern_action and intro_pattern_naming_r = -| QIntroIdentifier of Id.t located or_anti -| QIntroFresh of Id.t located or_anti +| QIntroIdentifier of Id.t CAst.t or_anti +| QIntroFresh of Id.t CAst.t or_anti | QIntroAnonymous and intro_pattern_action_r = | QIntroWildcard | QIntroOrAndPattern of or_and_intro_pattern -| QIntroInjection of intro_pattern list located +| QIntroInjection of intro_pattern list CAst.t (* | QIntroApplyOn of Empty.t (** Not implemented yet *) *) | QIntroRewrite of bool and or_and_intro_pattern_r = -| QIntroOrPattern of intro_pattern list located list -| QIntroAndPattern of intro_pattern list located +| QIntroOrPattern of intro_pattern list CAst.t list +| QIntroAndPattern of intro_pattern list CAst.t -and intro_pattern = intro_pattern_r located -and intro_pattern_naming = intro_pattern_naming_r located -and intro_pattern_action = intro_pattern_action_r located -and or_and_intro_pattern = or_and_intro_pattern_r located +and intro_pattern = intro_pattern_r CAst.t +and intro_pattern_naming = intro_pattern_naming_r CAst.t +and intro_pattern_action = intro_pattern_action_r CAst.t +and or_and_intro_pattern = or_and_intro_pattern_r CAst.t type occurrences_r = | QAllOccurrences -| QAllOccurrencesBut of int located or_anti list +| QAllOccurrencesBut of int CAst.t or_anti list | QNoOccurrences -| QOnlyOccurrences of int located or_anti list +| QOnlyOccurrences of int CAst.t or_anti list -type occurrences = occurrences_r located +type occurrences = occurrences_r CAst.t -type hyp_location = (occurrences * Id.t located or_anti) * Locus.hyp_location_flag +type hyp_location = (occurrences * Id.t CAst.t or_anti) * Locus.hyp_location_flag type clause_r = { q_onhyps : hyp_location list option; q_concl_occs : occurrences; } -type clause = clause_r located +type clause = clause_r CAst.t -type constr_with_bindings = (Constrexpr.constr_expr * bindings) located +type constr_with_bindings = (Constrexpr.constr_expr * bindings) CAst.t type destruction_arg_r = | QElimOnConstr of constr_with_bindings -| QElimOnIdent of Id.t located -| QElimOnAnonHyp of int located +| QElimOnIdent of Id.t CAst.t +| QElimOnAnonHyp of int CAst.t -type destruction_arg = destruction_arg_r located +type destruction_arg = destruction_arg_r CAst.t type induction_clause_r = { indcl_arg : destruction_arg; @@ -82,33 +81,33 @@ type induction_clause_r = { indcl_in : clause option; } -type induction_clause = induction_clause_r located +type induction_clause = induction_clause_r CAst.t type conversion_r = | QConvert of Constrexpr.constr_expr | QConvertWith of Constrexpr.constr_expr * Constrexpr.constr_expr -type conversion = conversion_r located +type conversion = conversion_r CAst.t type multi_r = -| QPrecisely of int located -| QUpTo of int located +| QPrecisely of int CAst.t +| QUpTo of int CAst.t | QRepeatStar | QRepeatPlus -type multi = multi_r located +type multi = multi_r CAst.t type rewriting_r = { - rew_orient : bool option located; + rew_orient : bool option CAst.t; rew_repeat : multi; rew_equatn : constr_with_bindings; } -type rewriting = rewriting_r located +type rewriting = rewriting_r CAst.t type dispatch_r = raw_tacexpr option list * (raw_tacexpr option * raw_tacexpr option list) option -type dispatch = dispatch_r located +type dispatch = dispatch_r CAst.t type red_flag_r = | QBeta @@ -117,52 +116,52 @@ type red_flag_r = | QFix | QCofix | QZeta -| QConst of Libnames.reference or_anti list located -| QDeltaBut of Libnames.reference or_anti list located +| QConst of Libnames.reference or_anti list CAst.t +| QDeltaBut of Libnames.reference or_anti list CAst.t -type red_flag = red_flag_r located +type red_flag = red_flag_r CAst.t -type strategy_flag = red_flag list located +type strategy_flag = red_flag list CAst.t type constr_match_pattern_r = | QConstrMatchPattern of Constrexpr.constr_expr | QConstrMatchContext of Id.t option * Constrexpr.constr_expr -type constr_match_pattern = constr_match_pattern_r located +type constr_match_pattern = constr_match_pattern_r CAst.t -type constr_match_branch = (constr_match_pattern * raw_tacexpr) located +type constr_match_branch = (constr_match_pattern * raw_tacexpr) CAst.t -type constr_matching = constr_match_branch list located +type constr_matching = constr_match_branch list CAst.t type goal_match_pattern_r = { q_goal_match_concl : constr_match_pattern; q_goal_match_hyps : (Misctypes.lname * constr_match_pattern) list; } -type goal_match_pattern = goal_match_pattern_r located +type goal_match_pattern = goal_match_pattern_r CAst.t -type goal_match_branch = (goal_match_pattern * raw_tacexpr) located +type goal_match_branch = (goal_match_pattern * raw_tacexpr) CAst.t -type goal_matching = goal_match_branch list located +type goal_matching = goal_match_branch list CAst.t type hintdb_r = | QHintAll -| QHintDbs of Id.t located or_anti list +| QHintDbs of Id.t CAst.t or_anti list -type hintdb = hintdb_r located +type hintdb = hintdb_r CAst.t type move_location_r = -| QMoveAfter of Id.t located or_anti -| QMoveBefore of Id.t located or_anti +| QMoveAfter of Id.t CAst.t or_anti +| QMoveBefore of Id.t CAst.t or_anti | QMoveFirst | QMoveLast -type move_location = move_location_r located +type move_location = move_location_r CAst.t -type pose = (Id.t located or_anti option * Constrexpr.constr_expr) located +type pose = (Id.t CAst.t or_anti option * Constrexpr.constr_expr) CAst.t type assertion_r = | QAssertType of intro_pattern option * Constrexpr.constr_expr * raw_tacexpr option -| QAssertValue of Id.t located or_anti * Constrexpr.constr_expr +| QAssertValue of Id.t CAst.t or_anti * Constrexpr.constr_expr -type assertion = assertion_r located +type assertion = assertion_r CAst.t diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 829f13344c..e986bfc393 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -9,6 +9,7 @@ open Pp open Names open Util +open CAst open Tac2dyn open Tac2expr open Tac2qexpr @@ -38,12 +39,12 @@ let control_core n = kername control_prefix n let pattern_core n = kername pattern_prefix n let global_ref ?loc kn = - Loc.tag ?loc @@ CTacRef (AbsKn (TacConstant kn)) + CAst.make ?loc @@ CTacRef (AbsKn (TacConstant kn)) let constructor ?loc kn args = - let cst = Loc.tag ?loc @@ CTacCst (AbsKn (Other kn)) in + let cst = CAst.make ?loc @@ CTacCst (AbsKn (Other kn)) in if List.is_empty args then cst - else Loc.tag ?loc @@ CTacApp (cst, args) + else CAst.make ?loc @@ CTacApp (cst, args) let std_constructor ?loc name args = constructor ?loc (std_core name) args @@ -53,44 +54,44 @@ let std_proj ?loc name = let thunk e = let t_unit = coq_core "unit" in - let loc = Tac2intern.loc_of_tacexpr e in - let ty = Loc.tag ?loc @@ CTypRef (AbsKn (Other t_unit), []) in - let pat = Loc.tag ?loc @@ CPatVar (Anonymous) in - let pat = Loc.tag ?loc @@ CPatCnv (pat, ty) in - Loc.tag ?loc @@ CTacFun ([pat], e) + let loc = e.loc in + let ty = CAst.make?loc @@ CTypRef (AbsKn (Other t_unit), []) in + let pat = CAst.make ?loc @@ CPatVar (Anonymous) in + let pat = CAst.make ?loc @@ CPatCnv (pat, ty) in + CAst.make ?loc @@ CTacFun ([pat], e) -let of_pair f g (loc, (e1, e2)) = - Loc.tag ?loc @@ CTacApp (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 2)), [f e1; g e2]) +let of_pair f g {loc;v=(e1, e2)} = + CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 2)), [f e1; g e2]) let of_tuple ?loc el = match el with | [] -> - Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 0)) + CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0)) | [e] -> e | el -> let len = List.length el in - Loc.tag ?loc @@ CTacApp (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple len)), el) + CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) -let of_int (loc, n) = - Loc.tag ?loc @@ CTacAtm (AtmInt n) +let of_int {loc;v=n} = + CAst.make ?loc @@ CTacAtm (AtmInt n) let of_option ?loc f opt = match opt with | None -> constructor ?loc (coq_core "None") [] | Some e -> constructor ?loc (coq_core "Some") [f e] let inj_wit ?loc wit x = - Loc.tag ?loc @@ CTacExt (wit, x) + CAst.make ?loc @@ CTacExt (wit, x) -let of_variable (loc, id) = +let of_variable {loc;v=id} = let qid = Libnames.qualid_of_ident id in if Tac2env.is_constructor qid then CErrors.user_err ?loc (str "Invalid identifier") - else Loc.tag ?loc @@ CTacRef (RelId (Loc.tag ?loc qid)) + else CAst.make ?loc @@ CTacRef (RelId (CAst.make ?loc qid)) let of_anti f = function | QExpr x -> f x | QAnti id -> of_variable id -let of_ident (loc, id) = inj_wit ?loc wit_ident id +let of_ident {loc;v=id} = inj_wit ?loc wit_ident id let of_constr c = let loc = Constrexpr_ops.constr_loc c in @@ -109,11 +110,11 @@ let rec of_list ?loc f = function | e :: l -> constructor ?loc (coq_core "::") [f e; of_list ?loc f l] -let of_qhyp (loc, h) = match h with +let of_qhyp {loc;v=h} = match h with | QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] | QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] -let of_bindings (loc, b) = match b with +let of_bindings {loc;v=b} = match b with | QNoBindings -> std_constructor ?loc "NoBindings" [] | QImplicitBindings tl -> @@ -124,7 +125,7 @@ let of_bindings (loc, b) = match b with let of_constr_with_bindings c = of_pair of_open_constr of_bindings c -let rec of_intro_pattern (loc, pat) = match pat with +let rec of_intro_pattern {loc;v=pat} = match pat with | QIntroForthcoming b -> std_constructor ?loc "IntroForthcoming" [of_bool b] | QIntroNaming iname -> @@ -132,7 +133,7 @@ let rec of_intro_pattern (loc, pat) = match pat with | QIntroAction iact -> std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] -and of_intro_pattern_naming (loc, pat) = match pat with +and of_intro_pattern_naming {loc;v=pat} = match pat with | QIntroIdentifier id -> std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] | QIntroFresh id -> @@ -140,7 +141,7 @@ and of_intro_pattern_naming (loc, pat) = match pat with | QIntroAnonymous -> std_constructor ?loc "IntroAnonymous" [] -and of_intro_pattern_action (loc, pat) = match pat with +and of_intro_pattern_action {loc;v=pat} = match pat with | QIntroWildcard -> std_constructor ?loc "IntroWildcard" [] | QIntroOrAndPattern pat -> @@ -150,13 +151,13 @@ and of_intro_pattern_action (loc, pat) = match pat with | QIntroRewrite b -> std_constructor ?loc "IntroRewrite" [of_bool ?loc b] -and of_or_and_intro_pattern (loc, pat) = match pat with +and of_or_and_intro_pattern {loc;v=pat} = match pat with | QIntroOrPattern ill -> std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] | QIntroAndPattern il -> std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] -and of_intro_patterns (loc, l) = +and of_intro_patterns {loc;v=l} = of_list ?loc of_intro_pattern l let of_hyp_location_flag ?loc = function @@ -164,7 +165,7 @@ let of_hyp_location_flag ?loc = function | Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] | Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] -let of_occurrences (loc, occ) = match occ with +let of_occurrences {loc;v=occ} = match occ with | QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] | QAllOccurrencesBut occs -> let map occ = of_anti of_int occ in @@ -183,27 +184,27 @@ let of_hyp_location ?loc ((occs, id), flag) = of_hyp_location_flag ?loc flag; ] -let of_clause (loc, cl) = +let of_clause {loc;v=cl} = let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in let concl = of_occurrences cl.q_concl_occs in - Loc.tag ?loc @@ CTacRec ([ + CAst.make ?loc @@ CTacRec ([ std_proj "on_hyps", hyps; std_proj "on_concl", concl; ]) -let of_destruction_arg (loc, arg) = match arg with +let of_destruction_arg {loc;v=arg} = match arg with | QElimOnConstr c -> let arg = thunk (of_constr_with_bindings c) in std_constructor ?loc "ElimOnConstr" [arg] | QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] | QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] -let of_induction_clause (loc, cl) = +let of_induction_clause {loc;v=cl} = let arg = of_destruction_arg cl.indcl_arg in let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in let in_ = of_option ?loc of_clause cl.indcl_in in - Loc.tag ?loc @@ CTacRec ([ + CAst.make ?loc @@ CTacRec ([ std_proj "indcl_arg", arg; std_proj "indcl_eqn", eqn; std_proj "indcl_as", as_; @@ -238,24 +239,24 @@ let abstract_vars loc vars tac = | Anonymous -> (n + 1, accu) | Name _ -> let get = global_ref ?loc (kername array_prefix "get") in - let args = [of_variable (loc, id0); of_int (loc, n)] in - let e = Loc.tag ?loc @@ CTacApp (get, args) in - let accu = (Loc.tag ?loc @@ CPatVar na, e) :: accu in + let args = [of_variable CAst.(make ?loc id0); of_int CAst.(make ?loc n)] in + let e = CAst.make ?loc @@ CTacApp (get, args) in + let accu = (CAst.make ?loc @@ CPatVar na, e) :: accu in (n + 1, accu) in let (_, bnd) = List.fold_left build_bindings (0, []) vars in - let tac = Loc.tag ?loc @@ CTacLet (false, bnd, tac) in + let tac = CAst.make ?loc @@ CTacLet (false, bnd, tac) in (Name id0, tac) in - Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na], tac) + CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], tac) let of_pattern p = inj_wit ?loc:p.CAst.loc wit_pattern p -let of_conversion (loc, c) = match c with +let of_conversion {loc;v=c} = match c with | QConvert c -> let pat = of_option ?loc of_pattern None in - let c = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar Anonymous], of_constr c) in + let c = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar Anonymous], of_constr c) in of_tuple ?loc [pat; c] | QConvertWith (pat, c) -> let vars = pattern_vars pat in @@ -266,7 +267,7 @@ let of_conversion (loc, c) = match c with let c = abstract_vars loc vars c in of_tuple [pat; c] -let of_repeat (loc, r) = match r with +let of_repeat {loc;v=r} = match r with | QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] | QUpTo n -> std_constructor ?loc "UpTo" [of_int n] | QRepeatStar -> std_constructor ?loc "RepeatStar" [] @@ -276,14 +277,14 @@ let of_orient loc b = if b then std_constructor ?loc "LTR" [] else std_constructor ?loc "RTL" [] -let of_rewriting (loc, rew) = +let of_rewriting {loc;v=rew} = let orient = - let (loc, orient) = rew.rew_orient in + let {loc;v=orient} = rew.rew_orient in of_option ?loc (fun b -> of_orient loc b) orient in let repeat = of_repeat rew.rew_repeat in let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in - Loc.tag ?loc @@ CTacRec ([ + CAst.make ?loc @@ CTacRec ([ std_proj "rew_orient", orient; std_proj "rew_repeat", repeat; std_proj "rew_equatn", equatn; @@ -291,42 +292,42 @@ let of_rewriting (loc, rew) = let of_hyp ?loc id = let hyp = global_ref ?loc (control_core "hyp") in - Loc.tag ?loc @@ CTacApp (hyp, [of_ident id]) + CAst.make ?loc @@ CTacApp (hyp, [of_ident id]) let of_exact_hyp ?loc id = let refine = global_ref ?loc (control_core "refine") in - Loc.tag ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) + CAst.make ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) let of_exact_var ?loc id = let refine = global_ref ?loc (control_core "refine") in - Loc.tag ?loc @@ CTacApp (refine, [thunk (of_variable id)]) + CAst.make ?loc @@ CTacApp (refine, [thunk (of_variable id)]) let of_dispatch tacs = - let (loc, _) = tacs in + let loc = tacs.loc in let default = function | Some e -> thunk e - | None -> thunk (Loc.tag ?loc @@ CTacCst (AbsKn (Tuple 0))) + | None -> thunk (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0))) in - let map e = of_pair default (fun l -> of_list ?loc default l) (Loc.tag ?loc e) in + let map e = of_pair default (fun l -> of_list ?loc default l) (CAst.make ?loc e) in of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs let make_red_flag l = let open Genredexpr in let rec add_flag red = function | [] -> red - | (_, flag) :: lf -> + | {v=flag} :: lf -> let red = match flag with | QBeta -> { red with rBeta = true } | QMatch -> { red with rMatch = true } | QFix -> { red with rFix = true } | QCofix -> { red with rCofix = true } | QZeta -> { red with rZeta = true } - | QConst (loc, l) -> + | QConst {loc;v=l} -> if red.rDelta then CErrors.user_err ?loc Pp.(str "Cannot set both constants to unfold and constants not to unfold"); { red with rConst = red.rConst @ l } - | QDeltaBut (loc, l) -> + | QDeltaBut {loc;v=l} -> if red.rConst <> [] && not red.rDelta then CErrors.user_err ?loc Pp.(str "Cannot set both constants to unfold and constants not to unfold"); @@ -348,10 +349,10 @@ let of_reference r = in of_anti of_ref r -let of_strategy_flag (loc, flag) = +let of_strategy_flag {loc;v=flag} = let open Genredexpr in let flag = make_red_flag flag in - Loc.tag ?loc @@ CTacRec ([ + CAst.make ?loc @@ CTacRec ([ std_proj "rBeta", of_bool ?loc flag.rBeta; std_proj "rMatch", of_bool ?loc flag.rMatch; std_proj "rFix", of_bool ?loc flag.rFix; @@ -361,7 +362,7 @@ let of_strategy_flag (loc, flag) = std_proj "rConst", of_list ?loc of_reference flag.rConst; ]) -let of_hintdb (loc, hdb) = match hdb with +let of_hintdb {loc;v=hdb} = match hdb with | QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None | QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) @@ -375,8 +376,8 @@ let extract_name ?loc oid = match oid with [(match_kind * pattern * (context -> constr array -> 'a))] where the function binds the names from the pattern to the contents of the constr array. *) -let of_constr_matching (loc, m) = - let map (loc, ((ploc, pat), tac)) = +let of_constr_matching {loc;v=m} = + let map {loc;v=({loc=ploc;v=pat}, tac)} = let (knd, pat, na) = match pat with | QConstrMatchPattern pat -> let knd = constructor ?loc (pattern_core "MatchPattern") [] in @@ -391,7 +392,7 @@ let of_constr_matching (loc, m) = let vars = Id.Set.elements vars in let vars = List.map (fun id -> Name id) vars in let e = abstract_vars loc vars tac in - let e = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar na], e) in + let e = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], e) in let pat = inj_wit ?loc:ploc wit_pattern pat in of_tuple [knd; pat; e] in @@ -401,8 +402,8 @@ let of_constr_matching (loc, m) = - a goal pattern: (constr_match list * constr_match) - a branch function (ident array -> context array -> constr array -> context -> 'a) *) -let of_goal_matching (loc, gm) = - let mk_pat (loc, p) = match p with +let of_goal_matching {loc;v=gm} = + let mk_pat {loc;v=p} = match p with | QConstrMatchPattern pat -> let knd = constructor ?loc (pattern_core "MatchPattern") [] in (Anonymous, pat, knd) @@ -411,7 +412,7 @@ let of_goal_matching (loc, gm) = let knd = constructor ?loc (pattern_core "MatchContext") [] in (na, pat, knd) in - let mk_gpat (loc, p) = + let mk_gpat {loc;v=p} = let concl_pat = p.q_goal_match_concl in let hyps_pats = p.q_goal_match_hyps in let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in @@ -433,9 +434,9 @@ let of_goal_matching (loc, gm) = let subst = List.map (fun id -> Name id) vars in (r, hyps, hctx, subst, concl_ctx) in - let map (loc, (pat, tac)) = + let map {loc;v=(pat, tac)} = let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in - let tac = Loc.tag ?loc @@ CTacFun ([Loc.tag ?loc @@ CPatVar cctx], tac) in + let tac = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar cctx], tac) in let tac = abstract_vars loc subst tac in let tac = abstract_vars loc hctx tac in let tac = abstract_vars loc hyps tac in @@ -443,7 +444,7 @@ let of_goal_matching (loc, gm) = in of_list ?loc map gm -let of_move_location (loc, mv) = match mv with +let of_move_location {loc;v=mv} = match mv with | QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] | QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] | QMoveFirst -> std_constructor ?loc "MoveFirst" [] @@ -452,7 +453,7 @@ let of_move_location (loc, mv) = match mv with let of_pose p = of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p -let of_assertion (loc, ast) = match ast with +let of_assertion {loc;v=ast} = match ast with | QAssertType (ipat, c, tac) -> let ipat = of_option of_intro_pattern ipat in let c = of_constr c in diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 3f6c9a55e5..94e1734222 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Tac2dyn open Tac2qexpr @@ -23,15 +22,15 @@ val thunk : raw_tacexpr -> raw_tacexpr val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr -val of_int : int located -> raw_tacexpr +val of_int : int CAst.t -> raw_tacexpr -val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) located -> raw_tacexpr +val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) CAst.t -> raw_tacexpr val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr -val of_variable : Id.t located -> raw_tacexpr +val of_variable : Id.t CAst.t -> raw_tacexpr -val of_ident : Id.t located -> raw_tacexpr +val of_ident : Id.t CAst.t -> raw_tacexpr val of_constr : Constrexpr.constr_expr -> raw_tacexpr @@ -43,7 +42,7 @@ val of_bindings : bindings -> raw_tacexpr val of_intro_pattern : intro_pattern -> raw_tacexpr -val of_intro_patterns : intro_pattern list located -> raw_tacexpr +val of_intro_patterns : intro_pattern list CAst.t -> raw_tacexpr val of_clause : clause -> raw_tacexpr @@ -63,13 +62,13 @@ val of_move_location : move_location -> raw_tacexpr val of_reference : Libnames.reference or_anti -> raw_tacexpr -val of_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr +val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) -val of_exact_hyp : ?loc:Loc.t -> Id.t located -> raw_tacexpr +val of_exact_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) -val of_exact_var : ?loc:Loc.t -> Id.t located -> raw_tacexpr +val of_exact_var : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr (** id ↦ 'Control.refine (fun () => Control.hyp @id') *) val of_dispatch : dispatch -> raw_tacexpr diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 65cdef0f3f..9bc23e91d7 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -37,16 +37,16 @@ let delayed_of_thunk r tac env sigma = let mk_bindings = function | ImplicitBindings l -> Misctypes.ImplicitBindings l | ExplicitBindings l -> - let l = List.map Loc.tag l in + let l = List.map CAst.make l in Misctypes.ExplicitBindings l | NoBindings -> Misctypes.NoBindings let mk_with_bindings (x, b) = (x, mk_bindings b) let rec mk_intro_pattern = function -| IntroForthcoming b -> Loc.tag @@ Misctypes.IntroForthcoming b -| IntroNaming ipat -> Loc.tag @@ Misctypes.IntroNaming (mk_intro_pattern_naming ipat) -| IntroAction ipat -> Loc.tag @@ Misctypes.IntroAction (mk_intro_pattern_action ipat) +| IntroForthcoming b -> CAst.make @@ Misctypes.IntroForthcoming b +| IntroNaming ipat -> CAst.make @@ Misctypes.IntroNaming (mk_intro_pattern_naming ipat) +| IntroAction ipat -> CAst.make @@ Misctypes.IntroAction (mk_intro_pattern_action ipat) and mk_intro_pattern_naming = function | IntroIdentifier id -> Misctypes.IntroIdentifier id @@ -58,7 +58,7 @@ and mk_intro_pattern_action = function | IntroOrAndPattern ipat -> Misctypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) | IntroInjection ipats -> Misctypes.IntroInjection (List.map mk_intro_pattern ipats) | IntroApplyOn (c, ipat) -> - let c = Loc.tag @@ delayed_of_thunk Tac2ffi.constr c in + let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in Misctypes.IntroApplyOn (c, mk_intro_pattern ipat) | IntroRewrite b -> Misctypes.IntroRewrite b @@ -94,7 +94,7 @@ let intros_patterns ev ipat = let apply adv ev cb cl = let map c = let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in - None, Loc.tag (delayed_of_tactic c) + None, CAst.make (delayed_of_tactic c) in let cb = List.map map cb in match cl with @@ -111,8 +111,8 @@ let mk_destruction_arg = function | ElimOnAnonHyp n -> Misctypes.ElimOnAnonHyp n let mk_induction_clause (arg, eqn, as_, occ) = - let eqn = Option.map (fun ipat -> Loc.tag @@ mk_intro_pattern_naming ipat) eqn in - let as_ = Option.map (fun ipat -> Loc.tag @@ mk_or_and_intro_pattern ipat) as_ in + let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in + let as_ = Option.map (fun ipat -> CAst.make @@ mk_or_and_intro_pattern ipat) as_ in let occ = Option.map mk_clause occ in ((None, mk_destruction_arg arg), (eqn, as_), occ) @@ -188,7 +188,7 @@ let forward fst tac ipat c = let assert_ = function | AssertValue (id, c) -> - let ipat = Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id) in + let ipat = CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id) in Tactics.forward true None (Some ipat) c | AssertType (ipat, c, tac) -> let ipat = Option.map mk_intro_pattern ipat in @@ -196,7 +196,7 @@ let assert_ = function Tactics.forward true (Some tac) ipat c let letin_pat_tac ev ipat na c cl = - let ipat = Option.map (fun (b, ipat) -> (b, Loc.tag @@ mk_intro_pattern_naming ipat)) ipat in + let ipat = Option.map (fun (b, ipat) -> (b, CAst.make @@ mk_intro_pattern_naming ipat)) ipat in let cl = mk_clause cl in Tactics.letin_pat_tac ev ipat na c cl @@ -420,7 +420,7 @@ let inversion knd arg pat ids = begin match pat with | None -> Proofview.tclUNIT None | Some (IntroAction (IntroOrAndPattern p)) -> - Proofview.tclUNIT (Some (Loc.tag @@ mk_or_and_intro_pattern p)) + Proofview.tclUNIT (Some (CAst.make @@ mk_or_and_intro_pattern p)) | Some _ -> Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") end >>= fun pat -> @@ -433,7 +433,7 @@ let inversion knd arg pat ids = Inv.inv_clause knd pat ids (NamedHyp id) | Some (_, Misctypes.ElimOnConstr c) -> let open Misctypes in - let anon = Loc.tag @@ IntroNaming IntroAnonymous in + let anon = CAst.make @@ IntroNaming IntroAnonymous in Tactics.specialize c (Some anon) >>= fun () -> Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) end -- cgit v1.2.3 From 4718f5afec0538781195fdac82ffefb0b7c57535 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 5 Mar 2018 23:38:52 +0100 Subject: [coq] Adapt to coq/coq#6837. Minor. --- src/g_ltac2.ml4 | 8 ++++---- src/tac2core.ml | 6 +++--- src/tac2entries.ml | 2 +- src/tac2quote.ml | 3 +-- 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index f4818f4ece..6189bb18cc 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -372,8 +372,8 @@ GEXTEND Gram [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] ; globref: - [ [ "&"; id = Prim.ident -> Libnames.Ident (Loc.tag ~loc:!@loc id) - | qid = Prim.qualid -> Libnames.Qualid (Loc.tag ~loc:!@loc qid.CAst.v) + [ [ "&"; id = Prim.ident -> CAst.make ~loc:!@loc (Libnames.Ident id) + | qid = Prim.qualid -> CAst.map (fun qid -> Libnames.Qualid qid) qid ] ] ; END @@ -667,8 +667,8 @@ GEXTEND Gram ] ] ; refglobal: - [ [ "&"; id = Prim.ident -> QExpr (Libnames.Ident (Loc.tag ~loc:!@loc id)) - | qid = Prim.qualid -> QExpr (Libnames.Qualid Loc.(tag ~loc:!@loc qid.CAst.v)) + [ [ "&"; id = Prim.ident -> QExpr (CAst.make ~loc:!@loc @@ Libnames.Ident id) + | qid = Prim.qualid -> QExpr (CAst.make ~loc:!@loc @@ Libnames.Qualid qid.CAst.v) | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index c6c3f26b6b..cf9af526d4 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -910,13 +910,13 @@ let () = let () = let intern self ist qid = match qid with - | Libnames.Ident (_, id) -> + | {CAst.v=Libnames.Ident id} -> GlbVal (Globnames.VarRef id), gtypref t_reference - | Libnames.Qualid (loc, qid) -> + | {CAst.loc;v=Libnames.Qualid qid} -> let gr = try Nametab.locate qid with Not_found -> - Nametab.error_global_not_found ?loc qid + Nametab.error_global_not_found (CAst.make ?loc qid) in GlbVal gr, gtypref t_reference in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index e4bddf439b..430142832b 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -831,7 +831,7 @@ end (** Printing *) let print_ltac ref = - let (loc, qid) = qualid_of_reference ref in + let {loc;v=qid} = qualid_of_reference ref in if Tac2env.is_constructor qid then let kn = try Tac2env.locate_constructor qid diff --git a/src/tac2quote.ml b/src/tac2quote.ml index e986bfc393..2a0230b779 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -344,8 +344,7 @@ let make_red_flag l = let of_reference r = let of_ref ref = - let loc = Libnames.loc_of_reference ref in - inj_wit ?loc wit_reference ref + inj_wit ?loc:ref.loc wit_reference ref in of_anti of_ref r -- cgit v1.2.3 From 7dbf6dbd73f3a828bbb58458191912f895cf7779 Mon Sep 17 00:00:00 2001 From: Armael Date: Tue, 13 Mar 2018 16:13:18 +0100 Subject: Fix a typo --- doc/ltac2.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index cd0d8f4325..10a65fce44 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -875,7 +875,7 @@ Due to conflicts, a few syntactic rules have changed. `try`, `repeat`, `do`, `once`, `progress`, `time`, `abstract`. - `idtac` is no more. Either use `()` if you expect nothing to happen, `(fun () => ())` if you want a thunk (see next section), or use printing - primitives from the `Message` module if you wand to display something. + primitives from the `Message` module if you want to display something. ## Tactic delay -- cgit v1.2.3 From e31fa0ecb1f823cc5735fa63330f430e2c0d96e2 Mon Sep 17 00:00:00 2001 From: Armael Date: Tue, 13 Mar 2018 17:16:55 +0100 Subject: Fix another typo in the documentation's grammar for open variants --- doc/ltac2.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 10a65fce44..9ba227c285 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -127,7 +127,7 @@ TYPEDEF := | TYPE | "[" CONSTRUCTORDEF₀ "|" ... "|" CONSTRUCTORDEFₙ "]" | "{" FIELDDEF₀ ";" ... ";" FIELDDEFₙ "}" -| "[" "..." "]" +| "[" ".." "]" CONSTRUCTORDEF := | IDENT ( "(" TYPE₀ "," ... "," TYPE₀ ")" ) -- cgit v1.2.3 From 33d7e374b449c754fcdf623e98cb717faaf241a5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 4 Dec 2017 17:45:50 +0100 Subject: Fixup strict mode for patterns --- src/tac2core.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index fe4912a6c5..32c873088c 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -895,7 +895,8 @@ let () = let intern self ist c = let env = ist.Genintern.genv in let sigma = Evd.from_env env in - let _, pat = Constrintern.intern_constr_pattern env sigma ~as_type:false c in + let warn = if !Ltac_plugin.Tacintern.strict_check then fun x -> x else Constrintern.for_grammar in + let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in GlbVal pat, gtypref t_pattern in let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in -- cgit v1.2.3 From 92880aa90abe810115227e1e2dd67355d7f5c872 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 5 Dec 2017 13:13:11 +0100 Subject: Fix printing of toplevel record values. --- src/tac2print.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/tac2print.ml b/src/tac2print.ml index 8f61686988..cab1530d15 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -390,7 +390,9 @@ let rec pr_valexpr env sigma v t = match kind t with let knc = change_kn_label kn id in let args = pr_constrargs env sigma params args tpe in hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - | GTydRec rcd -> str "{ TODO }" + | GTydRec rcd -> + let (_, args) = Tac2ffi.to_block v in + pr_record env sigma params args rcd | GTydOpn -> begin match Tac2ffi.to_open v with | (knc, [||]) -> pr_constructor knc @@ -417,6 +419,17 @@ and pr_constrargs env sigma params args tpe = let args = List.combine args tpe in prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args +and pr_record env sigma params args rcd = + let subst = Array.of_list params in + let map (id, _, tpe) = (id, subst_type subst tpe) in + let rcd = List.map map rcd in + let args = Array.to_list args in + let fields = List.combine rcd args in + let pr_field ((id, t), arg) = + Id.print id ++ spc () ++ str ":=" ++ spc () ++ pr_valexpr env sigma arg t + in + str "{" ++ spc () ++ prlist_with_sep pr_semicolon pr_field fields ++ spc () ++ str "}" + and pr_val_list env sigma args tpe = let pr v = pr_valexpr env sigma v tpe in str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" -- cgit v1.2.3 From 15a9b4a7a99498895addb74ffa9a711ea354c651 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 2 Apr 2018 03:51:52 +0200 Subject: [coq] Adapt to coq/coq#6960. Minor, a couple of tactic-related types moved. --- src/tac2stdlib.ml | 6 +++--- src/tac2tactics.ml | 18 +++++++++--------- src/tac2tactics.mli | 2 +- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 28d4967874..9ed3d5b32e 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -186,9 +186,9 @@ let to_strategy v = match Value.to_int v with let strategy = make_to_repr to_strategy let to_inversion_kind v = match Value.to_int v with -| 0 -> Misctypes.SimpleInversion -| 1 -> Misctypes.FullInversion -| 2 -> Misctypes.FullInversionClear +| 0 -> Inv.SimpleInversion +| 1 -> Inv.FullInversion +| 2 -> Inv.FullInversionClear | _ -> assert false let inversion_kind = make_to_repr to_inversion_kind diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 9bc23e91d7..3f2385a8d6 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -106,9 +106,9 @@ let apply adv ev cb cl = let mk_destruction_arg = function | ElimOnConstr c -> let c = c >>= fun c -> return (mk_with_bindings c) in - Misctypes.ElimOnConstr (delayed_of_tactic c) -| ElimOnIdent id -> Misctypes.ElimOnIdent CAst.(make id) -| ElimOnAnonHyp n -> Misctypes.ElimOnAnonHyp n + Tactics.ElimOnConstr (delayed_of_tactic c) +| ElimOnIdent id -> Tactics.ElimOnIdent CAst.(make id) +| ElimOnAnonHyp n -> Tactics.ElimOnAnonHyp n let mk_induction_clause (arg, eqn, as_, occ) = let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in @@ -342,9 +342,9 @@ let on_destruction_arg tac ev arg = Proofview.tclEVARMAP >>= fun sigma' -> let flags = tactic_infer_flags ev in let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in - Proofview.tclUNIT (Some sigma', Misctypes.ElimOnConstr (c, lbind)) - | ElimOnIdent id -> Proofview.tclUNIT (None, Misctypes.ElimOnIdent CAst.(make id)) - | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Misctypes.ElimOnAnonHyp n) + Proofview.tclUNIT (Some sigma', Tactics.ElimOnConstr (c, lbind)) + | ElimOnIdent id -> Proofview.tclUNIT (None, Tactics.ElimOnIdent CAst.(make id)) + | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Tactics.ElimOnAnonHyp n) in arg >>= fun (sigma', arg) -> let arg = Some (clear, arg) in @@ -427,11 +427,11 @@ let inversion knd arg pat ids = let inversion _ arg = begin match arg with | None -> assert false - | Some (_, Misctypes.ElimOnAnonHyp n) -> + | Some (_, Tactics.ElimOnAnonHyp n) -> Inv.inv_clause knd pat ids (AnonHyp n) - | Some (_, Misctypes.ElimOnIdent {CAst.v=id}) -> + | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> Inv.inv_clause knd pat ids (NamedHyp id) - | Some (_, Misctypes.ElimOnConstr c) -> + | Some (_, Tactics.ElimOnConstr c) -> let open Misctypes in let anon = CAst.make @@ IntroNaming IntroAnonymous in Tactics.specialize c (Some anon) >>= fun () -> diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 52e8a94c19..631e36b5ae 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -118,7 +118,7 @@ val eauto : Hints.debug -> int option -> int option -> constr thunk list -> val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> Id.t list option -> unit Proofview.tactic -val inversion : Misctypes.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic +val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic val contradiction : constr_with_bindings option -> unit tactic -- cgit v1.2.3 From a255ba63f82652ac7dae4a39e80c35f813d0e5a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 11 Apr 2018 08:30:56 +0200 Subject: Fix compilation w.r.t. coq/coq#7213. --- src/tac2core.ml | 4 ++-- src/tac2match.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 32c873088c..9a3aed3442 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -557,7 +557,7 @@ let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_list of_pair ans |] in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_list of_pair ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in pf_apply begin fun env sigma -> @@ -589,7 +589,7 @@ let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c - | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> let ans = Id.Map.bindings sub in let ans = Array.map_of_list snd ans in - let ans = Value.of_tuple [| Value.of_constr m_ctx; Value.of_array Value.of_constr ans |] in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_array Value.of_constr ans |] in Proofview.tclOR (return ans) (fun _ -> of_ans s) in pf_apply begin fun env sigma -> diff --git a/src/tac2match.ml b/src/tac2match.ml index 5035c9dba6..a3140eabea 100644 --- a/src/tac2match.ml +++ b/src/tac2match.ml @@ -170,7 +170,7 @@ module PatternMatching (E:StaticEnvironment) = struct let nctx = { subst } in match merge ctx nctx with | None -> (map s (e, info)).stream k ctx - | Some nctx -> Proofview.tclOR (k (Some m_ctx) nctx) (fun e -> (map s e).stream k ctx) + | Some nctx -> Proofview.tclOR (k (Some (Lazy.force m_ctx)) nctx) (fun e -> (map s e).stream k ctx) } in map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error -- cgit v1.2.3 From 513884e806a4db39ae6402333833ecc4f70a0fdc Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Apr 2018 08:00:43 +0200 Subject: Fixing printing level for subtypes of a type constructor. --- src/tac2print.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2print.ml b/src/tac2print.ml index cab1530d15..9c530dfc51 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -49,7 +49,7 @@ let pr_glbtype_gen pr lvl c = | T5_r | T5_l | T2 | T1 -> fun x -> x | T0 -> paren in - paren (pr_glbtype lvl t ++ spc () ++ pr_typref kn) + paren (pr_glbtype T1 t ++ spc () ++ pr_typref kn) | GTypRef (Other kn, tl) -> let paren = match lvl with | T5_r | T5_l | T2 | T1 -> fun x -> x -- cgit v1.2.3 From 5f9df6d084bb24ea9b26a74387b79656e4123ee0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Apr 2018 08:05:31 +0200 Subject: Allowing formatting break around a printed type. --- src/tac2intern.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index b1dd8f7f51..99965c4ed5 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -356,8 +356,8 @@ let rec unify0 env t1 t2 = match kind env t1, kind env t2 with let unify ?loc env t1 t2 = try unify0 env t1 t2 with CannotUnify (u1, u2) -> - user_err ?loc (str "This expression has type " ++ pr_glbtype env t1 ++ - str " but an expression was expected of type " ++ pr_glbtype env t2) + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env t1 ++ + spc () ++ str "but an expression was expected of type" ++ spc () ++ pr_glbtype env t2) let unify_arrow ?loc env ft args = let ft0 = ft in @@ -372,11 +372,11 @@ let unify_arrow ?loc env ft args = iter ft args true | GTypRef _, _ :: _ -> if is_fun then - user_err ?loc (str "This function has type " ++ pr_glbtype env ft0 ++ - str " and is applied to too many arguments") + user_err ?loc (str "This function has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is applied to too many arguments") else - user_err ?loc (str "This expression has type " ++ pr_glbtype env ft0 ++ - str " and is not a function") + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is not a function") in iter ft args false @@ -475,13 +475,13 @@ let check_elt_empty loc env t = match kind env t with | GTypVar _ -> user_err ?loc (str "Cannot infer an empty type for this expression") | GTypArrow _ | GTypRef (Tuple _, _) -> - user_err ?loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") | GTypRef (Other kn, _) -> let def = Tac2env.interp_type kn in match def with | _, GTydAlg { galg_constructors = [] } -> kn | _ -> - user_err ?loc (str "Type " ++ pr_glbtype env t ++ str " is not an empty type") + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") let check_unit ?loc t = let env = empty_env () in -- cgit v1.2.3 From 8db84eef2cf6a5f35e9ef7e4bea9725f29550845 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 14 May 2018 03:59:55 +0200 Subject: Adapt to fix/cofix changes in Coq (coq/coq#7196) c.f. https://github.com/coq/coq/pull/7196 --- src/tac2stdlib.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index 9ed3d5b32e..be7c76744d 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -501,12 +501,12 @@ end let () = define_prim0 "tac_admit" Proofview.give_up -let () = define_prim2 "tac_fix" (option ident) int begin fun idopt n -> - Tactics.fix idopt n +let () = define_prim2 "tac_fix" ident int begin fun ident n -> + Tactics.fix ident n end -let () = define_prim1 "tac_cofix" (option ident) begin fun idopt -> - Tactics.cofix idopt +let () = define_prim1 "tac_cofix" ident begin fun ident -> + Tactics.cofix ident end let () = define_prim1 "tac_clear" (list ident) begin fun ids -> -- cgit v1.2.3 From 5eb92624f33afb4d2a390f7c7b80552e3e04bc81 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 25 May 2018 16:03:01 +0200 Subject: Renaming smartmap and fold_map according to Coq PR #7177. --- src/tac2entries.ml | 4 ++-- src/tac2intern.ml | 30 +++++++++++++++--------------- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 430142832b..8728a513cf 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -248,12 +248,12 @@ let open_typext i obj = perform_typext (Exactly i) obj let subst_typext (subst, e) = let open Mod_subst in let subst_data data = - let edata_args = List.smartmap (fun e -> subst_type subst e) data.edata_args in + let edata_args = List.Smart.map (fun e -> subst_type subst e) data.edata_args in if edata_args == data.edata_args then data else { data with edata_args } in let typext_type = subst_kn subst e.typext_type in - let typext_expr = List.smartmap subst_data e.typext_expr in + let typext_expr = List.Smart.map subst_data e.typext_expr in if typext_type == e.typext_type && typext_expr == e.typext_expr then e else diff --git a/src/tac2intern.ml b/src/tac2intern.ml index b1dd8f7f51..75fca938f4 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -840,7 +840,7 @@ and intern_let_rec env loc ids el e = let env = push_name na (monomorphic (GTypVar id)) env in (env, (loc, na, t, e, id)) in - let (env, el) = List.fold_map map env el in + let (env, el) = List.fold_left_map map env el in let fold (loc, na, tc, e, id) (el, tl) = let loc_e = e.loc in let (e, t) = intern_rec env e in @@ -1314,7 +1314,7 @@ let rec subst_type subst t = match t with else GTypArrow (t1', t2') | GTypRef (kn, tl) -> let kn' = subst_or_tuple subst_kn subst kn in - let tl' = List.smartmap (fun t -> subst_type subst t) tl in + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in if kn' == kn && tl' == tl then t else GTypRef (kn', tl') let rec subst_expr subst e = match e with @@ -1328,7 +1328,7 @@ let rec subst_expr subst e = match e with GTacLet (r, bs, subst_expr subst e) | GTacCst (t, n, el) as e0 -> let t' = subst_or_tuple subst_kn subst t in - let el' = List.smartmap (fun e -> subst_expr subst e) el in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in if t' == t && el' == el then e0 else GTacCst (t', n, el') | GTacCse (e, ci, cse0, cse1) -> let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in @@ -1362,19 +1362,19 @@ let rec subst_expr subst e = match e with if arg' == arg then e else GTacExt (tag, arg') | GTacOpn (kn, el) as e0 -> let kn' = subst_kn subst kn in - let el' = List.smartmap (fun e -> subst_expr subst e) el in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in if kn' == kn && el' == el then e0 else GTacOpn (kn', el') let subst_typedef subst e = match e with | GTydDef t -> - let t' = Option.smartmap (fun t -> subst_type subst t) t in + let t' = Option.Smart.map (fun t -> subst_type subst t) t in if t' == t then e else GTydDef t' | GTydAlg galg -> let map (c, tl as p) = - let tl' = List.smartmap (fun t -> subst_type subst t) tl in + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in if tl' == tl then p else (c, tl') in - let constrs' = List.smartmap map galg.galg_constructors in + let constrs' = List.Smart.map map galg.galg_constructors in if constrs' == galg.galg_constructors then e else GTydAlg { galg with galg_constructors = constrs' } | GTydRec fields -> @@ -1382,7 +1382,7 @@ let subst_typedef subst e = match e with let t' = subst_type subst t in if t' == t then p else (c, mut, t') in - let fields' = List.smartmap map fields in + let fields' = List.Smart.map map fields in if fields' == fields then e else GTydRec fields' | GTydOpn -> GTydOpn @@ -1408,7 +1408,7 @@ let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') | CTypRef (ref, tl) -> let ref' = subst_or_relid subst ref in - let tl' = List.smartmap (fun t -> subst_rawtype subst t) tl in + let tl' = List.Smart.map (fun t -> subst_rawtype subst t) tl in if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') let subst_tacref subst ref = match ref with @@ -1429,7 +1429,7 @@ let subst_projection subst prj = match prj with let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with | CPatVar _ -> p | CPatRef (c, pl) -> - let pl' = List.smartmap (fun p -> subst_rawpattern subst p) pl in + let pl' = List.Smart.map (fun p -> subst_rawpattern subst p) pl in let c' = subst_or_relid subst c in if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') | CPatCnv (pat, ty) -> @@ -1448,12 +1448,12 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' | CTacFun (bnd, e) -> let map pat = subst_rawpattern subst pat in - let bnd' = List.smartmap map bnd in + let bnd' = List.Smart.map map bnd in let e' = subst_rawexpr subst e in if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') | CTacApp (e, el) -> let e' = subst_rawexpr subst e in - let el' = List.smartmap (fun e -> subst_rawexpr subst e) el in + let el' = List.Smart.map (fun e -> subst_rawexpr subst e) el in if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') | CTacLet (isrec, bnd, e) -> let map (na, e as p) = @@ -1461,7 +1461,7 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with let e' = subst_rawexpr subst e in if na' == na && e' == e then p else (na', e') in - let bnd' = List.smartmap map bnd in + let bnd' = List.Smart.map map bnd in let e' = subst_rawexpr subst e in if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') | CTacCnv (e, c) -> @@ -1479,7 +1479,7 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with if p' == p && e' == e then x else (p', e') in let e' = subst_rawexpr subst e in - let bl' = List.smartmap map bl in + let bl' = List.Smart.map map bl in if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') | CTacRec el -> let map (prj, e as p) = @@ -1487,7 +1487,7 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with let e' = subst_rawexpr subst e in if prj' == prj && e' == e then p else (prj', e') in - let el' = List.smartmap map el in + let el' = List.Smart.map map el in if el' == el then t else CAst.make ?loc @@ CTacRec el' | CTacPrj (e, prj) -> let prj' = subst_projection subst prj in -- cgit v1.2.3 From e15c228709351f5001f6a10765a816cebcf900cc Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 25 May 2018 16:04:18 +0200 Subject: Renaming global_reference according to Coq PR #6156. --- src/tac2ffi.mli | 6 +++--- src/tac2quote.mli | 2 +- src/tac2tactics.mli | 23 +++++++++++------------ 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index 1bf86b516a..d801c4f605 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -131,9 +131,9 @@ val of_constant : Constant.t -> valexpr val to_constant : valexpr -> Constant.t val constant : Constant.t repr -val of_reference : Globnames.global_reference -> valexpr -val to_reference : valexpr -> Globnames.global_reference -val reference : Globnames.global_reference repr +val of_reference : GlobRef.t -> valexpr +val to_reference : valexpr -> GlobRef.t +val reference : GlobRef.t repr val of_ext : 'a Val.tag -> 'a -> valexpr val to_ext : 'a Val.tag -> valexpr -> 'a diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 18533a8281..cc58144901 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -89,7 +89,7 @@ val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag val wit_ident : (Id.t, Id.t) Arg.tag -val wit_reference : (Libnames.reference, Globnames.global_reference) Arg.tag +val wit_reference : (Libnames.reference, GlobRef.t) Arg.tag (** Beware, at the raw level, [Qualid [id]] has not the same meaning as [Ident id]. The first is an unqualified global reference, the second is the dynamic reference to id. *) diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli index 631e36b5ae..026673acbf 100644 --- a/src/tac2tactics.mli +++ b/src/tac2tactics.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Globnames open Tac2expr open EConstr open Genredexpr @@ -57,16 +56,16 @@ val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> val reduce : Redexpr.red_expr -> clause -> unit tactic -val simpl : global_reference glob_red_flag -> +val simpl : GlobRef.t glob_red_flag -> (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic -val cbv : global_reference glob_red_flag -> clause -> unit tactic +val cbv : GlobRef.t glob_red_flag -> clause -> unit tactic -val cbn : global_reference glob_red_flag -> clause -> unit tactic +val cbn : GlobRef.t glob_red_flag -> clause -> unit tactic -val lazy_ : global_reference glob_red_flag -> clause -> unit tactic +val lazy_ : GlobRef.t glob_red_flag -> clause -> unit tactic -val unfold : (global_reference * occurrences) list -> clause -> unit tactic +val unfold : (GlobRef.t * occurrences) list -> clause -> unit tactic val pattern : (constr * occurrences) list -> clause -> unit tactic @@ -78,16 +77,16 @@ val eval_red : constr -> constr tactic val eval_hnf : constr -> constr tactic -val eval_simpl : global_reference glob_red_flag -> +val eval_simpl : GlobRef.t glob_red_flag -> (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic -val eval_cbv : global_reference glob_red_flag -> constr -> constr tactic +val eval_cbv : GlobRef.t glob_red_flag -> constr -> constr tactic -val eval_cbn : global_reference glob_red_flag -> constr -> constr tactic +val eval_cbn : GlobRef.t glob_red_flag -> constr -> constr tactic -val eval_lazy : global_reference glob_red_flag -> constr -> constr tactic +val eval_lazy : GlobRef.t glob_red_flag -> constr -> constr tactic -val eval_unfold : (global_reference * occurrences) list -> constr -> constr tactic +val eval_unfold : (GlobRef.t * occurrences) list -> constr -> constr tactic val eval_fold : constr list -> constr -> constr tactic @@ -122,4 +121,4 @@ val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> val contradiction : constr_with_bindings option -> unit tactic -val firstorder : unit thunk option -> global_reference list -> Id.t list -> unit tactic +val firstorder : unit thunk option -> GlobRef.t list -> Id.t list -> unit tactic -- cgit v1.2.3 From 1cd62aa20ba3f9fb206f2926c8e47dd463dee863 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sun, 20 May 2018 21:15:44 +0200 Subject: Adapt to coq/coq#7558. Trivial renaming of the vernacular parsing entry point. --- src/g_ltac2.ml4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 6189bb18cc..ac65495fe5 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -841,8 +841,8 @@ END let _ = let mode = { Proof_global.name = "Ltac2"; - set = (fun () -> set_command_entry tac2mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + set = (fun () -> Pvernac.set_command_entry tac2mode); + reset = (fun () -> Pvernac.(set_command_entry Vernac_.noedit_mode)); } in Proof_global.register_proof_mode mode -- cgit v1.2.3 From da142cf79f44c163db9c290947b34860ac902832 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 May 2018 19:16:24 +0200 Subject: Fix w.r.t. coq/coq#7521. --- src/tac2core.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 9a3aed3442..8d0ef675fe 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -502,7 +502,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> let sigma = Proofview.Goal.sigma gl in let has_var = try - let _ = Environ.lookup_named_val id (Environ.named_context_val env) in + let _ = Environ.lookup_named_val id env in true with Not_found -> false in -- cgit v1.2.3 From 1bbeba35eb385f813a0e4b6d25a437f9bab8191b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 18 Jun 2018 14:32:58 +0200 Subject: Fixing a batch of deprecation warnings. --- src/g_ltac2.ml4 | 7 +++---- src/tac2core.ml | 9 ++++----- src/tac2entries.ml | 5 +++-- src/tac2entries.mli | 4 ++-- src/tac2expr.mli | 7 +++---- src/tac2intern.ml | 2 +- src/tac2qexpr.mli | 2 +- src/tac2stdlib.ml | 10 +++++----- src/tac2tactics.ml | 40 ++++++++++++++++++++-------------------- src/tac2types.mli | 4 ++-- 10 files changed, 44 insertions(+), 46 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index ac65495fe5..b59a5e184e 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -12,7 +12,6 @@ open Names open Tok open Pcoq open Constrexpr -open Misctypes open Tac2expr open Tac2qexpr open Ltac_plugin @@ -799,15 +798,15 @@ GEXTEND Gram Pcoq.Constr.operconstr: LEVEL "0" [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) + CAst.make ~loc:!@loc (CHole (None, Namegen.IntroAnonymous, Some arg)) | test_ampersand_ident; "&"; id = Prim.ident -> let tac = Tac2quote.of_exact_hyp ~loc:!@loc (CAst.make ~loc:!@loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) + CAst.make ~loc:!@loc (CHole (None, Namegen.IntroAnonymous, Some arg)) | test_dollar_ident; "$"; id = Prim.ident -> let id = Loc.tag ~loc:!@loc id in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in - CAst.make ~loc:!@loc (CHole (None, IntroAnonymous, Some arg)) + CAst.make ~loc:!@loc (CHole (None, Namegen.IntroAnonymous, Some arg)) ] ] ; END diff --git a/src/tac2core.ml b/src/tac2core.ml index 8d0ef675fe..5f33374486 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -948,14 +948,14 @@ let () = let lfun = Tac2interp.set_env ist Id.Map.empty in let ist = Ltac_plugin.Tacinterp.default_ist () in let ist = { ist with Geninterp.lfun = lfun } in - let tac = (Obj.magic Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in + let tac = (Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in Proofview.tclOR tac wrap >>= fun () -> return v_unit in let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in let print env tac = - str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic (Obj.magic env) tac ++ str ")" + str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" in let obj = { ml_intern = intern; @@ -981,9 +981,8 @@ let () = let ist = Tac2interp.get_env ist in let c = Id.Map.find id ist.env_ist in let c = Value.to_constr c in - let evdref = ref sigma in - let () = Typing.e_check env evdref c concl in - (c, !evdref) + let sigma = Typing.check env sigma c concl in + (c, sigma) in Pretyping.register_constr_interp0 wit_ltac2_quotation interp diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 8728a513cf..c85ffb2539 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -748,7 +748,7 @@ let perform_eval e = let v = Tac2interp.interp Tac2interp.empty_environment e in let selector, proof = try - Proof_bullet.get_default_goal_selector (), + Goal_select.get_default_goal_selector (), Proof_global.give_me_the_proof () with Proof_global.NoCurrentProof -> let sigma = Evd.from_env env in @@ -759,6 +759,7 @@ let perform_eval e = | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l v | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id v | Vernacexpr.SelectAll -> v + | Vernacexpr.SelectAlreadyFocused -> assert false (** TODO **) in (** HACK: the API doesn't allow to return a value *) let ans = ref None in @@ -864,7 +865,7 @@ let print_ltac ref = let solve default tac = let status = Proof_global.with_current_proof begin fun etac p -> let with_end_tac = if default then Some etac else None in - let g = Proof_bullet.get_default_goal_selector () in + let g = Goal_select.get_default_goal_selector () in let (p, status) = Pfedit.solve g None tac ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index cfb58ea383..ad7624b7d0 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -13,13 +13,13 @@ open Tac2expr (** {5 Toplevel definitions} *) val register_ltac : ?local:bool -> ?mut:bool -> rec_flag -> - (Misctypes.lname * raw_tacexpr) list -> unit + (Names.lname * raw_tacexpr) list -> unit val register_type : ?local:bool -> rec_flag -> (qualid CAst.t * redef_flag * raw_quant_typedef) list -> unit val register_primitive : ?local:bool -> - Misctypes.lident -> raw_typexpr -> ml_tactic_name -> unit + Names.lident -> raw_typexpr -> ml_tactic_name -> unit val register_struct : ?local:bool -> strexpr -> unit diff --git a/src/tac2expr.mli b/src/tac2expr.mli index ddffd13a31..1f2c3ebf3b 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Libnames @@ -78,7 +77,7 @@ type glb_typedef = type type_scheme = int * int glb_typexpr -type raw_quant_typedef = Misctypes.lident list * raw_typedef +type raw_quant_typedef = Names.lident list * raw_typedef type glb_quant_typedef = int * glb_typedef (** {5 Term syntax} *) @@ -159,11 +158,11 @@ type sexpr = (** {5 Toplevel statements} *) type strexpr = -| StrVal of mutable_flag * rec_flag * (Misctypes.lname * raw_tacexpr) list +| StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list (** Term definition *) | StrTyp of rec_flag * (qualid CAst.t * redef_flag * raw_quant_typedef) list (** Type definition *) -| StrPrm of Misctypes.lident * raw_typexpr * ml_tactic_name +| StrPrm of Names.lident * raw_typexpr * ml_tactic_name (** External definition *) | StrSyn of sexpr list * int option * raw_tacexpr (** Syntactic extensions *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 75fca938f4..86d81ef5d2 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -12,7 +12,7 @@ open CAst open CErrors open Names open Libnames -open Misctypes +open Locus open Tac2env open Tac2print open Tac2expr diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 05b9f4141f..3f0c591e63 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -135,7 +135,7 @@ type constr_matching = constr_match_branch list CAst.t type goal_match_pattern_r = { q_goal_match_concl : constr_match_pattern; - q_goal_match_hyps : (Misctypes.lname * constr_match_pattern) list; + q_goal_match_hyps : (Names.lname * constr_match_pattern) list; } type goal_match_pattern = goal_match_pattern_r CAst.t diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml index be7c76744d..ffef2c05fd 100644 --- a/src/tac2stdlib.ml +++ b/src/tac2stdlib.ml @@ -194,10 +194,10 @@ let to_inversion_kind v = match Value.to_int v with let inversion_kind = make_to_repr to_inversion_kind let to_move_location = function -| ValInt 0 -> Misctypes.MoveFirst -| ValInt 1 -> Misctypes.MoveLast -| ValBlk (0, [|id|]) -> Misctypes.MoveAfter (Value.to_ident id) -| ValBlk (1, [|id|]) -> Misctypes.MoveBefore (Value.to_ident id) +| ValInt 0 -> Logic.MoveFirst +| ValInt 1 -> Logic.MoveLast +| ValBlk (0, [|id|]) -> Logic.MoveAfter (Value.to_ident id) +| ValBlk (1, [|id|]) -> Logic.MoveBefore (Value.to_ident id) | _ -> assert false let move_location = make_to_repr to_move_location @@ -424,7 +424,7 @@ let () = define_prim2 "tac_move" ident move_location begin fun id mv -> end let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> - let mv = Option.default Misctypes.MoveLast mv in + let mv = Option.default Logic.MoveLast mv in Tactics.intro_move id mv end diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 3f2385a8d6..3c464469f0 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -35,38 +35,38 @@ let delayed_of_thunk r tac env sigma = delayed_of_tactic (thaw r tac) env sigma let mk_bindings = function -| ImplicitBindings l -> Misctypes.ImplicitBindings l +| ImplicitBindings l -> Tactypes.ImplicitBindings l | ExplicitBindings l -> let l = List.map CAst.make l in - Misctypes.ExplicitBindings l -| NoBindings -> Misctypes.NoBindings + Tactypes.ExplicitBindings l +| NoBindings -> Tactypes.NoBindings let mk_with_bindings (x, b) = (x, mk_bindings b) let rec mk_intro_pattern = function -| IntroForthcoming b -> CAst.make @@ Misctypes.IntroForthcoming b -| IntroNaming ipat -> CAst.make @@ Misctypes.IntroNaming (mk_intro_pattern_naming ipat) -| IntroAction ipat -> CAst.make @@ Misctypes.IntroAction (mk_intro_pattern_action ipat) +| IntroForthcoming b -> CAst.make @@ Tactypes.IntroForthcoming b +| IntroNaming ipat -> CAst.make @@ Tactypes.IntroNaming (mk_intro_pattern_naming ipat) +| IntroAction ipat -> CAst.make @@ Tactypes.IntroAction (mk_intro_pattern_action ipat) and mk_intro_pattern_naming = function -| IntroIdentifier id -> Misctypes.IntroIdentifier id -| IntroFresh id -> Misctypes.IntroFresh id -| IntroAnonymous -> Misctypes.IntroAnonymous +| IntroIdentifier id -> Namegen.IntroIdentifier id +| IntroFresh id -> Namegen.IntroFresh id +| IntroAnonymous -> Namegen.IntroAnonymous and mk_intro_pattern_action = function -| IntroWildcard -> Misctypes.IntroWildcard -| IntroOrAndPattern ipat -> Misctypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) -| IntroInjection ipats -> Misctypes.IntroInjection (List.map mk_intro_pattern ipats) +| IntroWildcard -> Tactypes.IntroWildcard +| IntroOrAndPattern ipat -> Tactypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) +| IntroInjection ipats -> Tactypes.IntroInjection (List.map mk_intro_pattern ipats) | IntroApplyOn (c, ipat) -> let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in - Misctypes.IntroApplyOn (c, mk_intro_pattern ipat) -| IntroRewrite b -> Misctypes.IntroRewrite b + Tactypes.IntroApplyOn (c, mk_intro_pattern ipat) +| IntroRewrite b -> Tactypes.IntroRewrite b and mk_or_and_intro_pattern = function | IntroOrPattern ipatss -> - Misctypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) + Tactypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) | IntroAndPattern ipats -> - Misctypes.IntroAndPattern (List.map mk_intro_pattern ipats) + Tactypes.IntroAndPattern (List.map mk_intro_pattern ipats) let mk_intro_patterns ipat = List.map mk_intro_pattern ipat @@ -77,7 +77,7 @@ let mk_occurrences f = function | OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) let mk_occurrences_expr occ = - mk_occurrences (fun i -> Misctypes.ArgArg i) occ + mk_occurrences (fun i -> Locus.ArgArg i) occ let mk_hyp_location (id, occs, h) = ((mk_occurrences_expr occs, id), h) @@ -188,7 +188,7 @@ let forward fst tac ipat c = let assert_ = function | AssertValue (id, c) -> - let ipat = CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id) in + let ipat = CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id) in Tactics.forward true None (Some ipat) c | AssertType (ipat, c, tac) -> let ipat = Option.map mk_intro_pattern ipat in @@ -432,8 +432,8 @@ let inversion knd arg pat ids = | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> Inv.inv_clause knd pat ids (NamedHyp id) | Some (_, Tactics.ElimOnConstr c) -> - let open Misctypes in - let anon = CAst.make @@ IntroNaming IntroAnonymous in + let open Tactypes in + let anon = CAst.make @@ IntroNaming Namegen.IntroAnonymous in Tactics.specialize c (Some anon) >>= fun () -> Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) end diff --git a/src/tac2types.mli b/src/tac2types.mli index a7b0ceed6e..fa31153a27 100644 --- a/src/tac2types.mli +++ b/src/tac2types.mli @@ -17,7 +17,7 @@ type advanced_flag = bool type 'a thunk = (unit, 'a) Tac2ffi.fun1 -type quantified_hypothesis = Misctypes.quantified_hypothesis = +type quantified_hypothesis = Tactypes.quantified_hypothesis = | AnonHyp of int | NamedHyp of Id.t @@ -76,7 +76,7 @@ type induction_clause = or_and_intro_pattern option * clause option -type multi = Misctypes.multi = +type multi = Equality.multi = | Precisely of int | UpTo of int | RepeatStar -- cgit v1.2.3 From 15010cea58df81a3ccfdd5a4b2a01375e34853f3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 18 Jun 2018 16:43:42 +0200 Subject: Do not rely on the Ident vs. Qualid artificial separation. --- src/g_ltac2.ml4 | 8 ++++---- src/tac2core.ml | 7 ++++--- src/tac2entries.mli | 2 +- src/tac2qexpr.mli | 10 ++++++++-- src/tac2quote.mli | 4 ++-- 5 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index b59a5e184e..b13c036549 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -371,8 +371,8 @@ GEXTEND Gram [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] ; globref: - [ [ "&"; id = Prim.ident -> CAst.make ~loc:!@loc (Libnames.Ident id) - | qid = Prim.qualid -> CAst.map (fun qid -> Libnames.Qualid qid) qid + [ [ "&"; id = Prim.ident -> CAst.make ~loc:!@loc (QHypothesis id) + | qid = Prim.qualid -> CAst.map (fun qid -> QReference qid) qid ] ] ; END @@ -666,8 +666,8 @@ GEXTEND Gram ] ] ; refglobal: - [ [ "&"; id = Prim.ident -> QExpr (CAst.make ~loc:!@loc @@ Libnames.Ident id) - | qid = Prim.qualid -> QExpr (CAst.make ~loc:!@loc @@ Libnames.Qualid qid.CAst.v) + [ [ "&"; id = Prim.ident -> QExpr (CAst.make ~loc:!@loc @@ QHypothesis id) + | qid = Prim.qualid -> QExpr (CAst.make ~loc:!@loc @@ QReference qid.CAst.v) | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index 5f33374486..4bd294d4df 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -910,13 +910,14 @@ let () = define_ml_object Tac2quote.wit_pattern obj let () = - let intern self ist qid = match qid with - | {CAst.v=Libnames.Ident id} -> + let intern self ist ref = match ref.CAst.v with + | Tac2qexpr.QHypothesis id -> GlbVal (Globnames.VarRef id), gtypref t_reference - | {CAst.loc;v=Libnames.Qualid qid} -> + | Tac2qexpr.QReference qid -> let gr = try Nametab.locate qid with Not_found -> + let loc = ref.CAst.loc in Nametab.error_global_not_found (CAst.make ?loc qid) in GlbVal gr, gtypref t_reference diff --git a/src/tac2entries.mli b/src/tac2entries.mli index ad7624b7d0..777f3f1a43 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -74,7 +74,7 @@ val q_rewriting : rewriting Pcoq.Gram.entry val q_clause : clause Pcoq.Gram.entry val q_dispatch : dispatch Pcoq.Gram.entry val q_occurrences : occurrences Pcoq.Gram.entry -val q_reference : Libnames.reference or_anti Pcoq.Gram.entry +val q_reference : reference or_anti Pcoq.Gram.entry val q_strategy_flag : strategy_flag Pcoq.Gram.entry val q_constr_matching : constr_matching Pcoq.Gram.entry val q_goal_matching : goal_matching Pcoq.Gram.entry diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli index 3f0c591e63..400ab1a092 100644 --- a/src/tac2qexpr.mli +++ b/src/tac2qexpr.mli @@ -16,6 +16,12 @@ type 'a or_anti = | QExpr of 'a | QAnti of Id.t CAst.t +type reference_r = +| QReference of Libnames.qualid +| QHypothesis of Id.t + +type reference = reference_r CAst.t + type quantified_hypothesis = | QAnonHyp of int CAst.t | QNamedHyp of Id.t CAst.t @@ -116,8 +122,8 @@ type red_flag_r = | QFix | QCofix | QZeta -| QConst of Libnames.reference or_anti list CAst.t -| QDeltaBut of Libnames.reference or_anti list CAst.t +| QConst of reference or_anti list CAst.t +| QDeltaBut of reference or_anti list CAst.t type red_flag = red_flag_r CAst.t diff --git a/src/tac2quote.mli b/src/tac2quote.mli index cc58144901..2ce347f397 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -60,7 +60,7 @@ val of_hintdb : hintdb -> raw_tacexpr val of_move_location : move_location -> raw_tacexpr -val of_reference : Libnames.reference or_anti -> raw_tacexpr +val of_reference : reference or_anti -> raw_tacexpr val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr (** id ↦ 'Control.hyp @id' *) @@ -89,7 +89,7 @@ val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag val wit_ident : (Id.t, Id.t) Arg.tag -val wit_reference : (Libnames.reference, GlobRef.t) Arg.tag +val wit_reference : (reference, GlobRef.t) Arg.tag (** Beware, at the raw level, [Qualid [id]] has not the same meaning as [Ident id]. The first is an unqualified global reference, the second is the dynamic reference to id. *) -- cgit v1.2.3 From eba6d1ffe7a3aa775e6a4984914461364149573f Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 18 Jun 2018 14:21:19 +0200 Subject: Adapt to Coq's PR #7797 (removal of reference). --- src/g_ltac2.ml4 | 32 ++++++++++++++++---------------- src/tac2core.ml | 3 +-- src/tac2entries.ml | 43 ++++++++++++++++++++----------------------- src/tac2entries.mli | 4 ++-- src/tac2env.ml | 4 ++-- src/tac2env.mli | 2 +- src/tac2expr.mli | 6 +++--- src/tac2intern.ml | 32 ++++++++++++++++---------------- src/tac2quote.ml | 4 ++-- src/tac2quote.mli | 3 --- 10 files changed, 63 insertions(+), 70 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index b13c036549..16e7278235 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -98,25 +98,25 @@ let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e -let pattern_of_qualid ?loc id = - if Tac2env.is_constructor id.CAst.v then CAst.make ?loc @@ CPatRef (RelId id, []) +let pattern_of_qualid qid = + if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) else - let (dp, id) = Libnames.repr_qualid id.CAst.v in - if DirPath.is_empty dp then CAst.make ?loc @@ CPatVar (Name id) + let open Libnames in + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) else - CErrors.user_err ?loc (Pp.str "Syntax error") + CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") GEXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn tac2def_mut tac2def_run; tac2pat: [ "1" LEFTA - [ id = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> - if Tac2env.is_constructor (id.CAst.v) then - CAst.make ~loc:!@loc @@ CPatRef (RelId id, pl) + [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> + if Tac2env.is_constructor qid then + CAst.make ~loc:!@loc @@ CPatRef (RelId qid, pl) else CErrors.user_err ~loc:!@loc (Pp.str "Syntax error") - | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id + | qid = Prim.qualid -> pattern_of_qualid qid | "["; "]" -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) | p1 = tac2pat; "::"; p2 = tac2pat -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) @@ -124,7 +124,7 @@ GEXTEND Gram | "0" [ "_" -> CAst.make ~loc:!@loc @@ CPatVar Anonymous | "()" -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) - | id = Prim.qualid -> pattern_of_qualid ~loc:!@loc id + | qid = Prim.qualid -> pattern_of_qualid qid | "("; p = atomic_tac2pat; ")" -> p ] ] ; @@ -205,11 +205,11 @@ GEXTEND Gram tactic_atom: [ [ n = Prim.integer -> CAst.make ~loc:!@loc @@ CTacAtm (AtmInt n) | s = Prim.string -> CAst.make ~loc:!@loc @@ CTacAtm (AtmStr s) - | id = Prim.qualid -> - if Tac2env.is_constructor id.CAst.v then - CAst.make ~loc:!@loc @@ CTacCst (RelId id) + | qid = Prim.qualid -> + if Tac2env.is_constructor qid then + CAst.make ~loc:!@loc @@ CTacCst (RelId qid) else - CAst.make ~loc:!@loc @@ CTacRef (RelId id) + CAst.make ~loc:!@loc @@ CTacRef (RelId qid) | "@"; id = Prim.ident -> Tac2quote.of_ident (CAst.make ~loc:!@loc id) | "&"; id = lident -> Tac2quote.of_hyp ~loc:!@loc id | "'"; c = Constr.constr -> inj_open_constr !@loc c @@ -372,7 +372,7 @@ GEXTEND Gram ; globref: [ [ "&"; id = Prim.ident -> CAst.make ~loc:!@loc (QHypothesis id) - | qid = Prim.qualid -> CAst.map (fun qid -> QReference qid) qid + | qid = Prim.qualid -> CAst.make ~loc:!@loc @@ QReference qid ] ] ; END @@ -667,7 +667,7 @@ GEXTEND Gram ; refglobal: [ [ "&"; id = Prim.ident -> QExpr (CAst.make ~loc:!@loc @@ QHypothesis id) - | qid = Prim.qualid -> QExpr (CAst.make ~loc:!@loc @@ QReference qid.CAst.v) + | qid = Prim.qualid -> QExpr (CAst.make ~loc:!@loc @@ QReference qid) | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] ; diff --git a/src/tac2core.ml b/src/tac2core.ml index 4bd294d4df..97f25ef5ed 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -917,8 +917,7 @@ let () = let gr = try Nametab.locate qid with Not_found -> - let loc = ref.CAst.loc in - Nametab.error_global_not_found (CAst.make ?loc qid) + Nametab.error_global_not_found qid in GlbVal gr, gtypref t_reference in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index c85ffb2539..8ebfeec948 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -303,7 +303,7 @@ let inline_rec_tactic tactics = let bnd = List.map map_body tactics in let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in let var_of_id {loc;v=id} = - let qid = CAst.make ?loc @@ qualid_of_ident id in + let qid = qualid_of_ident ?loc id in CAst.make ?loc @@ CTacRef (RelId qid) in let loc0 = e.loc in @@ -360,10 +360,9 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = in List.iter iter defs -let qualid_to_ident {loc;v=qid} = - let (dp, id) = Libnames.repr_qualid qid in - if DirPath.is_empty dp then CAst.make ?loc id - else user_err ?loc (str "Identifier expected") +let qualid_to_ident qid = + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid + else user_err ?loc:qid.CAst.loc (str "Identifier expected") let register_typedef ?(local = false) isrec types = let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in @@ -453,21 +452,21 @@ let register_primitive ?(local = false) {loc;v=id} t ml = } in ignore (Lib.add_leaf id (inTacDef def)) -let register_open ?(local = false) {loc;v=qid} (params, def) = +let register_open ?(local = false) qid (params, def) = let kn = try Tac2env.locate_type qid with Not_found -> - user_err ?loc (str "Unbound type " ++ pr_qualid qid) + user_err ?loc:qid.CAst.loc (str "Unbound type " ++ pr_qualid qid) in let (tparams, t) = Tac2env.interp_type kn in let () = match t with | GTydOpn -> () | GTydAlg _ | GTydRec _ | GTydDef _ -> - user_err ?loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") in let () = if not (Int.equal (List.length params) tparams) then - Tac2intern.error_nparams_mismatch ?loc (List.length params) tparams + Tac2intern.error_nparams_mismatch ?loc:qid.CAst.loc (List.length params) tparams in match def with | CTydOpn -> () @@ -492,12 +491,11 @@ let register_open ?(local = false) {loc;v=qid} (params, def) = } in Lib.add_anonymous_leaf (inTypExt def) | CTydRec _ | CTydDef _ -> - user_err ?loc (str "Extensions only accept inductive constructors") + user_err ?loc:qid.CAst.loc (str "Extensions only accept inductive constructors") let register_type ?local isrec types = match types with | [qid, true, def] -> - let {loc} = qid in - let () = if isrec then user_err ?loc (str "Extensions cannot be recursive") in + let () = if isrec then user_err ?loc:qid.CAst.loc (str "Extensions cannot be recursive") in register_open ?local qid def | _ -> let map (qid, redef, def) = @@ -709,30 +707,30 @@ let inTac2Redefinition : redefinition -> obj = subst_function = subst_redefinition; classify_function = classify_redefinition } -let register_redefinition ?(local = false) (loc, qid) e = +let register_redefinition ?(local = false) qid e = let kn = try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) in let kn = match kn with | TacConstant kn -> kn | TacAlias _ -> - user_err ?loc (str "Cannot redefine syntactic abbreviations") + user_err ?loc:qid.CAst.loc (str "Cannot redefine syntactic abbreviations") in let data = Tac2env.interp_global kn in let () = if not (data.Tac2env.gdata_mutable) then - user_err ?loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") + user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") in let (e, t) = intern ~strict:true e in let () = if not (is_value e) then - user_err ?loc (str "Tactic definition must be a syntactical value") + user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") in let () = if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then let name = int_name () in - user_err ?loc (str "Type " ++ pr_glbtype name (snd t) ++ + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) in let def = { @@ -779,7 +777,7 @@ let register_struct ?local str = match str with | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e -| StrMut (qid, e) -> register_redefinition ?local CAst.(qid.loc, qid.v) e +| StrMut (qid, e) -> register_redefinition ?local qid e | StrRun e -> perform_eval e (** Toplevel exception *) @@ -831,19 +829,18 @@ end (** Printing *) -let print_ltac ref = - let {loc;v=qid} = qualid_of_reference ref in +let print_ltac qid = if Tac2env.is_constructor qid then let kn = try Tac2env.locate_constructor qid - with Not_found -> user_err ?loc (str "Unknown constructor " ++ pr_qualid qid) + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown constructor " ++ pr_qualid qid) in let _ = Tac2env.interp_constructor kn in Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) else let kn = try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc (str "Unknown tactic " ++ pr_qualid qid) + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) in match kn with | TacConstant kn -> diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 777f3f1a43..37944981d7 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -16,7 +16,7 @@ val register_ltac : ?local:bool -> ?mut:bool -> rec_flag -> (Names.lname * raw_tacexpr) list -> unit val register_type : ?local:bool -> rec_flag -> - (qualid CAst.t * redef_flag * raw_quant_typedef) list -> unit + (qualid * redef_flag * raw_quant_typedef) list -> unit val register_primitive : ?local:bool -> Names.lident -> raw_typexpr -> ml_tactic_name -> unit @@ -41,7 +41,7 @@ val parse_scope : sexpr -> scope_rule (** {5 Inspecting} *) -val print_ltac : Libnames.reference -> unit +val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) diff --git a/src/tac2env.ml b/src/tac2env.ml index d0f286b396..dcf7440498 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -208,10 +208,10 @@ let locate_extended_all_type qid = let tab = !nametab in KnTab.find_prefixes qid tab.tab_type -let shortest_qualid_of_type kn = +let shortest_qualid_of_type ?loc kn = let tab = !nametab in let sp = KNmap.find kn tab.tab_type_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_type + KnTab.shortest_qualid ?loc Id.Set.empty sp tab.tab_type let push_projection vis sp kn = let tab = !nametab in diff --git a/src/tac2env.mli b/src/tac2env.mli index 022c518143..7616579d63 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -88,7 +88,7 @@ val shortest_qualid_of_constructor : ltac_constructor -> qualid val push_type : visibility -> full_path -> type_constant -> unit val locate_type : qualid -> type_constant val locate_extended_all_type : qualid -> type_constant list -val shortest_qualid_of_type : type_constant -> qualid +val shortest_qualid_of_type : ?loc:Loc.t -> type_constant -> qualid val push_projection : visibility -> full_path -> ltac_projection -> unit val locate_projection : qualid -> ltac_projection diff --git a/src/tac2expr.mli b/src/tac2expr.mli index 1f2c3ebf3b..1069d0bfa3 100644 --- a/src/tac2expr.mli +++ b/src/tac2expr.mli @@ -26,7 +26,7 @@ type tacref = | TacAlias of ltac_alias type 'a or_relid = -| RelId of qualid CAst.t +| RelId of qualid | AbsKn of 'a (** {5 Misc} *) @@ -160,13 +160,13 @@ type sexpr = type strexpr = | StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list (** Term definition *) -| StrTyp of rec_flag * (qualid CAst.t * redef_flag * raw_quant_typedef) list +| StrTyp of rec_flag * (qualid * redef_flag * raw_quant_typedef) list (** Type definition *) | StrPrm of Names.lident * raw_typexpr * ml_tactic_name (** External definition *) | StrSyn of sexpr list * int option * raw_tacexpr (** Syntactic extensions *) -| StrMut of qualid CAst.t * raw_tacexpr +| StrMut of qualid * raw_tacexpr (** Redefinition of mutable globals *) | StrRun of raw_tacexpr (** Toplevel evaluation of an expression *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml index 86d81ef5d2..f3b222df21 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -208,9 +208,9 @@ let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t | CTypVar Anonymous -> GTypVar (fresh_id env) | CTypRef (rel, args) -> let (kn, nparams) = match rel with - | RelId {loc;v=qid} -> - let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp && Id.Map.mem id env.env_rec then + | RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && Id.Map.mem id env.env_rec then let (kn, n) = Id.Map.find id env.env_rec in (Other kn, n) else @@ -230,9 +230,9 @@ let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t let nargs = List.length args in let () = if not (Int.equal nparams nargs) then - let {loc;v=qid} = match rel with + let qid = match rel with | RelId lid -> lid - | AbsKn (Other kn) -> CAst.make ?loc @@ shortest_qualid_of_type kn + | AbsKn (Other kn) -> shortest_qualid_of_type ?loc kn | AbsKn (Tuple _) -> assert false in user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ @@ -500,14 +500,14 @@ let check_redundant_clause = function | (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () let get_variable0 mem var = match var with -| RelId {loc;v=qid} -> - let (dp, id) = repr_qualid qid in - if DirPath.is_empty dp && mem id then ArgVar CAst.(make ?loc id) +| RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && mem id then ArgVar CAst.(make ?loc:qid.CAst.loc id) else let kn = try Tac2env.locate_ltac qid with Not_found -> - CErrors.user_err ?loc (str "Unbound value " ++ pr_qualid qid) + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound value " ++ pr_qualid qid) in ArgArg kn | AbsKn kn -> ArgArg kn @@ -517,19 +517,19 @@ let get_variable env var = get_variable0 mem var let get_constructor env var = match var with -| RelId {loc;v=qid} -> +| RelId qid -> let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in begin match c with | Some knc -> Other knc | None -> - CErrors.user_err ?loc (str "Unbound constructor " ++ pr_qualid qid) + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound constructor " ++ pr_qualid qid) end | AbsKn knc -> knc let get_projection var = match var with -| RelId {loc;v=qid} -> +| RelId qid -> let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ?loc (pr_qualid qid ++ str " is not a projection") + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") in Tac2env.interp_projection kn | AbsKn kn -> @@ -622,7 +622,7 @@ let expand_pattern avoid bnd = na, None | _ -> let id = fresh_var avoid in - let qid = RelId (CAst.make ?loc:pat.loc (qualid_of_ident id)) in + let qid = RelId (qualid_of_ident ?loc:pat.loc id) in Name id, Some qid in let avoid = ids_of_pattern avoid pat in @@ -1206,9 +1206,9 @@ let check_subtype t1 t2 = (** Globalization *) let get_projection0 var = match var with -| RelId {CAst.loc;v=qid} -> +| RelId qid -> let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ?loc (pr_qualid qid ++ str " is not a projection") + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") in kn | AbsKn kn -> kn diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 2a0230b779..1d742afd83 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -82,10 +82,10 @@ let inj_wit ?loc wit x = CAst.make ?loc @@ CTacExt (wit, x) let of_variable {loc;v=id} = - let qid = Libnames.qualid_of_ident id in + let qid = Libnames.qualid_of_ident ?loc id in if Tac2env.is_constructor qid then CErrors.user_err ?loc (str "Invalid identifier") - else CAst.make ?loc @@ CTacRef (RelId (CAst.make ?loc qid)) + else CAst.make ?loc @@ CTacRef (RelId qid) let of_anti f = function | QExpr x -> f x diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 2ce347f397..09aa92f9ee 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -90,9 +90,6 @@ val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag val wit_ident : (Id.t, Id.t) Arg.tag val wit_reference : (reference, GlobRef.t) Arg.tag -(** Beware, at the raw level, [Qualid [id]] has not the same meaning as - [Ident id]. The first is an unqualified global reference, the second is - the dynamic reference to id. *) val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag -- cgit v1.2.3 From fd2b270a8be038f50b57d9e76a532dcf2222fd0b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 23 Jun 2018 14:24:19 +0200 Subject: Fix for compilation with the camlp5-parser branch. --- src/tac2core.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 97f25ef5ed..13265ee080 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1127,12 +1127,12 @@ end let () = add_scope "tactic" begin function | [] -> (** Default to level 5 parsing *) - let scope = Extend.Aentryl (tac2expr, 5) in + let scope = Extend.Aentryl (tac2expr, "5") in let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt {loc;v=n}] as arg -> let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Extend.Aentryl (tac2expr, n) in + let scope = Extend.Aentryl (tac2expr, string_of_int n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "tactic" arg -- cgit v1.2.3 From b9ad51bb8aa4fbd1bd54314797428a1a0ae19fde Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 25 May 2018 16:11:56 +0200 Subject: Adapting to move of register_constr_interp0 from Pretyping to GlobEnv. --- src/tac2core.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 13265ee080..d745d52c82 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -974,7 +974,7 @@ let () = let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in (EConstr.of_constr c, sigma) in - Pretyping.register_constr_interp0 wit_ltac2 interp + GlobEnv.register_constr_interp0 wit_ltac2 interp let () = let interp ist env sigma concl id = @@ -984,7 +984,7 @@ let () = let sigma = Typing.check env sigma c concl in (c, sigma) in - Pretyping.register_constr_interp0 wit_ltac2_quotation interp + GlobEnv.register_constr_interp0 wit_ltac2_quotation interp let () = let pr_raw id = Genprint.PrinterBasic mt in -- cgit v1.2.3 From f37c6f514a63aa1ebfb23b3c8def0087c242ca15 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 23 Jul 2018 14:40:49 +0200 Subject: Fix deprecated warnings from Pcoq. --- src/g_ltac2.ml4 | 16 ++++++++-------- src/tac2entries.ml | 44 ++++++++++++++++++++++---------------------- src/tac2entries.mli | 42 +++++++++++++++++++++--------------------- 3 files changed, 51 insertions(+), 51 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 16e7278235..82ab53298e 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -81,14 +81,14 @@ let test_dollar_ident = end let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Gram.entry_create "tactic:tac2type" -let tac2def_val = Gram.entry_create "tactic:tac2def_val" -let tac2def_typ = Gram.entry_create "tactic:tac2def_typ" -let tac2def_ext = Gram.entry_create "tactic:tac2def_ext" -let tac2def_syn = Gram.entry_create "tactic:tac2def_syn" -let tac2def_mut = Gram.entry_create "tactic:tac2def_mut" -let tac2def_run = Gram.entry_create "tactic:tac2def_run" -let tac2mode = Gram.entry_create "vernac:ltac2_command" +let tac2type = Entry.create "tactic:tac2type" +let tac2def_val = Entry.create "tactic:tac2def_val" +let tac2def_typ = Entry.create "tactic:tac2def_typ" +let tac2def_ext = Entry.create "tactic:tac2def_ext" +let tac2def_syn = Entry.create "tactic:tac2def_syn" +let tac2def_mut = Entry.create "tactic:tac2def_mut" +let tac2def_run = Entry.create "tactic:tac2def_run" +let tac2mode = Entry.create "vernac:ltac2_command" let ltac1_expr = Pltac.tactic_expr diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 8ebfeec948..c26fbdc478 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -22,28 +22,28 @@ open Tac2intern module Pltac = struct -let tac2expr = Pcoq.Gram.entry_create "tactic:tac2expr" - -let q_ident = Pcoq.Gram.entry_create "tactic:q_ident" -let q_bindings = Pcoq.Gram.entry_create "tactic:q_bindings" -let q_with_bindings = Pcoq.Gram.entry_create "tactic:q_with_bindings" -let q_intropattern = Pcoq.Gram.entry_create "tactic:q_intropattern" -let q_intropatterns = Pcoq.Gram.entry_create "tactic:q_intropatterns" -let q_destruction_arg = Pcoq.Gram.entry_create "tactic:q_destruction_arg" -let q_induction_clause = Pcoq.Gram.entry_create "tactic:q_induction_clause" -let q_conversion = Pcoq.Gram.entry_create "tactic:q_conversion" -let q_rewriting = Pcoq.Gram.entry_create "tactic:q_rewriting" -let q_clause = Pcoq.Gram.entry_create "tactic:q_clause" -let q_dispatch = Pcoq.Gram.entry_create "tactic:q_dispatch" -let q_occurrences = Pcoq.Gram.entry_create "tactic:q_occurrences" -let q_reference = Pcoq.Gram.entry_create "tactic:q_reference" -let q_strategy_flag = Pcoq.Gram.entry_create "tactic:q_strategy_flag" -let q_constr_matching = Pcoq.Gram.entry_create "tactic:q_constr_matching" -let q_goal_matching = Pcoq.Gram.entry_create "tactic:q_goal_matching" -let q_hintdb = Pcoq.Gram.entry_create "tactic:q_hintdb" -let q_move_location = Pcoq.Gram.entry_create "tactic:q_move_location" -let q_pose = Pcoq.Gram.entry_create "tactic:q_pose" -let q_assert = Pcoq.Gram.entry_create "tactic:q_assert" +let tac2expr = Pcoq.Entry.create "tactic:tac2expr" + +let q_ident = Pcoq.Entry.create "tactic:q_ident" +let q_bindings = Pcoq.Entry.create "tactic:q_bindings" +let q_with_bindings = Pcoq.Entry.create "tactic:q_with_bindings" +let q_intropattern = Pcoq.Entry.create "tactic:q_intropattern" +let q_intropatterns = Pcoq.Entry.create "tactic:q_intropatterns" +let q_destruction_arg = Pcoq.Entry.create "tactic:q_destruction_arg" +let q_induction_clause = Pcoq.Entry.create "tactic:q_induction_clause" +let q_conversion = Pcoq.Entry.create "tactic:q_conversion" +let q_rewriting = Pcoq.Entry.create "tactic:q_rewriting" +let q_clause = Pcoq.Entry.create "tactic:q_clause" +let q_dispatch = Pcoq.Entry.create "tactic:q_dispatch" +let q_occurrences = Pcoq.Entry.create "tactic:q_occurrences" +let q_reference = Pcoq.Entry.create "tactic:q_reference" +let q_strategy_flag = Pcoq.Entry.create "tactic:q_strategy_flag" +let q_constr_matching = Pcoq.Entry.create "tactic:q_constr_matching" +let q_goal_matching = Pcoq.Entry.create "tactic:q_goal_matching" +let q_hintdb = Pcoq.Entry.create "tactic:q_hintdb" +let q_move_location = Pcoq.Entry.create "tactic:q_move_location" +let q_pose = Pcoq.Entry.create "tactic:q_pose" +let q_assert = Pcoq.Entry.create "tactic:q_assert" end (** Tactic definition *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 37944981d7..f97e35fec0 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -56,32 +56,32 @@ val backtrace : backtrace Exninfo.t module Pltac : sig -val tac2expr : raw_tacexpr Pcoq.Gram.entry +val tac2expr : raw_tacexpr Pcoq.Entry.t (** Quoted entries. To be used for complex notations. *) open Tac2qexpr -val q_ident : Id.t CAst.t or_anti Pcoq.Gram.entry -val q_bindings : bindings Pcoq.Gram.entry -val q_with_bindings : bindings Pcoq.Gram.entry -val q_intropattern : intro_pattern Pcoq.Gram.entry -val q_intropatterns : intro_pattern list CAst.t Pcoq.Gram.entry -val q_destruction_arg : destruction_arg Pcoq.Gram.entry -val q_induction_clause : induction_clause Pcoq.Gram.entry -val q_conversion : conversion Pcoq.Gram.entry -val q_rewriting : rewriting Pcoq.Gram.entry -val q_clause : clause Pcoq.Gram.entry -val q_dispatch : dispatch Pcoq.Gram.entry -val q_occurrences : occurrences Pcoq.Gram.entry -val q_reference : reference or_anti Pcoq.Gram.entry -val q_strategy_flag : strategy_flag Pcoq.Gram.entry -val q_constr_matching : constr_matching Pcoq.Gram.entry -val q_goal_matching : goal_matching Pcoq.Gram.entry -val q_hintdb : hintdb Pcoq.Gram.entry -val q_move_location : move_location Pcoq.Gram.entry -val q_pose : pose Pcoq.Gram.entry -val q_assert : assertion Pcoq.Gram.entry +val q_ident : Id.t CAst.t or_anti Pcoq.Entry.t +val q_bindings : bindings Pcoq.Entry.t +val q_with_bindings : bindings Pcoq.Entry.t +val q_intropattern : intro_pattern Pcoq.Entry.t +val q_intropatterns : intro_pattern list CAst.t Pcoq.Entry.t +val q_destruction_arg : destruction_arg Pcoq.Entry.t +val q_induction_clause : induction_clause Pcoq.Entry.t +val q_conversion : conversion Pcoq.Entry.t +val q_rewriting : rewriting Pcoq.Entry.t +val q_clause : clause Pcoq.Entry.t +val q_dispatch : dispatch Pcoq.Entry.t +val q_occurrences : occurrences Pcoq.Entry.t +val q_reference : reference or_anti Pcoq.Entry.t +val q_strategy_flag : strategy_flag Pcoq.Entry.t +val q_constr_matching : constr_matching Pcoq.Entry.t +val q_goal_matching : goal_matching Pcoq.Entry.t +val q_hintdb : hintdb Pcoq.Entry.t +val q_move_location : move_location Pcoq.Entry.t +val q_pose : pose Pcoq.Entry.t +val q_assert : assertion Pcoq.Entry.t end (** {5 Hooks} *) -- cgit v1.2.3 From c555a1b74ff745c7ee964c2d53463db190dc6705 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 23 Jul 2018 14:45:35 +0200 Subject: Adding environment-manipulating functions. --- _CoqProject | 1 + src/tac2core.ml | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ theories/Constr.v | 7 +++++++ theories/Env.v | 22 ++++++++++++++++++++++ theories/Ltac2.v | 1 + 5 files changed, 87 insertions(+) create mode 100644 theories/Env.v diff --git a/_CoqProject b/_CoqProject index 5af42197ea..15e02a6484 100644 --- a/_CoqProject +++ b/_CoqProject @@ -44,5 +44,6 @@ theories/Constr.v theories/Pattern.v theories/Fresh.v theories/Std.v +theories/Env.v theories/Notations.v theories/Ltac2.v diff --git a/src/tac2core.ml b/src/tac2core.ml index 13265ee080..8a7d2034fc 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -494,6 +494,26 @@ let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> return (Value.of_constr ans) end +let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + try + let ans = Inductiveops.make_case_info env ind Constr.RegularStyle in + return (Value.of_ext Value.val_case ans) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define2 "constr_constructor" (repr_ext val_inductive) int begin fun (ind, i) k -> + Proofview.tclENV >>= fun env -> + try + let open Declarations in + let ans = Environ.lookup_mind ind env in + let _ = ans.mind_packets.(i).mind_consnames.(k) in + return (Value.of_ext val_constructor ((ind, i), (k + 1))) + with e when CErrors.noncritical e -> + throw err_notfound +end + let () = define3 "constr_in_context" ident constr closure begin fun id t c -> Proofview.Goal.goals >>= function | [gl] -> @@ -801,6 +821,42 @@ let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> return (Value.of_ident nid) end +(** Env *) + +let () = define1 "env_get" (list ident) begin fun ids -> + let r = match ids with + | [] -> None + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + try Some (Nametab.global_of_path fp) with Not_found -> None + in + return (Value.of_option Value.of_reference r) +end + +let () = define1 "env_expand" (list ident) begin fun ids -> + let r = match ids with + | [] -> [] + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let qid = Libnames.make_qualid path id in + Nametab.locate_all qid + in + return (Value.of_list Value.of_reference r) +end + +let () = define1 "env_path" reference begin fun r -> + match Nametab.path_of_global r with + | fp -> + let (path, id) = Libnames.repr_path fp in + let path = DirPath.repr path in + return (Value.of_list Value.of_ident (List.rev_append path [id])) + | exception Not_found -> + throw err_notfound +end + (** ML types *) let constr_flags () = diff --git a/theories/Constr.v b/theories/Constr.v index 072c613920..d8d222730e 100644 --- a/theories/Constr.v +++ b/theories/Constr.v @@ -57,6 +57,13 @@ Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "con (** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) +Ltac2 @ external case : inductive -> case := "ltac2" "constr_case". +(** Generate the case information for a given inductive type. *) + +Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "constr_constructor". +(** Generate the i-th constructor for a given inductive type. Indexing starts + at 0. Panics if there is no such constructor. *) + End Unsafe. Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". diff --git a/theories/Env.v b/theories/Env.v new file mode 100644 index 0000000000..7e36aa7990 --- /dev/null +++ b/theories/Env.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Std.reference option := "ltac2" "env_get". +(** Returns the global reference corresponding to the absolute name given as + argument if it exists. *) + +Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". +(** Returns the list of all global references whose absolute name contains + the argument list as a prefix. *) + +Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". +(** Returns the absolute name of the given reference. Panics if the reference + does not exist. *) diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 7b2f592ac6..3fe71f4c65 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -18,4 +18,5 @@ Require Ltac2.Control. Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. +Require Ltac2.Env. Require Export Ltac2.Notations. -- cgit v1.2.3 From 6ff982c5d96cfa847f699bc25dc75553e7f718f0 Mon Sep 17 00:00:00 2001 From: Langston Barrett Date: Tue, 7 Aug 2018 11:22:32 -0700 Subject: doc/ltac2.md: add table of contents --- doc/ltac2.md | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/doc/ltac2.md b/doc/ltac2.md index 9ba227c285..e8280a033a 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -24,6 +24,61 @@ that features at least the following: This document describes the implementation of such a language. The implementation of Ltac as of Coq 8.7 will be referred to as Ltac1. +# Contents + + +**Table of Contents** + +- [Summary](#summary) +- [Contents](#contents) +- [General design](#general-design) +- [ML component](#ml-component) + - [Overview](#overview) + - [Type Syntax](#type-syntax) + - [Type declarations](#type-declarations) + - [Term Syntax](#term-syntax) + - [Ltac Definitions](#ltac-definitions) + - [Reduction](#reduction) + - [Typing](#typing) + - [Effects](#effects) + - [Standard IO](#standard-io) + - [Fatal errors](#fatal-errors) + - [Backtrack](#backtrack) + - [Goals](#goals) +- [Meta-programming](#meta-programming) + - [Overview](#overview-1) + - [Generic Syntax for Quotations](#generic-syntax-for-quotations) + - [Built-in quotations](#built-in-quotations) + - [Strict vs. non-strict mode](#strict-vs-non-strict-mode) + - [Term Antiquotations](#term-antiquotations) + - [Syntax](#syntax) + - [Semantics](#semantics) + - [Static semantics](#static-semantics) + - [Dynamic semantics](#dynamic-semantics) + - [Trivial Term Antiquotations](#trivial-term-antiquotations) + - [Match over terms](#match-over-terms) + - [Match over goals](#match-over-goals) +- [Notations](#notations) + - [Scopes](#scopes) + - [Notations](#notations-1) + - [Abbreviations](#abbreviations) +- [Evaluation](#evaluation) +- [Debug](#debug) +- [Compatibility layer with Ltac1](#compatibility-layer-with-ltac1) + - [Ltac1 from Ltac2](#ltac1-from-ltac2) + - [Ltac2 from Ltac1](#ltac2-from-ltac1) +- [Transition from Ltac1](#transition-from-ltac1) + - [Syntax changes](#syntax-changes) + - [Tactic delay](#tactic-delay) + - [Variable binding](#variable-binding) + - [In Ltac expressions](#in-ltac-expressions) + - [In quotations](#in-quotations) + - [Exception catching](#exception-catching) +- [TODO](#todo) + + + + # General design There are various alternatives to Ltac1, such that Mtac or Rtac for instance. -- cgit v1.2.3 From 057345df3a6f5e46b76b9d8a395d75ba8b0965e9 Mon Sep 17 00:00:00 2001 From: Langston Barrett Date: Tue, 7 Aug 2018 11:35:50 -0700 Subject: fix three small typos --- doc/ltac2.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ltac2.md b/doc/ltac2.md index 9ba227c285..38cdef025e 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -17,7 +17,7 @@ Following the need of users that start developing huge projects relying critically on Ltac, we believe that we should offer a proper modern language that features at least the following: -- at least informal, predictible semantics +- at least informal, predictable semantics - a typing system - standard programming facilities (i.e. datatypes) @@ -388,7 +388,7 @@ represent several goals, including none. Thus, there is no such thing as It is natural to do the same in Ltac2, but we must provide a way to get access to a given goal. This is the role of the `enter` primitive, that applies a -tactic to each currently focussed goal in turn. +tactic to each currently focused goal in turn. ``` val enter : (unit -> unit) -> unit @@ -634,7 +634,7 @@ bindings, so that there will be a syntax error if one of the bound variables starts with an uppercase character. The semantics of this construction is otherwise the same as the corresponding -one from Ltac1, except that it requires the goal to be focussed. +one from Ltac1, except that it requires the goal to be focused. ## Match over goals -- cgit v1.2.3 From bebd946584b33a5e263393bd88e8571cd5fa5af2 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 26 Sep 2018 11:41:05 +0200 Subject: Fix for Coq PR#8554 (term builder for tactic "change" takes an environment). --- src/tac2tactics.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 3c464469f0..25431af2ea 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -159,8 +159,7 @@ let specialize c pat = let change pat c cl = let open Tac2ffi in Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let c subst sigma = + let c subst env sigma = let subst = Array.map_of_list snd (Id.Map.bindings subst) in delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma in -- cgit v1.2.3 From 118a93ccf954d02afbfa5ef2b3735ef37439b274 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 26 Sep 2018 16:20:07 +0200 Subject: Adapt to removal of section paths from kernel names --- src/tac2entries.ml | 4 ++-- src/tac2print.ml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index c26fbdc478..2936f143ce 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -100,8 +100,8 @@ type typdef = { } let change_kn_label kn id = - let (mp, dp, _) = KerName.repr kn in - KerName.make mp dp (Label.of_id id) + let mp = KerName.modpath kn in + KerName.make mp (Label.of_id id) let change_sp_label sp id = let (dp, _) = Libnames.repr_path sp in diff --git a/src/tac2print.ml b/src/tac2print.ml index 9c530dfc51..0fea07ee3a 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -16,8 +16,8 @@ open Tac2ffi (** Utils *) let change_kn_label kn id = - let (mp, dp, _) = KerName.repr kn in - KerName.make mp dp (Label.of_id id) + let mp = KerName.modpath kn in + KerName.make mp (Label.of_id id) let paren p = hov 2 (str "(" ++ p ++ str ")") -- cgit v1.2.3 From 0579efd93eebb18f94c90718b092ae4b68a2262d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 2 Oct 2018 08:18:34 +0200 Subject: Fix deprecation warnings. --- src/tac2entries.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index c26fbdc478..95a5f954c6 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -750,14 +750,14 @@ let perform_eval e = Proof_global.give_me_the_proof () with Proof_global.NoCurrentProof -> let sigma = Evd.from_env env in - Vernacexpr.SelectAll, Proof.start sigma [] + Goal_select.SelectAll, Proof.start sigma [] in let v = match selector with - | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i v - | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l v - | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id v - | Vernacexpr.SelectAll -> v - | Vernacexpr.SelectAlreadyFocused -> assert false (** TODO **) + | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v + | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v + | Goal_select.SelectId id -> Proofview.tclFOCUSID id v + | Goal_select.SelectAll -> v + | Goal_select.SelectAlreadyFocused -> assert false (** TODO **) in (** HACK: the API doesn't allow to return a value *) let ans = ref None in -- cgit v1.2.3 From e51555082231328a974ed1f7ab6a1a658df3313b Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Thu, 11 Oct 2018 14:45:34 +0200 Subject: Fix for coq/coq#8515 (command driven attributes) --- src/g_ltac2.ml4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 index 82ab53298e..cb42b393db 100644 --- a/src/g_ltac2.ml4 +++ b/src/g_ltac2.ml4 @@ -831,8 +831,8 @@ let classify_ltac2 = function VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTactic2Definition | [ "Ltac2" ltac2_entry(e) ] => [ classify_ltac2 e ] -> [ - fun ~atts ~st -> let open Vernacinterp in - Tac2entries.register_struct ?local:atts.locality e; + fun ~atts ~st -> + Tac2entries.register_struct ?local:(Attributes.only_locality atts) e; st ] END -- cgit v1.2.3 From 8b9b1be48a9c83f70cbfb70f52eabc616065fa1e Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 17 Oct 2018 02:02:20 +0200 Subject: [build] Add dune file + fix warnings. This allows to drop the ltac2 folder inside the Coq dir and have it compose with the Coq build. I've fixed build warnings by the way. --- src/dune | 10 ++++++++++ src/tac2core.ml | 4 ++-- src/tac2entries.ml | 4 ++-- src/tac2ffi.ml | 2 +- src/tac2intern.ml | 2 +- src/tac2match.ml | 2 +- src/tac2print.ml | 8 ++++---- src/tac2quote.ml | 2 +- 8 files changed, 22 insertions(+), 12 deletions(-) create mode 100644 src/dune diff --git a/src/dune b/src/dune new file mode 100644 index 0000000000..b0140aa809 --- /dev/null +++ b/src/dune @@ -0,0 +1,10 @@ +(library + (name ltac2) + (public_name coq.plugins.ltac2) + (modules_without_implementation tac2expr tac2qexpr tac2types) + (libraries coq.plugins.firstorder)) + +(rule + (targets g_ltac2.ml) + (deps (:pp-file g_ltac2.ml4) ) + (action (run coqp5 -loc loc -impl %{pp-file} -o %{targets}))) diff --git a/src/tac2core.ml b/src/tac2core.ml index 6ff353ce30..8ee239f803 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -20,8 +20,8 @@ open Proofview.Notations module Value = Tac2ffi open Value -let std_core n = KerName.make2 Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) -let coq_core n = KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) +let std_core n = KerName.make Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) +let coq_core n = KerName.make Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) module Core = struct diff --git a/src/tac2entries.ml b/src/tac2entries.ml index ec10dea777..bba4680a72 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -805,7 +805,7 @@ let pr_frame = function let () = register_handler begin function | Tac2interp.LtacError (kn, args) -> - let t_exn = KerName.make2 Tac2env.coq_prefix (Label.make "exn") in + let t_exn = KerName.make Tac2env.coq_prefix (Label.make "exn") in let v = Tac2ffi.of_open (kn, args) in let t = GTypRef (Other t_exn, []) in let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in @@ -897,7 +897,7 @@ let register_prim_alg name params def = let def = { typdef_local = false; typdef_expr = def } in ignore (Lib.add_leaf id (inTypDef def)) -let coq_def n = KerName.make2 Tac2env.coq_prefix (Label.make n) +let coq_def n = KerName.make Tac2env.coq_prefix (Label.make n) let def_unit = { typdef_local = false; diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index a719970a57..df1857c3e7 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -229,7 +229,7 @@ let internal_err = let coq_prefix = MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) in - KerName.make2 coq_prefix (Label.of_id (Id.of_string "Internal")) + KerName.make coq_prefix (Label.of_id (Id.of_string "Internal")) (** FIXME: handle backtrace in Ltac2 exceptions *) let of_exn c = match fst c with diff --git a/src/tac2intern.ml b/src/tac2intern.ml index ff8fb4c0f4..fe615853ce 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -19,7 +19,7 @@ open Tac2expr (** Hardwired types and constants *) -let coq_type n = KerName.make2 Tac2env.coq_prefix (Label.make n) +let coq_type n = KerName.make Tac2env.coq_prefix (Label.make n) let t_int = coq_type "int" let t_string = coq_type "string" diff --git a/src/tac2match.ml b/src/tac2match.ml index a3140eabea..c9e549d47e 100644 --- a/src/tac2match.ml +++ b/src/tac2match.ml @@ -181,7 +181,7 @@ module PatternMatching (E:StaticEnvironment) = struct pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> return (id, ctx) - let hyp_match_body_and_type bodypat typepat hyps = + let _hyp_match_body_and_type bodypat typepat hyps = pick hyps >>= function | LocalDef (id,body,hyp) -> pattern_match_term bodypat body >>= fun ctx_body -> diff --git a/src/tac2print.ml b/src/tac2print.ml index 0fea07ee3a..0b20cf9f58 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -22,7 +22,7 @@ let change_kn_label kn id = let paren p = hov 2 (str "(" ++ p ++ str ")") let t_list = - KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string "list")) + KerName.make Tac2env.coq_prefix (Label.of_id (Id.of_string "list")) (** Type printing *) @@ -35,7 +35,7 @@ type typ_level = | T0 let t_unit = - KerName.make2 Tac2env.coq_prefix (Label.of_id (Id.of_string "unit")) + KerName.make Tac2env.coq_prefix (Label.of_id (Id.of_string "unit")) let pr_typref kn = Libnames.pr_qualid (Tac2env.shortest_qualid_of_type kn) @@ -435,7 +435,7 @@ and pr_val_list env sigma args tpe = str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" let register_init n f = - let kn = KerName.make2 Tac2env.coq_prefix (Label.make n) in + let kn = KerName.make Tac2env.coq_prefix (Label.make n) in register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } let () = register_init "int" begin fun _ _ n -> @@ -476,7 +476,7 @@ let () = register_init "err" begin fun _ _ e -> end let () = - let kn = KerName.make2 Tac2env.coq_prefix (Label.make "array") in + let kn = KerName.make Tac2env.coq_prefix (Label.make "array") in let val_printer env sigma v arg = match arg with | [arg] -> let (_, v) = to_block v in diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 1d742afd83..3bddfe7594 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -32,7 +32,7 @@ let control_prefix = prefix_gen "Control" let pattern_prefix = prefix_gen "Pattern" let array_prefix = prefix_gen "Array" -let kername prefix n = KerName.make2 prefix (Label.of_id (Id.of_string_soft n)) +let kername prefix n = KerName.make prefix (Label.of_id (Id.of_string_soft n)) let std_core n = kername Tac2env.std_prefix n let coq_core n = kername Tac2env.coq_prefix n let control_core n = kername control_prefix n -- cgit v1.2.3 From 0a007ed37f34c9ae30ed860e2c3f237a616c89e6 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 30 Oct 2018 13:06:42 +0100 Subject: Adapt to coq/coq#8844 (move abstract out of tactics.ml) --- src/tac2core.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 8ee239f803..7384652216 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -781,7 +781,7 @@ let () = define1 "progress" closure begin fun f -> end let () = define2 "abstract" (option ident) closure begin fun id f -> - Tactics.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> + Abstract.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> return v_unit end -- cgit v1.2.3 From b06ed5af083e66ab33fbb8f77c8cce5e6b6ed2d3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 31 Oct 2018 16:29:40 +0100 Subject: Port to coqpp. --- _CoqProject | 2 +- src/dune | 4 +- src/g_ltac2.ml4 | 868 ---------------------------------------------------- src/g_ltac2.mlg | 936 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 939 insertions(+), 871 deletions(-) delete mode 100644 src/g_ltac2.ml4 create mode 100644 src/g_ltac2.mlg diff --git a/_CoqProject b/_CoqProject index 15e02a6484..071066dd86 100644 --- a/_CoqProject +++ b/_CoqProject @@ -30,7 +30,7 @@ src/tac2tactics.ml src/tac2tactics.mli src/tac2stdlib.ml src/tac2stdlib.mli -src/g_ltac2.ml4 +src/g_ltac2.mlg src/ltac2_plugin.mlpack theories/Init.v diff --git a/src/dune b/src/dune index b0140aa809..7c911fb041 100644 --- a/src/dune +++ b/src/dune @@ -6,5 +6,5 @@ (rule (targets g_ltac2.ml) - (deps (:pp-file g_ltac2.ml4) ) - (action (run coqp5 -loc loc -impl %{pp-file} -o %{targets}))) + (deps (:mlg-file g_ltac2.mlg)) + (action (run coqpp %{mlg-file}))) diff --git a/src/g_ltac2.ml4 b/src/g_ltac2.ml4 deleted file mode 100644 index cb42b393db..0000000000 --- a/src/g_ltac2.ml4 +++ /dev/null @@ -1,868 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tok.t Stream.t -> int option - -let entry_of_lookahead s (lk : lookahead) = - let run strm = match lk 0 strm with None -> err () | Some _ -> () in - Gram.Entry.of_parser s run - -let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> None -| Some n -> lk2 n strm - -let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> lk2 n strm -| Some n -> Some n - -let lk_kw kw n strm = match stream_nth n strm with -| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None -| _ -> None - -let lk_ident n strm = match stream_nth n strm with -| IDENT _ -> Some (n + 1) -| _ -> None - -let lk_int n strm = match stream_nth n strm with -| INT _ -> Some (n + 1) -| _ -> None - -let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) - -(* lookahead for (x:=t), (?x:=t) and (1:=t) *) -let test_lpar_idnum_coloneq = - entry_of_lookahead "test_lpar_idnum_coloneq" begin - lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" - end - -(* lookahead for (x:t), (?x:t) *) -let test_lpar_id_colon = - entry_of_lookahead "test_lpar_id_colon" begin - lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" - end - -(* Hack to recognize "(x := t)" and "($x := t)" *) -let test_lpar_id_coloneq = - entry_of_lookahead "test_lpar_id_coloneq" begin - lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" - end - -(* Hack to recognize "(x)" *) -let test_lpar_id_rpar = - entry_of_lookahead "test_lpar_id_rpar" begin - lk_kw "(" >> lk_ident >> lk_kw ")" - end - -let test_ampersand_ident = - entry_of_lookahead "test_ampersand_ident" begin - lk_kw "&" >> lk_ident - end - -let test_dollar_ident = - entry_of_lookahead "test_dollar_ident" begin - lk_kw "$" >> lk_ident - end - -let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Entry.create "tactic:tac2type" -let tac2def_val = Entry.create "tactic:tac2def_val" -let tac2def_typ = Entry.create "tactic:tac2def_typ" -let tac2def_ext = Entry.create "tactic:tac2def_ext" -let tac2def_syn = Entry.create "tactic:tac2def_syn" -let tac2def_mut = Entry.create "tactic:tac2def_mut" -let tac2def_run = Entry.create "tactic:tac2def_run" -let tac2mode = Entry.create "vernac:ltac2_command" - -let ltac1_expr = Pltac.tactic_expr - -let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) -let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c -let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c -let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c -let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e - -let pattern_of_qualid qid = - if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) - else - let open Libnames in - if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) - else - CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") - -GEXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut tac2def_run; - tac2pat: - [ "1" LEFTA - [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> - if Tac2env.is_constructor qid then - CAst.make ~loc:!@loc @@ CPatRef (RelId qid, pl) - else - CErrors.user_err ~loc:!@loc (Pp.str "Syntax error") - | qid = Prim.qualid -> pattern_of_qualid qid - | "["; "]" -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) - | p1 = tac2pat; "::"; p2 = tac2pat -> - CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2]) - ] - | "0" - [ "_" -> CAst.make ~loc:!@loc @@ CPatVar Anonymous - | "()" -> CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) - | qid = Prim.qualid -> pattern_of_qualid qid - | "("; p = atomic_tac2pat; ")" -> p - ] ] - ; - atomic_tac2pat: - [ [ -> - CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple 0), []) - | p = tac2pat; ":"; t = tac2type -> - CAst.make ~loc:!@loc @@ CPatCnv (p, t) - | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> - let pl = p :: pl in - CAst.make ~loc:!@loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) - | p = tac2pat -> p - ] ] - ; - tac2expr: - [ "6" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> CAst.make ~loc:!@loc @@ CTacSeq (e1, e2) ] - | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> - CAst.make ~loc:!@loc @@ CTacFun (it, body) - | "let"; isrec = rec_flag; - lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "6" -> - CAst.make ~loc:!@loc @@ CTacLet (isrec, lc, e) - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> - CAst.make ~loc:!@loc @@ CTacCse (e, bl) - ] - | "4" LEFTA [ ] - | "::" RIGHTA - [ e1 = tac2expr; "::"; e2 = tac2expr -> - CAst.make ~loc:!@loc @@ CTacApp (CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) - ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> - let el = e0 :: el in - CAst.make ~loc:!@loc @@ CTacApp (CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) ] - | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> - CAst.make ~loc:!@loc @@ CTacApp (e, el) - | e = SELF; ".("; qid = Prim.qualid; ")" -> - CAst.make ~loc:!@loc @@ CTacPrj (e, RelId qid) - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> - CAst.make ~loc:!@loc @@ CTacSet (e, RelId qid, r) ] - | "0" - [ "("; a = SELF; ")" -> a - | "("; a = SELF; ":"; t = tac2type; ")" -> - CAst.make ~loc:!@loc @@ CTacCnv (a, t) - | "()" -> - CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) - | "("; ")" -> - CAst.make ~loc:!@loc @@ CTacCst (AbsKn (Tuple 0)) - | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> - Tac2quote.of_list ~loc:!@loc (fun x -> x) a - | "{"; a = tac2rec_fieldexprs; "}" -> - CAst.make ~loc:!@loc @@ CTacRec a - | a = tactic_atom -> a ] - ] - ; - branches: - [ [ -> [] - | "|"; bl = LIST1 branch SEP "|" -> bl - | bl = LIST1 branch SEP "|" -> bl ] - ] - ; - branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> (pat, e) ] ] - ; - rec_flag: - [ [ IDENT "rec" -> true - | -> false ] ] - ; - mut_flag: - [ [ IDENT "mutable" -> true - | -> false ] ] - ; - typ_param: - [ [ "'"; id = Prim.ident -> id ] ] - ; - tactic_atom: - [ [ n = Prim.integer -> CAst.make ~loc:!@loc @@ CTacAtm (AtmInt n) - | s = Prim.string -> CAst.make ~loc:!@loc @@ CTacAtm (AtmStr s) - | qid = Prim.qualid -> - if Tac2env.is_constructor qid then - CAst.make ~loc:!@loc @@ CTacCst (RelId qid) - else - CAst.make ~loc:!@loc @@ CTacRef (RelId qid) - | "@"; id = Prim.ident -> Tac2quote.of_ident (CAst.make ~loc:!@loc id) - | "&"; id = lident -> Tac2quote.of_hyp ~loc:!@loc id - | "'"; c = Constr.constr -> inj_open_constr !@loc c - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_constr c - | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> Tac2quote.of_open_constr c - | IDENT "ident"; ":"; "("; c = lident; ")" -> Tac2quote.of_ident c - | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> inj_pattern !@loc c - | IDENT "reference"; ":"; "("; c = globref; ")" -> inj_reference !@loc c - | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> inj_ltac1 !@loc qid - ] ] - ; - let_clause: - [ [ binder = let_binder; ":="; te = tac2expr -> - let (pat, fn) = binder in - let te = match fn with - | None -> te - | Some args -> CAst.make ~loc:!@loc @@ CTacFun (args, te) - in - (pat, te) - ] ] - ; - let_binder: - [ [ pats = LIST1 input_fun -> - match pats with - | [{CAst.v=CPatVar _} as pat] -> (pat, None) - | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) - | [pat] -> (pat, None) - | _ -> CErrors.user_err ~loc:!@loc (str "Invalid pattern") - ] ] - ; - tac2type: - [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> CAst.make ~loc:!@loc @@ CTypArrow (t1, t2) ] - | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> - let tl = t :: tl in - CAst.make ~loc:!@loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) ] - | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> CAst.make ~loc:!@loc @@ CTypRef (RelId qid, [t]) ] - | "0" - [ "("; t = tac2type LEVEL "5"; ")" -> t - | id = typ_param -> CAst.make ~loc:!@loc @@ CTypVar (Name id) - | "_" -> CAst.make ~loc:!@loc @@ CTypVar Anonymous - | qid = Prim.qualid -> CAst.make ~loc:!@loc @@ CTypRef (RelId qid, []) - | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - CAst.make ~loc:!@loc @@ CTypRef (RelId qid, p) ] - ]; - locident: - [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] - ; - binder: - [ [ "_" -> CAst.make ~loc:!@loc Anonymous - | l = Prim.ident -> CAst.make ~loc:!@loc (Name l) ] ] - ; - input_fun: - [ [ b = tac2pat LEVEL "0" -> b ] ] - ; - tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> - let e = if List.is_empty it then e else CAst.make ~loc:!@loc @@ CTacFun (it, e) in - (name, e) - ] ] - ; - tac2def_val: - [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> - StrVal (mut, isrec, l) - ] ] - ; - tac2def_mut: - [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> StrMut (qid, e) ] ] - ; - tac2def_run: - [ [ "Eval"; e = tac2expr -> StrRun e ] ] - ; - tac2typ_knd: - [ [ t = tac2type -> CTydDef (Some t) - | "["; ".."; "]" -> CTydOpn - | "["; t = tac2alg_constructors; "]" -> CTydAlg t - | "{"; t = tac2rec_fields; "}"-> CTydRec t ] ] - ; - tac2alg_constructors: - [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> cs - | cs = LIST0 tac2alg_constructor SEP "|" -> cs ] ] - ; - tac2alg_constructor: - [ [ c = Prim.ident -> (c, []) - | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> (c, args) ] ] - ; - tac2rec_fields: - [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> f :: l - | f = tac2rec_field; ";" -> [f] - | f = tac2rec_field -> [f] - | -> [] ] ] - ; - tac2rec_field: - [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> (id, mut, t) ] ] - ; - tac2rec_fieldexprs: - [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> f :: l - | f = tac2rec_fieldexpr; ";" -> [f] - | f = tac2rec_fieldexpr-> [f] - | -> [] ] ] - ; - tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> RelId qid, e ] ] - ; - tac2typ_prm: - [ [ -> [] - | id = typ_param -> [CAst.make ~loc:!@loc id] - | "("; ids = LIST1 [ id = typ_param -> CAst.make ~loc:!@loc id ] SEP "," ;")" -> ids - ] ] - ; - tac2typ_def: - [ [ prm = tac2typ_prm; id = Prim.qualid; (r, e) = tac2type_body -> (id, r, (prm, e)) ] ] - ; - tac2type_body: - [ [ -> false, CTydDef None - | ":="; e = tac2typ_knd -> false, e - | "::="; e = tac2typ_knd -> true, e - ] ] - ; - tac2def_typ: - [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> - StrTyp (isrec, l) - ] ] - ; - tac2def_ext: - [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; - plugin = Prim.string; name = Prim.string -> - let ml = { mltac_plugin = plugin; mltac_tactic = name } in - StrPrm (id, t, ml) - ] ] - ; - syn_node: - [ [ "_" -> CAst.make ~loc:!@loc None - | id = Prim.ident -> CAst.make ~loc:!@loc (Some id) - ] ] - ; - sexpr: - [ [ s = Prim.string -> SexprStr (CAst.make ~loc:!@loc s) - | n = Prim.integer -> SexprInt (CAst.make ~loc:!@loc n) - | id = syn_node -> SexprRec (!@loc, id, []) - | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> - SexprRec (!@loc, id, tok) - ] ] - ; - syn_level: - [ [ -> None - | ":"; n = Prim.integer -> Some n - ] ] - ; - tac2def_syn: - [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; - e = tac2expr -> - StrSyn (toks, n, e) - ] ] - ; - lident: - [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] - ; - globref: - [ [ "&"; id = Prim.ident -> CAst.make ~loc:!@loc (QHypothesis id) - | qid = Prim.qualid -> CAst.make ~loc:!@loc @@ QReference qid - ] ] - ; -END - -(** Quotation scopes used by notations *) - -open Tac2entries.Pltac - -let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) - -GEXTEND Gram - GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_destruction_arg q_reference q_with_bindings q_constr_matching - q_goal_matching q_hintdb q_move_location q_pose q_assert; - anti: - [ [ "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) ] ] - ; - ident_or_anti: - [ [ id = lident -> QExpr id - | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) - ] ] - ; - lident: - [ [ id = Prim.ident -> CAst.make ~loc:!@loc id ] ] - ; - lnatural: - [ [ n = Prim.natural -> CAst.make ~loc:!@loc n ] ] - ; - q_ident: - [ [ id = ident_or_anti -> id ] ] - ; - qhyp: - [ [ x = anti -> x - | n = lnatural -> QExpr (CAst.make ~loc:!@loc @@ QAnonHyp n) - | id = lident -> QExpr (CAst.make ~loc:!@loc @@ QNamedHyp id) - ] ] - ; - simple_binding: - [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> - CAst.make ~loc:!@loc (h, c) - ] ] - ; - bindings: - [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - CAst.make ~loc:!@loc @@ QExplicitBindings bl - | bl = LIST1 Constr.constr -> - CAst.make ~loc:!@loc @@ QImplicitBindings bl - ] ] - ; - q_bindings: - [ [ bl = bindings -> bl ] ] - ; - q_with_bindings: - [ [ bl = with_bindings -> bl ] ] - ; - intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> CAst.make ~loc:!@loc l ]] - ; -(* ne_intropatterns: *) -(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) -(* ; *) - or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> CAst.make ~loc:!@loc @@ QIntroOrPattern tc - | "()" -> CAst.make ~loc:!@loc @@ QIntroAndPattern (CAst.make ~loc:!@loc []) - | "("; si = simple_intropattern; ")" -> CAst.make ~loc:!@loc @@ QIntroAndPattern (CAst.make ~loc:!@loc [si]) - | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> - CAst.make ~loc:!@loc @@ QIntroAndPattern (CAst.make ~loc:!@loc (si::tc)) - | "("; si = simple_intropattern; "&"; - tc = LIST1 simple_intropattern SEP "&" ; ")" -> - (* (A & B & C) is translated into (A,(B,C)) *) - let rec pairify = function - | ([]|[_]|[_;_]) as l -> CAst.make ~loc:!@loc l - | t::q -> - let q = - CAst.make ~loc:!@loc @@ - QIntroAction (CAst.make ~loc:!@loc @@ - QIntroOrAndPattern (CAst.make ~loc:!@loc @@ - QIntroAndPattern (pairify q))) - in - CAst.make ~loc:!@loc [t; q] - in CAst.make ~loc:!@loc @@ QIntroAndPattern (pairify (si::tc)) ] ] - ; - equality_intropattern: - [ [ "->" -> CAst.make ~loc:!@loc @@ QIntroRewrite true - | "<-" -> CAst.make ~loc:!@loc @@ QIntroRewrite false - | "[="; tc = intropatterns; "]" -> CAst.make ~loc:!@loc @@ QIntroInjection tc ] ] - ; - naming_intropattern: - [ [ LEFTQMARK; id = lident -> - CAst.make ~loc:!@loc @@ QIntroFresh (QExpr id) - | "?$"; id = lident -> - CAst.make ~loc:!@loc @@ QIntroFresh (QAnti id) - | "?" -> - CAst.make ~loc:!@loc @@ QIntroAnonymous - | id = ident_or_anti -> - CAst.make ~loc:!@loc @@ QIntroIdentifier id - ] ] - ; - nonsimple_intropattern: - [ [ l = simple_intropattern -> l - | "*" -> CAst.make ~loc:!@loc @@ QIntroForthcoming true - | "**" -> CAst.make ~loc:!@loc @@ QIntroForthcoming false ]] - ; - simple_intropattern: - [ [ pat = simple_intropattern_closed -> -(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) - (** TODO: handle %pat *) - pat - ] ] - ; - simple_intropattern_closed: - [ [ pat = or_and_intropattern -> - CAst.make ~loc:!@loc @@ QIntroAction (CAst.make ~loc:!@loc @@ QIntroOrAndPattern pat) - | pat = equality_intropattern -> - CAst.make ~loc:!@loc @@ QIntroAction pat - | "_" -> - CAst.make ~loc:!@loc @@ QIntroAction (CAst.make ~loc:!@loc @@ QIntroWildcard) - | pat = naming_intropattern -> - CAst.make ~loc:!@loc @@ QIntroNaming pat - ] ] - ; - q_intropatterns: - [ [ ipat = intropatterns -> ipat ] ] - ; - q_intropattern: - [ [ ipat = simple_intropattern -> ipat ] ] - ; - nat_or_anti: - [ [ n = lnatural -> QExpr n - | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) - ] ] - ; - eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some pat - | -> None - ] ] - ; - with_bindings: - [ [ "with"; bl = bindings -> bl | -> CAst.make ~loc:!@loc @@ QNoBindings ] ] - ; - constr_with_bindings: - [ [ c = Constr.constr; l = with_bindings -> CAst.make ~loc:!@loc @@ (c, l) ] ] - ; - destruction_arg: - [ [ n = lnatural -> CAst.make ~loc:!@loc @@ QElimOnAnonHyp n - | id = lident -> CAst.make ~loc:!@loc @@ QElimOnIdent id - | c = constr_with_bindings -> CAst.make ~loc:!@loc @@ QElimOnConstr c - ] ] - ; - q_destruction_arg: - [ [ arg = destruction_arg -> arg ] ] - ; - as_or_and_ipat: - [ [ "as"; ipat = or_and_intropattern -> Some ipat - | -> None - ] ] - ; - occs_nums: - [ [ nl = LIST1 nat_or_anti -> CAst.make ~loc:!@loc @@ QOnlyOccurrences nl - | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> - CAst.make ~loc:!@loc @@ QAllOccurrencesBut (n::nl) - ] ] - ; - occs: - [ [ "at"; occs = occs_nums -> occs | -> CAst.make ~loc:!@loc QAllOccurrences ] ] - ; - hypident: - [ [ id = ident_or_anti -> - id,Locus.InHyp - | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> - id,Locus.InHypTypeOnly - | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> - id,Locus.InHypValueOnly - ] ] - ; - hypident_occ: - [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] - ; - in_clause: - [ [ "*"; occs=occs -> - { q_onhyps = None; q_concl_occs = occs } - | "*"; "|-"; occs = concl_occ -> - { q_onhyps = None; q_concl_occs = occs } - | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> - { q_onhyps = Some hl; q_concl_occs = occs } - | hl = LIST0 hypident_occ SEP "," -> - { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc:!@loc QNoOccurrences } - ] ] - ; - clause: - [ [ "in"; cl = in_clause -> CAst.make ~loc:!@loc @@ cl - | "at"; occs = occs_nums -> - CAst.make ~loc:!@loc @@ { q_onhyps = Some []; q_concl_occs = occs } - ] ] - ; - q_clause: - [ [ cl = clause -> cl ] ] - ; - concl_occ: - [ [ "*"; occs = occs -> occs - | -> CAst.make ~loc:!@loc QNoOccurrences - ] ] - ; - induction_clause: - [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = OPT clause -> - CAst.make ~loc:!@loc @@ { - indcl_arg = c; - indcl_eqn = eq; - indcl_as = pat; - indcl_in = cl; - } - ] ] - ; - q_induction_clause: - [ [ cl = induction_clause -> cl ] ] - ; - conversion: - [ [ c = Constr.constr -> - CAst.make ~loc:!@loc @@ QConvert c - | c1 = Constr.constr; "with"; c2 = Constr.constr -> - CAst.make ~loc:!@loc @@ QConvertWith (c1, c2) - ] ] - ; - q_conversion: - [ [ c = conversion -> c ] ] - ; - orient: - [ [ "->" -> CAst.make ~loc:!@loc (Some true) - | "<-" -> CAst.make ~loc:!@loc (Some false) - | -> CAst.make ~loc:!@loc None - ]] - ; - rewriter: - [ [ "!"; c = constr_with_bindings -> - (CAst.make ~loc:!@loc @@ QRepeatPlus,c) - | ["?"| LEFTQMARK]; c = constr_with_bindings -> - (CAst.make ~loc:!@loc @@ QRepeatStar,c) - | n = lnatural; "!"; c = constr_with_bindings -> - (CAst.make ~loc:!@loc @@ QPrecisely n,c) - | n = lnatural; ["?" | LEFTQMARK]; c = constr_with_bindings -> - (CAst.make ~loc:!@loc @@ QUpTo n,c) - | n = lnatural; c = constr_with_bindings -> - (CAst.make ~loc:!@loc @@ QPrecisely n,c) - | c = constr_with_bindings -> - (CAst.make ~loc:!@loc @@ QPrecisely (CAst.make 1), c) - ] ] - ; - oriented_rewriter: - [ [ b = orient; (m, c) = rewriter -> - CAst.make ~loc:!@loc @@ { - rew_orient = b; - rew_repeat = m; - rew_equatn = c; - } - ] ] - ; - q_rewriting: - [ [ r = oriented_rewriter -> r ] ] - ; - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tac2expr LEVEL "6" SEP "|" -> lta - | -> [] - ] ] - ; - tactic_then_gen: - [ [ ta = tac2expr; "|"; (first,last) = tactic_then_gen -> (Some ta :: first, last) - | ta = tac2expr; ".."; l = tactic_then_last -> ([], Some (Some ta, l)) - | ".."; l = tactic_then_last -> ([], Some (None, l)) - | ta = tac2expr -> ([Some ta], None) - | "|"; (first,last) = tactic_then_gen -> (None :: first, last) - | -> ([None], None) - ] ] - ; - q_dispatch: - [ [ d = tactic_then_gen -> CAst.make ~loc:!@loc d ] ] - ; - q_occurrences: - [ [ occs = occs -> occs ] ] - ; - red_flag: - [ [ IDENT "beta" -> CAst.make ~loc:!@loc @@ QBeta - | IDENT "iota" -> CAst.make ~loc:!@loc @@ QIota - | IDENT "match" -> CAst.make ~loc:!@loc @@ QMatch - | IDENT "fix" -> CAst.make ~loc:!@loc @@ QFix - | IDENT "cofix" -> CAst.make ~loc:!@loc @@ QCofix - | IDENT "zeta" -> CAst.make ~loc:!@loc @@ QZeta - | IDENT "delta"; d = delta_flag -> d - ] ] - ; - refglobal: - [ [ "&"; id = Prim.ident -> QExpr (CAst.make ~loc:!@loc @@ QHypothesis id) - | qid = Prim.qualid -> QExpr (CAst.make ~loc:!@loc @@ QReference qid) - | "$"; id = Prim.ident -> QAnti (CAst.make ~loc:!@loc id) - ] ] - ; - q_reference: - [ [ r = refglobal -> r ] ] - ; - refglobals: - [ [ gl = LIST1 refglobal -> CAst.make ~loc:!@loc gl ] ] - ; - delta_flag: - [ [ "-"; "["; idl = refglobals; "]" -> CAst.make ~loc:!@loc @@ QDeltaBut idl - | "["; idl = refglobals; "]" -> CAst.make ~loc:!@loc @@ QConst idl - | -> CAst.make ~loc:!@loc @@ QDeltaBut (CAst.make ~loc:!@loc []) - ] ] - ; - strategy_flag: - [ [ s = LIST1 red_flag -> CAst.make ~loc:!@loc s - | d = delta_flag -> - CAst.make ~loc:!@loc - [CAst.make ~loc:!@loc QBeta; CAst.make ~loc:!@loc QIota; CAst.make ~loc:!@loc QZeta; d] - ] ] - ; - q_strategy_flag: - [ [ flag = strategy_flag -> flag ] ] - ; - hintdb: - [ [ "*" -> CAst.make ~loc:!@loc @@ QHintAll - | l = LIST1 ident_or_anti -> CAst.make ~loc:!@loc @@ QHintDbs l - ] ] - ; - q_hintdb: - [ [ db = hintdb -> db ] ] - ; - match_pattern: - [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> CAst.make ~loc:!@loc @@ QConstrMatchContext (id, pat) - | pat = Constr.lconstr_pattern -> CAst.make ~loc:!@loc @@ QConstrMatchPattern pat ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; tac = tac2expr -> - CAst.make ~loc:!@loc @@ (mp, tac) - ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl ] ] - ; - q_constr_matching: - [ [ m = match_list -> m ] ] - ; - gmatch_hyp_pattern: - [ [ na = Prim.name; ":"; pat = match_pattern -> (na, pat) ] ] - ; - gmatch_pattern: - [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> - CAst.make ~loc:!@loc @@ { - q_goal_match_concl = p; - q_goal_match_hyps = hl; - } - ] ] - ; - gmatch_rule: - [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> - CAst.make ~loc:!@loc @@ (mp, tac) - ] ] - ; - gmatch_list: - [ [ mrl = LIST1 gmatch_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl - | "|"; mrl = LIST1 gmatch_rule SEP "|" -> CAst.make ~loc:!@loc @@ mrl ] ] - ; - q_goal_matching: - [ [ m = gmatch_list -> m ] ] - ; - move_location: - [ [ "at"; IDENT "top" -> CAst.make ~loc:!@loc @@ QMoveFirst - | "at"; IDENT "bottom" -> CAst.make ~loc:!@loc @@ QMoveLast - | IDENT "after"; id = ident_or_anti -> CAst.make ~loc:!@loc @@ QMoveAfter id - | IDENT "before"; id = ident_or_anti -> CAst.make ~loc:!@loc @@ QMoveBefore id - ] ] - ; - q_move_location: - [ [ mv = move_location -> mv ] ] - ; - as_name: - [ [ -> None - | "as"; id = ident_or_anti -> Some id - ] ] - ; - pose: - [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - CAst.make ~loc:!@loc (Some id, c) - | c = Constr.constr; na = as_name -> CAst.make ~loc:!@loc (na, c) - ] ] - ; - q_pose: - [ [ p = pose -> p ] ] - ; - as_ipat: - [ [ "as"; ipat = simple_intropattern -> Some ipat - | -> None - ] ] - ; - by_tactic: - [ [ "by"; tac = tac2expr -> Some tac - | -> None - ] ] - ; - assertion: - [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - CAst.make ~loc:!@loc (QAssertValue (id, c)) - | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> - let loc = !@loc in - let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in - CAst.make ~loc (QAssertType (Some ipat, c, tac)) - | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> - CAst.make ~loc:!@loc (QAssertType (ipat, c, tac)) - ] ] - ; - q_assert: - [ [ a = assertion -> a ] ] - ; -END - -(** Extension of constr syntax *) - -let () = Hook.set Tac2entries.register_constr_quotations begin fun () -> -GEXTEND Gram - Pcoq.Constr.operconstr: LEVEL "0" - [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc:!@loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - | test_ampersand_ident; "&"; id = Prim.ident -> - let tac = Tac2quote.of_exact_hyp ~loc:!@loc (CAst.make ~loc:!@loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc:!@loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - | test_dollar_ident; "$"; id = Prim.ident -> - let id = Loc.tag ~loc:!@loc id in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in - CAst.make ~loc:!@loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - ] ] - ; -END -end - -let pr_ltac2entry _ = mt () (** FIXME *) -let pr_ltac2expr _ = mt () (** FIXME *) - -VERNAC ARGUMENT EXTEND ltac2_entry -PRINTED BY pr_ltac2entry -| [ tac2def_val(v) ] -> [ v ] -| [ tac2def_typ(t) ] -> [ t ] -| [ tac2def_ext(e) ] -> [ e ] -| [ tac2def_syn(e) ] -> [ e ] -| [ tac2def_mut(e) ] -> [ e ] -| [ tac2def_run(e) ] -> [ e ] -END - -let classify_ltac2 = function -| StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow -| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernac_classifier.classify_as_sideeff - -VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTactic2Definition -| [ "Ltac2" ltac2_entry(e) ] => [ classify_ltac2 e ] -> [ - fun ~atts ~st -> - Tac2entries.register_struct ?local:(Attributes.only_locality atts) e; - st - ] -END - -let _ = - let mode = { - Proof_global.name = "Ltac2"; - set = (fun () -> Pvernac.set_command_entry tac2mode); - reset = (fun () -> Pvernac.(set_command_entry Vernac_.noedit_mode)); - } in - Proof_global.register_proof_mode mode - -VERNAC ARGUMENT EXTEND ltac2_expr -PRINTED BY pr_ltac2expr -| [ tac2expr(e) ] -> [ e ] -END - -open G_ltac -open Vernac_classifier - -VERNAC tac2mode EXTEND VernacLtac2 -| [ - ltac2_expr(t) ltac_use_default(default) ] => - [ classify_as_proofstep ] -> [ -(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - Tac2entries.call ~default t - ] -END - -open Stdarg - -VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF -| [ "Print" "Ltac2" reference(tac) ] -> [ Tac2entries.print_ltac tac ] -END diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg new file mode 100644 index 0000000000..5aad77596d --- /dev/null +++ b/src/g_ltac2.mlg @@ -0,0 +1,936 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tok.t Stream.t -> int option + +let entry_of_lookahead s (lk : lookahead) = + let run strm = match lk 0 strm with None -> err () | Some _ -> () in + Gram.Entry.of_parser s run + +let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> None +| Some n -> lk2 n strm + +let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> lk2 n strm +| Some n -> Some n + +let lk_kw kw n strm = match stream_nth n strm with +| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None +| _ -> None + +let lk_ident n strm = match stream_nth n strm with +| IDENT _ -> Some (n + 1) +| _ -> None + +let lk_int n strm = match stream_nth n strm with +| INT _ -> Some (n + 1) +| _ -> None + +let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) + +(* lookahead for (x:=t), (?x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + entry_of_lookahead "test_lpar_idnum_coloneq" begin + lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" + end + +(* lookahead for (x:t), (?x:t) *) +let test_lpar_id_colon = + entry_of_lookahead "test_lpar_id_colon" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" + end + +(* Hack to recognize "(x := t)" and "($x := t)" *) +let test_lpar_id_coloneq = + entry_of_lookahead "test_lpar_id_coloneq" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" + end + +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + entry_of_lookahead "test_lpar_id_rpar" begin + lk_kw "(" >> lk_ident >> lk_kw ")" + end + +let test_ampersand_ident = + entry_of_lookahead "test_ampersand_ident" begin + lk_kw "&" >> lk_ident + end + +let test_dollar_ident = + entry_of_lookahead "test_dollar_ident" begin + lk_kw "$" >> lk_ident + end + +let tac2expr = Tac2entries.Pltac.tac2expr +let tac2type = Entry.create "tactic:tac2type" +let tac2def_val = Entry.create "tactic:tac2def_val" +let tac2def_typ = Entry.create "tactic:tac2def_typ" +let tac2def_ext = Entry.create "tactic:tac2def_ext" +let tac2def_syn = Entry.create "tactic:tac2def_syn" +let tac2def_mut = Entry.create "tactic:tac2def_mut" +let tac2def_run = Entry.create "tactic:tac2def_run" +let tac2mode = Entry.create "vernac:ltac2_command" + +let ltac1_expr = Pltac.tactic_expr + +let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) +let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c +let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c +let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c +let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e + +let pattern_of_qualid qid = + if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) + else + let open Libnames in + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) + else + CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") + +} + +GRAMMAR EXTEND Gram + GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + tac2def_mut tac2def_run; + tac2pat: + [ "1" LEFTA + [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { + if Tac2env.is_constructor qid then + CAst.make ~loc @@ CPatRef (RelId qid, pl) + else + CErrors.user_err ~loc (Pp.str "Syntax error") } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } + | p1 = tac2pat; "::"; p2 = tac2pat -> + { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])} + ] + | "0" + [ "_" -> { CAst.make ~loc @@ CPatVar Anonymous } + | "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "("; p = atomic_tac2pat; ")" -> { p } + ] ] + ; + atomic_tac2pat: + [ [ -> + { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | p = tac2pat; ":"; t = tac2type -> + { CAst.make ~loc @@ CPatCnv (p, t) } + | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> + { let pl = p :: pl in + CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) } + | p = tac2pat -> { p } + ] ] + ; + tac2expr: + [ "6" RIGHTA + [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] + | "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacFun (it, body) } + | "let"; isrec = rec_flag; + lc = LIST1 let_clause SEP "with"; "in"; + e = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacLet (isrec, lc, e) } + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> + { CAst.make ~loc @@ CTacCse (e, bl) } + ] + | "4" LEFTA [ ] + | "::" RIGHTA + [ e1 = tac2expr; "::"; e2 = tac2expr -> + { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } + ] + | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + { let el = e0 :: el in + CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] + | "1" LEFTA + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + { CAst.make ~loc @@ CTacApp (e, el) } + | e = SELF; ".("; qid = Prim.qualid; ")" -> + { CAst.make ~loc @@ CTacPrj (e, RelId qid) } + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] + | "0" + [ "("; a = SELF; ")" -> { a } + | "("; a = SELF; ":"; t = tac2type; ")" -> + { CAst.make ~loc @@ CTacCnv (a, t) } + | "()" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "("; ")" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + { Tac2quote.of_list ~loc (fun x -> x) a } + | "{"; a = tac2rec_fieldexprs; "}" -> + { CAst.make ~loc @@ CTacRec a } + | a = tactic_atom -> { a } ] + ] + ; + branches: + [ [ -> { [] } + | "|"; bl = LIST1 branch SEP "|" -> { bl } + | bl = LIST1 branch SEP "|" -> { bl } ] + ] + ; + branch: + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] + ; + rec_flag: + [ [ IDENT "rec" -> { true } + | -> { false } ] ] + ; + mut_flag: + [ [ IDENT "mutable" -> { true } + | -> { false } ] ] + ; + typ_param: + [ [ "'"; id = Prim.ident -> { id } ] ] + ; + tactic_atom: + [ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) } + | s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) } + | qid = Prim.qualid -> + { if Tac2env.is_constructor qid then + CAst.make ~loc @@ CTacCst (RelId qid) + else + CAst.make ~loc @@ CTacRef (RelId qid) } + | "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) } + | "&"; id = lident -> { Tac2quote.of_hyp ~loc id } + | "'"; c = Constr.constr -> { inj_open_constr loc c } + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } + | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } + | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } + | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } + | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } + ] ] + ; + let_clause: + [ [ binder = let_binder; ":="; te = tac2expr -> + { let (pat, fn) = binder in + let te = match fn with + | None -> te + | Some args -> CAst.make ~loc @@ CTacFun (args, te) + in + (pat, te) } + ] ] + ; + let_binder: + [ [ pats = LIST1 input_fun -> + { match pats with + | [{CAst.v=CPatVar _} as pat] -> (pat, None) + | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) + | [pat] -> (pat, None) + | _ -> CErrors.user_err ~loc (str "Invalid pattern") } + ] ] + ; + tac2type: + [ "5" RIGHTA + [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] + | "2" + [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + { let tl = t :: tl in + CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] + | "1" LEFTA + [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] + | "0" + [ "("; t = tac2type LEVEL "5"; ")" -> { t } + | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } + | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } + | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } + | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> + { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] + ]; + locident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + binder: + [ [ "_" -> { CAst.make ~loc Anonymous } + | l = Prim.ident -> { CAst.make ~loc (Name l) } ] ] + ; + input_fun: + [ [ b = tac2pat LEVEL "0" -> { b } ] ] + ; + tac2def_body: + [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in + (name, e) } + ] ] + ; + tac2def_val: + [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + { StrVal (mut, isrec, l) } + ] ] + ; + tac2def_mut: + [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] + ; + tac2def_run: + [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] + ; + tac2typ_knd: + [ [ t = tac2type -> { CTydDef (Some t) } + | "["; ".."; "]" -> { CTydOpn } + | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } + | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] + ; + tac2alg_constructors: + [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs } + | cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ] + ; + tac2alg_constructor: + [ [ c = Prim.ident -> { (c, []) } + | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] + ; + tac2rec_fields: + [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } + | f = tac2rec_field; ";" -> { [f] } + | f = tac2rec_field -> { [f] } + | -> { [] } ] ] + ; + tac2rec_field: + [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] + ; + tac2rec_fieldexprs: + [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } + | f = tac2rec_fieldexpr; ";" -> { [f] } + | f = tac2rec_fieldexpr-> { [f] } + | -> { [] } ] ] + ; + tac2rec_fieldexpr: + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] + ; + tac2typ_prm: + [ [ -> { [] } + | id = typ_param -> { [CAst.make ~loc id] } + | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } + ] ] + ; + tac2typ_def: + [ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ] + ; + tac2type_body: + [ [ -> { false, CTydDef None } + | ":="; e = tac2typ_knd -> { false, e } + | "::="; e = tac2typ_knd -> { true, e } + ] ] + ; + tac2def_typ: + [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> + { StrTyp (isrec, l) } + ] ] + ; + tac2def_ext: + [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + plugin = Prim.string; name = Prim.string -> + { let ml = { mltac_plugin = plugin; mltac_tactic = name } in + StrPrm (id, t, ml) } + ] ] + ; + syn_node: + [ [ "_" -> { CAst.make ~loc None } + | id = Prim.ident -> { CAst.make ~loc (Some id) } + ] ] + ; + sexpr: + [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } + | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } + | id = syn_node -> { SexprRec (loc, id, []) } + | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + { SexprRec (loc, id, tok) } + ] ] + ; + syn_level: + [ [ -> { None } + | ":"; n = Prim.integer -> { Some n } + ] ] + ; + tac2def_syn: + [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; + e = tac2expr -> + { StrSyn (toks, n, e) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + globref: + [ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) } + | qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid } + ] ] + ; +END + +(** Quotation scopes used by notations *) + +{ + +open Tac2entries.Pltac + +let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) + +} + +GRAMMAR EXTEND Gram + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause + q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag + q_destruction_arg q_reference q_with_bindings q_constr_matching + q_goal_matching q_hintdb q_move_location q_pose q_assert; + anti: + [ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ] + ; + ident_or_anti: + [ [ id = lident -> { QExpr id } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + lnatural: + [ [ n = Prim.natural -> { CAst.make ~loc n } ] ] + ; + q_ident: + [ [ id = ident_or_anti -> { id } ] ] + ; + qhyp: + [ [ x = anti -> { x } + | n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) } + | id = lident -> { QExpr (CAst.make ~loc @@ QNamedHyp id) } + ] ] + ; + simple_binding: + [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (h, c) } + ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + { CAst.make ~loc @@ QExplicitBindings bl } + | bl = LIST1 Constr.constr -> + { CAst.make ~loc @@ QImplicitBindings bl } + ] ] + ; + q_bindings: + [ [ bl = bindings -> { bl } ] ] + ; + q_with_bindings: + [ [ bl = with_bindings -> { bl } ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ] + ; +(* ne_intropatterns: *) +(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) +(* ; *) + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc } + | "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) } + | "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) } + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) } + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + { let rec pairify = function + | ([]|[_]|[_;_]) as l -> CAst.make ~loc l + | t::q -> + let q = + CAst.make ~loc @@ + QIntroAction (CAst.make ~loc @@ + QIntroOrAndPattern (CAst.make ~loc @@ + QIntroAndPattern (pairify q))) + in + CAst.make ~loc [t; q] + in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ] + ; + equality_intropattern: + [ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true } + | "<-" -> { CAst.make ~loc @@ QIntroRewrite false } + | "[="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ] + ; + naming_intropattern: + [ [ LEFTQMARK; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QExpr id) } + | "?$"; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QAnti id) } + | "?" -> + { CAst.make ~loc @@ QIntroAnonymous } + | id = ident_or_anti -> + { CAst.make ~loc @@ QIntroIdentifier id } + ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> { l } + | "*" -> { CAst.make ~loc @@ QIntroForthcoming true } + | "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed -> +(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) + (** TODO: handle %pat *) + { pat } + ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) } + | pat = equality_intropattern -> + { CAst.make ~loc @@ QIntroAction pat } + | "_" -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) } + | pat = naming_intropattern -> + { CAst.make ~loc @@ QIntroNaming pat } + ] ] + ; + q_intropatterns: + [ [ ipat = intropatterns -> { ipat } ] ] + ; + q_intropattern: + [ [ ipat = simple_intropattern -> { ipat } ] ] + ; + nat_or_anti: + [ [ n = lnatural -> { QExpr n } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat } + | -> { None } + ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ] + ; + constr_with_bindings: + [ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ] + ; + destruction_arg: + [ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n } + | id = lident -> { CAst.make ~loc @@ QElimOnIdent id } + | c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c } + ] ] + ; + q_destruction_arg: + [ [ arg = destruction_arg -> { arg } ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl } + | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> + { CAst.make ~loc @@ QAllOccurrencesBut (n::nl) } + ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ] + ; + hypident: + [ [ id = ident_or_anti -> + { id,Locus.InHyp } + | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypTypeOnly } + | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypValueOnly } + ] ] + ; + hypident_occ: + [ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + { { q_onhyps = None; q_concl_occs = occs } } + | "*"; "|-"; occs = concl_occ -> + { { q_onhyps = None; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> + { { q_onhyps = Some hl; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP "," -> + { { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } } + ] ] + ; + clause: + [ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl } + | "at"; occs = occs_nums -> + { CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } } + ] ] + ; + q_clause: + [ [ cl = clause -> { cl } ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> { occs } + | -> { CAst.make ~loc QNoOccurrences } + ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = OPT clause -> + { CAst.make ~loc @@ { + indcl_arg = c; + indcl_eqn = eq; + indcl_as = pat; + indcl_in = cl; + } } + ] ] + ; + q_induction_clause: + [ [ cl = induction_clause -> { cl } ] ] + ; + conversion: + [ [ c = Constr.constr -> + { CAst.make ~loc @@ QConvert c } + | c1 = Constr.constr; "with"; c2 = Constr.constr -> + { CAst.make ~loc @@ QConvertWith (c1, c2) } + ] ] + ; + q_conversion: + [ [ c = conversion -> { c } ] ] + ; + orient: + [ [ "->" -> { CAst.make ~loc (Some true) } + | "<-" -> { CAst.make ~loc (Some false) } + | -> { CAst.make ~loc None } + ]] + ; + rewriter: + [ [ "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatPlus,c) } + | [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatStar,c) } + | n = lnatural; "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QUpTo n,c) } + | n = lnatural; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) } + ] ] + ; + oriented_rewriter: + [ [ b = orient; r = rewriter -> + { let (m, c) = r in + CAst.make ~loc @@ { + rew_orient = b; + rew_repeat = m; + rew_equatn = c; + } } + ] ] + ; + q_rewriting: + [ [ r = oriented_rewriter -> { r } ] ] + ; + tactic_then_last: + [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } + | -> { [] } + ] ] + ; + tactic_then_gen: + [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } + | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (None, l)) } + | ta = tac2expr -> { ([Some ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } + | -> { ([None], None) } + ] ] + ; + q_dispatch: + [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] + ; + q_occurrences: + [ [ occs = occs -> { occs } ] ] + ; + red_flag: + [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } + | IDENT "iota" -> { CAst.make ~loc @@ QIota } + | IDENT "match" -> { CAst.make ~loc @@ QMatch } + | IDENT "fix" -> { CAst.make ~loc @@ QFix } + | IDENT "cofix" -> { CAst.make ~loc @@ QCofix } + | IDENT "zeta" -> { CAst.make ~loc @@ QZeta } + | IDENT "delta"; d = delta_flag -> { d } + ] ] + ; + refglobal: + [ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) } + | qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + q_reference: + [ [ r = refglobal -> { r } ] ] + ; + refglobals: + [ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ] + ; + delta_flag: + [ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl } + | "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl } + | -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) } + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flag -> { CAst.make ~loc s } + | d = delta_flag -> + { CAst.make ~loc + [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } + ] ] + ; + q_strategy_flag: + [ [ flag = strategy_flag -> { flag } ] ] + ; + hintdb: + [ [ "*" -> { CAst.make ~loc @@ QHintAll } + | l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l } + ] ] + ; + q_hintdb: + [ [ db = hintdb -> { db } ] ] + ; + match_pattern: + [ [ IDENT "context"; id = OPT Prim.ident; + "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } + | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_constr_matching: + [ [ m = match_list -> { m } ] ] + ; + gmatch_hyp_pattern: + [ [ na = Prim.name; ":"; pat = match_pattern -> { (na, pat) } ] ] + ; + gmatch_pattern: + [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> + { CAst.make ~loc @@ { + q_goal_match_concl = p; + q_goal_match_hyps = hl; + } } + ] ] + ; + gmatch_rule: + [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + gmatch_list: + [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_goal_matching: + [ [ m = gmatch_list -> { m } ] ] + ; + move_location: + [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } + | "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast } + | IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id } + | IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id } + ] ] + ; + q_move_location: + [ [ mv = move_location -> { mv } ] ] + ; + as_name: + [ [ -> { None } + | "as"; id = ident_or_anti -> { Some id } + ] ] + ; + pose: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (Some id, c) } + | c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) } + ] ] + ; + q_pose: + [ [ p = pose -> { p } ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + by_tactic: + [ [ "by"; tac = tac2expr -> { Some tac } + | -> { None } + ] ] + ; + assertion: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (QAssertValue (id, c)) } + | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> + { let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in + CAst.make ~loc (QAssertType (Some ipat, c, tac)) } + | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> + { CAst.make ~loc (QAssertType (ipat, c, tac)) } + ] ] + ; + q_assert: + [ [ a = assertion -> { a } ] ] + ; +END + +(** Extension of constr syntax *) + +(* +GRAMMAR EXTEND Gram + Pcoq.Constr.operconstr: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_ampersand_ident; "&"; id = Prim.ident -> + { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_dollar_ident; "$"; id = Prim.ident -> + { let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + ] ] + ; +END +*) +{ + +let () = + +let open Extend in +let open Tok in +let (++) r s = Next (r, s) in +let rules = [ + Rule ( + Stop ++ Aentry test_dollar_ident ++ Atoken (KEYWORD "$") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Aentry test_ampersand_ident ++ Atoken (KEYWORD "&") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Atoken (IDENT "ltac2") ++ Atoken (KEYWORD ":") ++ + Atoken (KEYWORD "(") ++ Aentry tac2expr ++ Atoken (KEYWORD ")"), + begin fun _ tac _ _ _ loc -> + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ) +] in + +Hook.set Tac2entries.register_constr_quotations begin fun () -> + Gram.gram_extend Pcoq.Constr.operconstr (Some (Level "0"), [(None, None, rules)]) +end + +} + +{ + +let pr_ltac2entry _ = mt () (** FIXME *) +let pr_ltac2expr _ = mt () (** FIXME *) + +} + +VERNAC ARGUMENT EXTEND ltac2_entry +PRINTED BY { pr_ltac2entry } +| [ tac2def_val(v) ] -> { v } +| [ tac2def_typ(t) ] -> { t } +| [ tac2def_ext(e) ] -> { e } +| [ tac2def_syn(e) ] -> { e } +| [ tac2def_mut(e) ] -> { e } +| [ tac2def_run(e) ] -> { e } +END + +{ + +let classify_ltac2 = function +| StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernac_classifier.classify_as_sideeff + +} + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition +| #[ local = locality ] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + Tac2entries.register_struct ?local e + } +END + +{ + +let _ = + let mode = { + Proof_global.name = "Ltac2"; + set = (fun () -> Pvernac.set_command_entry tac2mode); + reset = (fun () -> Pvernac.(set_command_entry Vernac_.noedit_mode)); + } in + Proof_global.register_proof_mode mode + +} + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY { pr_ltac2expr } +| [ tac2expr(e) ] -> { e } +END + +{ + +open G_ltac +open Vernac_classifier + +} + +VERNAC { tac2mode } EXTEND VernacLtac2 +| [ ltac2_expr(t) ltac_use_default(default) ] => + { classify_as_proofstep } -> { +(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) + Tac2entries.call ~default t + } +END + +{ + +open Stdarg + +} + +VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF +| [ "Print" "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac tac } +END -- cgit v1.2.3 From f26974c7844d6a58d22c3a9d52b93c5a94f19214 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Oct 2018 11:37:10 +0100 Subject: Fix compilation w.r.t. coq/coq#8779. --- src/tac2core.ml | 2 -- src/tac2tactics.ml | 1 - 2 files changed, 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 7384652216..ec10c335e9 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -864,7 +864,6 @@ let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = true; expand_evars = true } @@ -874,7 +873,6 @@ let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 25431af2ea..b06427bc38 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -21,7 +21,6 @@ let thaw r f = Tac2ffi.app_fun1 f Tac2ffi.unit r () let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = None; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } -- cgit v1.2.3 From dcdd460710c36522ff10f1b12bbb0b0628c5542f Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sat, 17 Nov 2018 17:11:20 +0100 Subject: [coq] Overlay to adapt to coq/coq#9003 To be merged when the Coq developers merge the PR upstream. --- src/g_ltac2.mlg | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 5aad77596d..2e4fad73fd 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -882,8 +882,8 @@ END { let classify_ltac2 = function -| StrSyn _ -> Vernacexpr.VtUnknown, Vernacexpr.VtNow -| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernac_classifier.classify_as_sideeff +| StrSyn _ -> Vernacextend.(VtUnknown, VtNow) +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff } @@ -913,7 +913,7 @@ END { open G_ltac -open Vernac_classifier +open Vernacextend } -- cgit v1.2.3 From a67daa71f98cc01a61c4dae4e3dd6bcbf42bb9d4 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sat, 17 Nov 2018 18:00:56 +0100 Subject: [ci] Add travis setup, docker-based. Pretty straightforward; need to be enabled in the Travis console tho. --- .travis.yml | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000000..d52b3ebd25 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,39 @@ +dist: trusty +sudo: required +language: generic + +services: + - docker + +env: + global: + - NJOBS="2" + - CONTRIB_NAME="ltac2" + matrix: + - COQ_IMAGE="coqorg/coq:dev" + +install: | + # Prepare the COQ container + docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/${CONTRIB_NAME} -w /home/coq/${CONTRIB_NAME} ${COQ_IMAGE} + docker exec COQ /bin/bash --login -c " + # This bash script is double-quoted to interpolate Travis CI env vars: + echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex # -e = exit on failure; -x = trace for debug + # opam update -y + # opam install -y -j ${NJOBS} coq-mathcomp-ssreflect + opam config list + opam repo list + opam list + " +script: +- echo -e "${ANSI_YELLOW}Building ${CONTRIB_NAME}...${ANSI_RESET}" && echo -en 'travis_fold:start:script\\r' +- | + docker exec COQ /bin/bash --login -c " + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex + sudo chown -R coq:coq /home/coq/${CONTRIB_NAME} + make + " +- docker stop COQ # optional +- echo -en 'travis_fold:end:script\\r' -- cgit v1.2.3 From fd184924e1d8955d6cfe7d7645dfb8776b211195 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Nov 2018 19:20:29 +0100 Subject: Add an image status for the CI. --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 73785f6368..d49dd88076 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +[![Build Status](https://travis-ci.org/ppedrot/ltac2.svg?branch=master)](https://travis-ci.org/ppedrot/ltac2) + Overview ======== -- cgit v1.2.3 From 3ba8647971c441307dd61bc67dc2c3705b345b56 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Nov 2018 09:51:05 +0100 Subject: Add a Char module. --- _CoqProject | 1 + src/tac2core.ml | 10 ++++++++++ theories/Char.v | 12 ++++++++++++ theories/Ltac2.v | 1 + 4 files changed, 24 insertions(+) create mode 100644 theories/Char.v diff --git a/_CoqProject b/_CoqProject index 071066dd86..e2ef5cebe1 100644 --- a/_CoqProject +++ b/_CoqProject @@ -35,6 +35,7 @@ src/ltac2_plugin.mlpack theories/Init.v theories/Int.v +theories/Char.v theories/String.v theories/Ident.v theories/Array.v diff --git a/src/tac2core.ml b/src/tac2core.ml index ec10c335e9..b6983ed869 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -258,6 +258,16 @@ let () = define1 "int_neg" int begin fun m -> return (Value.of_int (~- m)) end +(** Char *) + +let () = define1 "char_of_int" int begin fun n -> + wrap (fun () -> Value.of_char (Char.chr n)) +end + +let () = define1 "char_to_int" char begin fun n -> + wrap (fun () -> Value.of_int (Char.code n)) +end + (** String *) let () = define2 "string_make" int char begin fun n c -> diff --git a/theories/Char.v b/theories/Char.v new file mode 100644 index 0000000000..29fef60f2c --- /dev/null +++ b/theories/Char.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char := "ltac2" "char_of_int". +Ltac2 @external to_int : char -> int := "ltac2" "char_to_int". diff --git a/theories/Ltac2.v b/theories/Ltac2.v index 3fe71f4c65..e838fb7b81 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -9,6 +9,7 @@ Require Export Ltac2.Init. Require Ltac2.Int. +Require Ltac2.Char. Require Ltac2.String. Require Ltac2.Ident. Require Ltac2.Array. -- cgit v1.2.3 From 93300e662b6e7571619508e6f6d47b963d5300d1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Nov 2018 10:00:50 +0100 Subject: Add a function to generate fresh reference instances. --- src/tac2core.ml | 8 ++++++++ theories/Env.v | 5 +++++ 2 files changed, 13 insertions(+) diff --git a/src/tac2core.ml b/src/tac2core.ml index b6983ed869..890062a6d1 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -867,6 +867,14 @@ let () = define1 "env_path" reference begin fun r -> throw err_notfound end +let () = define1 "env_instantiate" reference begin fun r -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let (sigma, c) = Evd.fresh_global env sigma r in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (Value.of_constr c) +end + (** ML types *) let constr_flags () = diff --git a/theories/Env.v b/theories/Env.v index 7e36aa7990..c9b250f4ba 100644 --- a/theories/Env.v +++ b/theories/Env.v @@ -20,3 +20,8 @@ Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expan Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". (** Returns the absolute name of the given reference. Panics if the reference does not exist. *) + +Ltac2 @ external instantiate : Std.reference -> constr := "ltac2" "env_instantiate". +(** Returns a fresh instance of the corresponding reference, in particular + generating fresh universe variables and constraints when this reference is + universe-polymorphic. *) -- cgit v1.2.3 From 387a56ced3a093af1e97ed08be02c93ceaf66aa8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Nov 2018 10:11:44 +0100 Subject: Adding a module to manipulate Ltac1 values. --- _CoqProject | 1 + doc/ltac2.md | 17 +++++++++ src/g_ltac2.mlg | 2 ++ src/tac2core.ml | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- src/tac2env.ml | 3 ++ src/tac2env.mli | 3 ++ src/tac2ffi.ml | 1 + src/tac2ffi.mli | 1 + src/tac2quote.ml | 1 + src/tac2quote.mli | 4 +++ theories/Ltac1.v | 36 +++++++++++++++++++ theories/Ltac2.v | 1 + 12 files changed, 171 insertions(+), 2 deletions(-) create mode 100644 theories/Ltac1.v diff --git a/_CoqProject b/_CoqProject index e2ef5cebe1..dda5a8001a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -47,4 +47,5 @@ theories/Fresh.v theories/Std.v theories/Env.v theories/Notations.v +theories/Ltac1.v theories/Ltac2.v diff --git a/doc/ltac2.md b/doc/ltac2.md index 3cee0ac494..b217cb08e6 100644 --- a/doc/ltac2.md +++ b/doc/ltac2.md @@ -880,6 +880,8 @@ a backtrace. ## Ltac1 from Ltac2 +### Simple API + One can call Ltac1 code from Ltac2 by using the `ltac1` quotation. It parses a Ltac1 expression, and semantics of this quotation is the evaluation of the corresponding code for its side effects. In particular, in cannot return values, @@ -888,6 +890,21 @@ and the quotation has type `unit`. Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited to the use of standalone function calls. +### Low-level API + +There exists a lower-level FFI into Ltac1 that is not recommended for daily use, +which is available in the `Ltac2.Ltac1` module. This API allows to directly +manipulate dynamically-typed Ltac1 values, either through the function calls, +or using the `ltac1val` quotation. The latter parses the same as `ltac1`, but +has type `Ltac2.Ltac1.t` instead of `unit`, and dynamically behaves as an Ltac1 +thunk, i.e. `ltac1val:(foo)` corresponds to the tactic closure that Ltac1 +would generate from `idtac; foo`. + +Due to intricate dynamic semantics, understanding when Ltac1 value quotations +focus is very hard. This is why some functions return a continuation-passing +style value, as it can dispatch dynamically between focused and unfocused +behaviour. + ## Ltac2 from Ltac1 Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 5aad77596d..0494227f1e 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -100,6 +100,7 @@ let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e +let inj_ltac1val loc e = inj_wit Tac2quote.wit_ltac1val loc e let pattern_of_qualid qid = if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) @@ -224,6 +225,7 @@ GRAMMAR EXTEND Gram | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } + | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1val loc qid } ] ] ; let_clause: diff --git a/src/tac2core.ml b/src/tac2core.ml index 890062a6d1..aad4814744 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -20,8 +20,11 @@ open Proofview.Notations module Value = Tac2ffi open Value -let std_core n = KerName.make Tac2env.std_prefix (Label.of_id (Id.of_string_soft n)) -let coq_core n = KerName.make Tac2env.coq_prefix (Label.of_id (Id.of_string_soft n)) +let core_prefix path n = KerName.make path (Label.of_id (Id.of_string_soft n)) + +let std_core n = core_prefix Tac2env.std_prefix n +let coq_core n = core_prefix Tac2env.coq_prefix n +let ltac1_core n = core_prefix Tac2env.ltac1_prefix n module Core = struct @@ -37,6 +40,7 @@ let t_ident = coq_core "ident" let t_option = coq_core "option" let t_exn = coq_core "exn" let t_reference = std_core "reference" +let t_ltac1 = ltac1_core "t" let c_nil = coq_core "[]" let c_cons = coq_core "::" @@ -875,6 +879,73 @@ let () = define1 "env_instantiate" reference begin fun r -> return (Value.of_constr c) end +(** Ltac1 in Ltac2 *) + +let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 +let of_ltac1 v = Value.of_ext Value.val_ltac1 v + +let () = define1 "ltac1_ref" (list ident) begin fun ids -> + let open Ltac_plugin in + let r = match ids with + | [] -> raise Not_found + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + if Tacenv.exists_tactic fp then + List.hd (Tacenv.locate_extended_all_tactic (Libnames.qualid_of_path fp)) + else raise Not_found + in + let tac = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) (Tacenv.interp_ltac r) in + return (Value.of_ext val_ltac1 tac) +end + +let () = define1 "ltac1_run" ltac1 begin fun v -> + let open Ltac_plugin in + Tacinterp.tactic_of_value (Tacinterp.default_ist ()) v >>= fun () -> + return v_unit +end + +let () = define3 "ltac1_apply" ltac1 (list ltac1) closure begin fun f args k -> + let open Ltac_plugin in + let open Tacexpr in + let open Locus in + let k ret = + Proofview.tclIGNORE (Tac2ffi.apply k [Value.of_ext val_ltac1 ret]) + in + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + Tacinterp.val_interp ist tac k >>= fun () -> + return v_unit +end + +let () = define1 "ltac1_of_constr" constr begin fun c -> + let open Ltac_plugin in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_constr c)) +end + +let () = define1 "ltac1_to_constr" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) +end + +let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> + let open Geninterp.Val in + return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) +end + +let () = define1 "ltac1_to_list" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option (Value.of_list of_ltac1) (Tacinterp.Value.to_list v)) +end + (** ML types *) let constr_flags () = @@ -1037,6 +1108,34 @@ let () = } in define_ml_object Tac2quote.wit_ltac1 obj +let () = + let open Ltac_plugin in + let intern self ist tac = + (** Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_ltac1 + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_closure ist tac)) + in + let subst s tac = Genintern.substitute Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1val:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1val obj + (** Ltac2 in terms *) let () = diff --git a/src/tac2env.ml b/src/tac2env.ml index dcf7440498..8198f92ff8 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -276,6 +276,9 @@ let coq_prefix = let std_prefix = MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) +let ltac1_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Ltac1"; "Ltac2"])) + (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2:value" diff --git a/src/tac2env.mli b/src/tac2env.mli index 7616579d63..c7e87c5432 100644 --- a/src/tac2env.mli +++ b/src/tac2env.mli @@ -133,6 +133,9 @@ val coq_prefix : ModPath.t val std_prefix : ModPath.t (** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) +val ltac1_prefix : ModPath.t +(** Path where the Ltac1 legacy FFI is defined. *) + (** {5 Generic arguments} *) val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index df1857c3e7..c271967bd6 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -96,6 +96,7 @@ let val_projection = Val.create "projection" let val_case = Val.create "case" let val_univ = Val.create "universe" let val_free : Names.Id.Set.t Val.tag = Val.create "free" +let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli index d801c4f605..bfc93d99e6 100644 --- a/src/tac2ffi.mli +++ b/src/tac2ffi.mli @@ -167,6 +167,7 @@ val val_projection : Projection.t Val.tag val val_case : Constr.case_info Val.tag val val_univ : Univ.Level.t Val.tag val val_free : Id.Set.t Val.tag +val val_ltac1 : Geninterp.Val.t Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 3bddfe7594..5a26e7465c 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -22,6 +22,7 @@ let wit_ident = Arg.create "ident" let wit_constr = Arg.create "constr" let wit_open_constr = Arg.create "open_constr" let wit_ltac1 = Arg.create "ltac1" +let wit_ltac1val = Arg.create "ltac1val" (** Syntactic quoting of expressions. *) diff --git a/src/tac2quote.mli b/src/tac2quote.mli index 09aa92f9ee..1b03dad8ec 100644 --- a/src/tac2quote.mli +++ b/src/tac2quote.mli @@ -96,3 +96,7 @@ val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) + +val wit_ltac1val : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a value-returning expression, with type Ltac1.t. *) diff --git a/theories/Ltac1.v b/theories/Ltac1.v new file mode 100644 index 0000000000..c4e0b606d0 --- /dev/null +++ b/theories/Ltac1.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t := "ltac2" "ltac1_ref". +(** Returns the Ltac1 definition with the given absolute name. *) + +Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". +(** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning + anything. *) + +Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". +(** Applies an Ltac1 value to a list of arguments, and provides the result in + CPS style. It does **not** run the returned value. *) + +(** Conversion functions *) + +Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". +Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". + +Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". +Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/theories/Ltac2.v b/theories/Ltac2.v index e838fb7b81..ac90f63560 100644 --- a/theories/Ltac2.v +++ b/theories/Ltac2.v @@ -20,4 +20,5 @@ Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. Require Ltac2.Env. +Require Ltac2.Ltac1. Require Export Ltac2.Notations. -- cgit v1.2.3 From f05f4ebe9e91829e2817c63d90ec328f430992c4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 23 Nov 2018 14:04:25 +0100 Subject: Fix w.r.t. coq/coq#9051. --- src/g_ltac2.mlg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 2a20264edc..12364a0bd8 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -25,7 +25,7 @@ type lookahead = int -> Tok.t Stream.t -> int option let entry_of_lookahead s (lk : lookahead) = let run strm = match lk 0 strm with None -> err () | Some _ -> () in - Gram.Entry.of_parser s run + Pcoq.Entry.of_parser s run let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with | None -> None @@ -859,7 +859,7 @@ let rules = [ ] in Hook.set Tac2entries.register_constr_quotations begin fun () -> - Gram.gram_extend Pcoq.Constr.operconstr (Some (Level "0"), [(None, None, rules)]) + Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Level "0"), [(None, None, rules)]) end } -- cgit v1.2.3 From 09b917593e90233d7a55610e9ce7886de77ef576 Mon Sep 17 00:00:00 2001 From: James R. Wilcox Date: Sat, 24 Nov 2018 13:22:50 -0800 Subject: tests/Makefile: support unset COQBIN, like top-level Makefile does --- tests/Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/Makefile b/tests/Makefile index 9370b063f8..37915e0d6f 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,3 +1,7 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + all: $(patsubst %.v,%.v.log,$(wildcard *.v)) %.v.log: %.v -- cgit v1.2.3 From e2fe373a1947206746dd43afe6c9815c69453def Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 28 Nov 2018 00:47:10 +0100 Subject: [build] Test tests in Travis, use coqc for tests. `coqtop -batch` is an oxymoron, in prevision for upstream changes use `coqc`. We also call `make test` in Travis as to make CI more robust. --- .travis.yml | 1 + tests/Makefile | 4 ++-- tests/example1.v | 1 + 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index d52b3ebd25..2628abde45 100644 --- a/.travis.yml +++ b/.travis.yml @@ -34,6 +34,7 @@ script: set -ex sudo chown -R coq:coq /home/coq/${CONTRIB_NAME} make + make tests " - docker stop COQ # optional - echo -en 'travis_fold:end:script\\r' diff --git a/tests/Makefile b/tests/Makefile index 37915e0d6f..d85ae90dd6 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,11 +1,11 @@ ifeq "$(COQBIN)" "" - COQBIN=$(dir $(shell which coqtop))/ + COQBIN=$(dir $(shell which coqc))/ endif all: $(patsubst %.v,%.v.log,$(wildcard *.v)) %.v.log: %.v - $(COQBIN)/coqtop -batch -I ../src -Q ../theories Ltac2 -lv $< > $@ + $(COQBIN)/coqc -I ../src -Q ../theories Ltac2 $< > $@ if [ $$? = 0 ]; then \ echo " $<... OK"; \ else \ diff --git a/tests/example1.v b/tests/example1.v index 1b26aad824..023791050f 100644 --- a/tests/example1.v +++ b/tests/example1.v @@ -24,3 +24,4 @@ Goal forall n m, n + m = 0 -> n = 0. Proof. refine (fun () => '(fun n m H => _)). let t := get_hyp_by_name @H in Message.print (Message.of_constr t). +Abort. -- cgit v1.2.3 From 8b1c09e551c02f26c524922570341f0f7fc78e2e Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 10 Dec 2018 21:07:45 +0100 Subject: [coq] Adapt to coq/coq#9172 Note that this highlights some issues with the current Coq interface, not clear what should we do. --- src/g_ltac2.mlg | 2 +- src/tac2core.ml | 3 ++- src/tac2entries.ml | 3 ++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 12364a0bd8..7020ca079e 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -859,7 +859,7 @@ let rules = [ ] in Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Level "0"), [(None, None, rules)]) + Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) end } diff --git a/src/tac2core.ml b/src/tac2core.ml index aad4814744..8e92e154ac 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1142,7 +1142,8 @@ let () = let interp ist env sigma concl tac = let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in - let c, sigma = Pfedit.refine_by_tactic env sigma concl tac in + let name, poly = Id.of_string "ltac2", false in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_ltac2 interp diff --git a/src/tac2entries.ml b/src/tac2entries.ml index bba4680a72..22025f0a8f 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -750,7 +750,8 @@ let perform_eval e = Proof_global.give_me_the_proof () with Proof_global.NoCurrentProof -> let sigma = Evd.from_env env in - Goal_select.SelectAll, Proof.start sigma [] + let name, poly = Id.of_string "ltac2", false in + Goal_select.SelectAll, Proof.start ~name ~poly sigma [] in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v -- cgit v1.2.3 From c9faee36005bea6add36b0eadb87af0f7439bb41 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Jan 2019 12:27:36 +0100 Subject: Adapt to Coq's new proof mode API --- src/g_ltac2.mlg | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 7020ca079e..c707a82e5b 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -897,13 +897,7 @@ END { -let _ = - let mode = { - Proof_global.name = "Ltac2"; - set = (fun () -> Pvernac.set_command_entry tac2mode); - reset = (fun () -> Pvernac.(set_command_entry Vernac_.noedit_mode)); - } in - Proof_global.register_proof_mode mode +let _ = Pvernac.register_proof_mode "Ltac2" tac2mode } -- cgit v1.2.3 From 49155a0817234299c45d04a14bd834f44fbc391f Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 28 Jan 2019 18:00:02 -0500 Subject: Make lazy_match! goal actually lazy It was missing `Control.once`. Fixes coq/ltac2#79 Fixes coq/ltac2#77 --- tests/matching.v | 19 +++++++++++++++++++ theories/Pattern.v | 2 +- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/tests/matching.v b/tests/matching.v index 6bc5706da7..4338cbd32f 100644 --- a/tests/matching.v +++ b/tests/matching.v @@ -50,3 +50,22 @@ match! reverse goal with check_id h' @i end. Abort. + +(* Check #79 *) +Goal 2 = 3. + Control.plus + (fun () + => lazy_match! goal with + | [ |- 2 = 3 ] => Control.zero (Tactic_failure None) + | [ |- 2 = _ ] => Control.zero (Tactic_failure (Some (Message.of_string "should not be printed"))) + end) + (fun e + => match e with + | Tactic_failure c + => match c with + | None => () + | _ => Control.zero e + end + | e => Control.zero e + end). +Abort. diff --git a/theories/Pattern.v b/theories/Pattern.v index ff7776b682..8d1fb0cd8a 100644 --- a/theories/Pattern.v +++ b/theories/Pattern.v @@ -125,7 +125,7 @@ Ltac2 lazy_goal_match0 rev pats := in Control.plus cur next end in - interp pats (). + Control.once (fun () => interp pats) (). Ltac2 multi_goal_match0 rev pats := let rec interp m := match m with -- cgit v1.2.3 From 14cb3c26e5b35a4d824838c76a7cf8d8a0fa35e0 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 1 Feb 2019 20:59:01 +0100 Subject: Adapt to https://github.com/coq/coq/pull/9410 --- src/tac2core.ml | 6 ++++-- src/tac2tactics.ml | 4 +++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index 8e92e154ac..b5ae446ed5 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -954,7 +954,8 @@ let constr_flags () = use_typeclasses = true; solve_unification_constraints = true; fail_evar = true; - expand_evars = true + expand_evars = true; + program_mode = false; } let open_constr_no_classes_flags () = @@ -963,7 +964,8 @@ let open_constr_no_classes_flags () = use_typeclasses = false; solve_unification_constraints = true; fail_evar = false; - expand_evars = true + expand_evars = true; + program_mode = false; } (** Embed all Ltac2 data into Values *) diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index b06427bc38..bc92ab43a8 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -22,7 +22,9 @@ let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = not with_evar; - Pretyping.expand_evars = true } + Pretyping.expand_evars = true; + Pretyping.program_mode = false; +} (** FIXME: export a better interface in Tactics *) let delayed_of_tactic tac env sigma = -- cgit v1.2.3 From 8f81a501b2dacd779b0c0eb75091ea10bdb8f2d7 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 8 Feb 2019 22:14:13 +0100 Subject: Remove VtUnknown classification That classification is going to disappear from Coq. However, I don't understand why it was used here. Can you confirm that the command can not open a proof? --- src/g_ltac2.mlg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index c707a82e5b..609e8a6c0e 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -884,7 +884,7 @@ END { let classify_ltac2 = function -| StrSyn _ -> Vernacextend.(VtUnknown, VtNow) +| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) | StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff } -- cgit v1.2.3 From 67cff8c545a25e7fa1a29b08d41fc64a7278508b Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 17 Dec 2018 19:01:04 +0100 Subject: [coq] Adapt to coq/coq#9137 To be merged when the upstream PR is merged. Not sure this is the right thing to do tho. --- src/dune | 1 + src/tac2tactics.ml | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/dune b/src/dune index 7c911fb041..4a018adb9a 100644 --- a/src/dune +++ b/src/dune @@ -2,6 +2,7 @@ (name ltac2) (public_name coq.plugins.ltac2) (modules_without_implementation tac2expr tac2qexpr tac2types) + (flags :standard -w -50) (libraries coq.plugins.firstorder)) (rule diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index bc92ab43a8..059a1babd7 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -29,7 +29,8 @@ let tactic_infer_flags with_evar = { (** FIXME: export a better interface in Tactics *) let delayed_of_tactic tac env sigma = let _, pv = Proofview.init sigma [] in - let c, pv, _, _ = Proofview.apply env tac pv in + let name, poly = Id.of_string "ltac2_delayed", false in + let c, pv, _, _ = Proofview.apply ~name ~poly env tac pv in (sigma, c) let delayed_of_thunk r tac env sigma = -- cgit v1.2.3 From 95483808fa2f95b3ef8fc6b3b6da14c23c88d620 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Wed, 19 Dec 2018 16:30:12 +0100 Subject: Adapt to coq/coq#8817 (SProp) --- src/tac2core.ml | 49 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 35 insertions(+), 14 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index b5ae446ed5..78cbe6d2be 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -66,6 +66,26 @@ let to_name c = match Value.to_option Value.to_ident c with | None -> Anonymous | Some id -> Name id +let of_relevance = function + | Sorts.Relevant -> ValInt 0 + | Sorts.Irrelevant -> ValInt 1 + +let to_relevance = function + | ValInt 0 -> Sorts.Relevant + | ValInt 1 -> Sorts.Irrelevant + | _ -> assert false + +let of_annot f Context.{binder_name;binder_relevance} = + of_tuple [|(f binder_name); of_relevance binder_relevance|] + +let to_annot f x = + match to_tuple x with + | [|x;y|] -> + let x = f x in + let y = to_relevance y in + Context.make_annot x y + | _ -> assert false + let of_instance u = let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in Value.of_array (fun v -> Value.of_ext Value.val_univ v) u @@ -75,12 +95,12 @@ let to_instance u = EConstr.EInstance.make (Univ.Instance.of_array u) let of_rec_declaration (nas, ts, cs) = - (Value.of_array of_name nas, + (Value.of_array (of_annot of_name) nas, Value.of_array Value.of_constr ts, Value.of_array Value.of_constr cs) let to_rec_declaration (nas, ts, cs) = - (Value.to_array to_name nas, + (Value.to_array (to_annot to_name) nas, Value.to_array Value.to_constr ts, Value.to_array Value.to_constr cs) @@ -338,19 +358,19 @@ let () = define1 "constr_kind" constr begin fun c -> |] | Prod (na, t, u) -> v_blk 6 [| - of_name na; + of_annot of_name na; Value.of_constr t; Value.of_constr u; |] | Lambda (na, t, c) -> v_blk 7 [| - of_name na; + of_annot of_name na; Value.of_constr t; Value.of_constr c; |] | LetIn (na, b, t, c) -> v_blk 8 [| - of_name na; + of_annot of_name na; Value.of_constr b; Value.of_constr t; Value.of_constr c; @@ -431,17 +451,17 @@ let () = define1 "constr_make" valexpr begin fun knd -> let t = Value.to_constr t in EConstr.mkCast (c, k, t) | (6, [|na; t; u|]) -> - let na = to_name na in + let na = to_annot to_name na in let t = Value.to_constr t in let u = Value.to_constr u in EConstr.mkProd (na, t, u) | (7, [|na; t; c|]) -> - let na = to_name na in + let na = to_annot to_name na in let t = Value.to_constr t in let u = Value.to_constr c in EConstr.mkLambda (na, t, u) | (8, [|na; b; t; c|]) -> - let na = to_name na in + let na = to_annot to_name na in let b = Value.to_constr b in let t = Value.to_constr t in let c = Value.to_constr c in @@ -511,7 +531,7 @@ end let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> Proofview.tclENV >>= fun env -> try - let ans = Inductiveops.make_case_info env ind Constr.RegularStyle in + let ans = Inductiveops.make_case_info env ind Sorts.Relevant Constr.RegularStyle in return (Value.of_ext Value.val_case ans) with e when CErrors.noncritical e -> throw err_notfound @@ -544,7 +564,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> Tacticals.New.tclZEROMSG (str "Variable already exists") else let open Context.Named.Declaration in - let nenv = EConstr.push_named (LocalAssum (id, t)) env in + let nenv = EConstr.push_named (LocalAssum (Context.make_annot id Sorts.Relevant, t)) env in let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in Proofview.Unsafe.tclEVARS sigma >>= fun () -> @@ -554,7 +574,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in let args = Array.of_list (EConstr.mkRel 1 :: args) in let ans = EConstr.mkEvar (evk, args) in - let ans = EConstr.mkLambda (Name id, t, ans) in + let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in return (Value.of_constr ans) | _ -> throw err_notfocussed @@ -759,16 +779,17 @@ end let () = define0 "hyps" begin pf_apply begin fun env _ -> - let open Context.Named.Declaration in + let open Context in + let open Named.Declaration in let hyps = List.rev (Environ.named_context env) in let map = function | LocalAssum (id, t) -> let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id; Value.of_option Value.of_constr None; Value.of_constr t|] + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr None; Value.of_constr t|] | LocalDef (id, c, t) -> let c = EConstr.of_constr c in let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id; Value.of_option Value.of_constr (Some c); Value.of_constr t|] + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr (Some c); Value.of_constr t|] in return (Value.of_list map hyps) end -- cgit v1.2.3 From 7c976ede65fbd5c6144e4cd58572c7c5a1229f73 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 20 Feb 2019 03:01:23 +0100 Subject: [coq] Fix OCaml warnings. In anticipation to https://github.com/coq/coq/pull/9605 , we fix all OCaml warnings. Fixes coq/ltac2#107 --- src/g_ltac2.mlg | 6 +++--- src/tac2core.ml | 12 +++++++----- src/tac2entries.ml | 20 ++++++++++---------- src/tac2env.ml | 2 +- src/tac2ffi.ml | 4 ++-- src/tac2intern.ml | 33 ++++++++++++++++----------------- src/tac2interp.ml | 2 +- src/tac2match.mli | 6 +++--- src/tac2print.ml | 4 ++-- src/tac2quote.ml | 12 ++++++------ 10 files changed, 51 insertions(+), 50 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 609e8a6c0e..7b058a339a 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -384,7 +384,7 @@ GRAMMAR EXTEND Gram ; END -(** Quotation scopes used by notations *) +(* Quotation scopes used by notations *) { @@ -866,8 +866,8 @@ end { -let pr_ltac2entry _ = mt () (** FIXME *) -let pr_ltac2expr _ = mt () (** FIXME *) +let pr_ltac2entry _ = mt () (* FIXME *) +let pr_ltac2expr _ = mt () (* FIXME *) } diff --git a/src/tac2core.ml b/src/tac2core.ml index b5ae446ed5..762a145318 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -404,6 +404,8 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_projection p; Value.of_constr c; |] + | Int _ -> + assert false end end @@ -753,7 +755,7 @@ let () = define1 "hyp" ident begin fun id -> let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in if mem then return (Value.of_constr (EConstr.mkVar id)) else Tacticals.New.tclZEROMSG - (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (** FIXME: Do something more sensible *) + (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (* FIXME: Do something more sensible *) end end @@ -1082,7 +1084,7 @@ let () = let () = let intern self ist tac = - (** Prevent inner calls to Ltac2 values *) + (* Prevent inner calls to Ltac2 values *) let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in let ist = { ist with Genintern.extra } in let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in @@ -1113,7 +1115,7 @@ let () = let () = let open Ltac_plugin in let intern self ist tac = - (** Prevent inner calls to Ltac2 values *) + (* Prevent inner calls to Ltac2 values *) let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in let ist = { ist with Genintern.extra } in let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in @@ -1300,7 +1302,7 @@ end let () = add_scope "tactic" begin function | [] -> - (** Default to level 5 parsing *) + (* Default to level 5 parsing *) let scope = Extend.Aentryl (tac2expr, "5") in let act tac = tac in Tac2entries.ScopeRule (scope, act) @@ -1407,7 +1409,7 @@ let rec make_seq_rule = function let Seqrule (r, c) = make_seq_rule rem in let r = { norec_rule = Next (r.norec_rule, scope.any_symbol) } in let f = match tok with - | SexprStr _ -> None (** Leave out mere strings *) + | SexprStr _ -> None (* Leave out mere strings *) | _ -> Some f in Seqrule (r, CvCns (c, f)) diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 22025f0a8f..b7ce363957 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -111,7 +111,7 @@ let push_typedef visibility sp kn (_, def) = match def with | GTydDef _ -> Tac2env.push_type visibility sp kn | GTydAlg { galg_constructors = cstrs } -> - (** Register constructors *) + (* Register constructors *) let iter (c, _) = let spc = change_sp_label sp c in let knc = change_kn_label kn c in @@ -120,7 +120,7 @@ let push_typedef visibility sp kn (_, def) = match def with Tac2env.push_type visibility sp kn; List.iter iter cstrs | GTydRec fields -> - (** Register fields *) + (* Register fields *) let iter (c, _, _) = let spc = change_sp_label sp c in let knc = change_kn_label kn c in @@ -140,7 +140,7 @@ let define_typedef kn (params, def as qdef) = match def with | GTydDef _ -> Tac2env.define_type kn qdef | GTydAlg { galg_constructors = cstrs } -> - (** Define constructors *) + (* Define constructors *) let constant = ref 0 in let nonconstant = ref 0 in let iter (c, args) = @@ -157,7 +157,7 @@ let define_typedef kn (params, def as qdef) = match def with Tac2env.define_type kn qdef; List.iter iter cstrs | GTydRec fs -> - (** Define projections *) + (* Define projections *) let iter i (id, mut, t) = let knp = change_kn_label kn id in let proj = { @@ -297,7 +297,7 @@ let inline_rec_tactic tactics = let loc = pat.loc in (Id.Set.add id avoid, CAst.make ?loc id :: ans) in - (** Fresh variables to abstract over the function patterns *) + (* Fresh variables to abstract over the function patterns *) let _, vars = List.fold_left fold_var (avoid, []) pat in let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in let bnd = List.map map_body tactics in @@ -656,13 +656,13 @@ let inTac2Abbreviation : abbreviation -> obj = let register_notation ?(local = false) tkn lev body = match tkn, lev with | [SexprRec (_, {loc;v=Some id}, [])], None -> - (** Tactic abbreviation *) + (* Tactic abbreviation *) let () = check_lowercase CAst.(make ?loc id) in let body = Tac2intern.globalize Id.Set.empty body in let abbr = { abbr_body = body } in ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) | _ -> - (** Check that the tokens make sense *) + (* Check that the tokens make sense *) let entries = List.map ParseToken.parse_token tkn in let fold accu tok = match tok with | TacTerm _ -> accu @@ -670,7 +670,7 @@ let register_notation ?(local = false) tkn lev body = match tkn, lev with | TacNonTerm (Anonymous, _) -> accu in let ids = List.fold_left fold Id.Set.empty entries in - (** Globalize so that names are absolute *) + (* Globalize so that names are absolute *) let body = Tac2intern.globalize ids body in let lev = match lev with Some _ -> lev | None -> Some 5 in let ext = { @@ -758,9 +758,9 @@ let perform_eval e = | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v | Goal_select.SelectId id -> Proofview.tclFOCUSID id v | Goal_select.SelectAll -> v - | Goal_select.SelectAlreadyFocused -> assert false (** TODO **) + | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) in - (** HACK: the API doesn't allow to return a value *) + (* HACK: the API doesn't allow to return a value *) let ans = ref None in let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in diff --git a/src/tac2env.ml b/src/tac2env.ml index 8198f92ff8..93ad57e97e 100644 --- a/src/tac2env.ml +++ b/src/tac2env.ml @@ -291,7 +291,7 @@ let is_constructor qid = let id = Id.to_string id in assert (String.length id > 0); match id with - | "true" | "false" -> true (** built-in constructors *) + | "true" | "false" -> true (* built-in constructors *) | _ -> match id.[0] with | 'A'..'Z' -> true diff --git a/src/tac2ffi.ml b/src/tac2ffi.ml index c271967bd6..e3127ab9df 100644 --- a/src/tac2ffi.ml +++ b/src/tac2ffi.ml @@ -349,12 +349,12 @@ let to_fun1 r0 r1 f = to_closure f let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = fun arity f args -> match args, arity with | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) - (** A few hardcoded cases for efficiency *) + (* A few hardcoded cases for efficiency *) | [a0], OneAty -> f a0 | [a0; a1], AddAty OneAty -> f a0 a1 | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 - (** Generic cases *) + (* Generic cases *) | a :: args, OneAty -> f a >>= fun f -> let MLTactic (arity, f) = to_closure f in diff --git a/src/tac2intern.ml b/src/tac2intern.ml index fe615853ce..de99fb167f 100644 --- a/src/tac2intern.ml +++ b/src/tac2intern.ml @@ -141,7 +141,7 @@ let empty_env () = { } let env_name env = - (** Generate names according to a provided environment *) + (* Generate names according to a provided environment *) let mk num = let base = num mod 26 in let rem = num / 26 in @@ -267,7 +267,6 @@ let fresh_reftype env (kn : KerName.t or_tuple) = (subst, t) (** First-order unification algorithm *) - let is_unfoldable kn = match snd (Tac2env.interp_type kn) with | GTydDef (Some _) -> true | GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false @@ -485,7 +484,7 @@ let check_elt_empty loc env t = match kind env t with let check_unit ?loc t = let env = empty_env () in - (** Should not matter, t should be closed. *) + (* Should not matter, t should be closed. *) let t = fresh_type_scheme env t in let maybe_unit = match kind env t with | GTypVar _ -> true @@ -618,7 +617,7 @@ let expand_pattern avoid bnd = let fold (avoid, bnd) (pat, t) = let na, expand = match pat.v with | CPatVar na -> - (** Don't expand variable patterns *) + (* Don't expand variable patterns *) na, None | _ -> let id = fresh_var avoid in @@ -691,7 +690,7 @@ let rec intern_rec env {loc;v=e} = match e with in let e = Tac2env.interp_alias kn in let map arg = - (** Thunk alias arguments *) + (* Thunk alias arguments *) let loc = arg.loc in let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in @@ -782,8 +781,8 @@ let rec intern_rec env {loc;v=e} = match e with intern_rec env e in let obj = interp_ml_object tag in - (** External objects do not have access to the named context because this is - not stable by dynamic semantics. *) + (* External objects do not have access to the named context because this is + not stable by dynamic semantics. *) let genv = Global.env_of_context Environ.empty_named_context_val in let ist = empty_glob_sign genv in let ist = { ist with extra = Store.set ist.extra ltac2_env env } in @@ -907,7 +906,7 @@ and intern_case env loc e pl = | CPatVar Anonymous -> let () = check_redundant_clause rem in let (br', brT) = intern_rec env br in - (** Fill all remaining branches *) + (* Fill all remaining branches *) let fill (ncst, narg) arity = if Int.equal arity 0 then let () = @@ -951,7 +950,7 @@ and intern_case env loc e pl = if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids in let fold env id tpe = - (** Instantiate all arguments *) + (* Instantiate all arguments *) let subst n = GTypVar subst.(n) in let tpe = subst_type subst tpe in push_name id (monomorphic tpe) env @@ -1005,7 +1004,7 @@ and intern_case env loc e pl = let get = function | GPatVar na -> na | GPatRef _ -> - user_err ?loc (str "TODO: Unhandled match case") (** FIXME *) + user_err ?loc (str "TODO: Unhandled match case") (* FIXME *) in let loc = pat.loc in let knc = match knc with @@ -1024,7 +1023,7 @@ and intern_case env loc e pl = if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids in let fold env id tpe = - (** Instantiate all arguments *) + (* Instantiate all arguments *) let subst n = GTypVar subst.(n) in let tpe = subst_type subst tpe in push_name id (monomorphic tpe) env @@ -1089,7 +1088,7 @@ and intern_record env loc fs = | _ -> assert false in let subst = Array.init params (fun _ -> fresh_id env) in - (** Set the answer [args] imperatively *) + (* Set the answer [args] imperatively *) let args = Array.make (List.length typdef) None in let iter (loc, pinfo, e) = if KerName.equal kn pinfo.pdata_type then @@ -1145,14 +1144,14 @@ let intern ~strict e = let intern_typedef self (ids, t) : glb_quant_typedef = let env = { (empty_env ()) with env_rec = self } in - (** Initialize type parameters *) + (* Initialize type parameters *) let map id = get_alias id env in let ids = List.map map ids in let count = ref (List.length ids) in let vars = ref UF.Map.empty in let iter n id = vars := UF.Map.add id (GTypVar n) !vars in let () = List.iteri iter ids in - (** Do not accept unbound type variables *) + (* Do not accept unbound type variables *) let env = { env with env_opn = false } in let intern t = let t = intern_type env t in @@ -1195,7 +1194,7 @@ let intern_open_type t = let check_subtype t1 t2 = let env = empty_env () in let t1 = fresh_type_scheme env t1 in - (** We build a substitution mimicking rigid variable by using dummy tuples *) + (* We build a substitution mimicking rigid variable by using dummy tuples *) let rigid i = GTypRef (Tuple (i + 1), []) in let (n, t2) = t2 in let subst = Array.init n rigid in @@ -1507,7 +1506,7 @@ let () = let intern ist tac = let env = match Genintern.Store.get ist.extra ltac2_env with | None -> - (** Only happens when Ltac2 is called from a constr or ltac1 quotation *) + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) let env = empty_env () in if !Ltac_plugin.Tacintern.strict_check then env else { env with env_str = false } @@ -1526,7 +1525,7 @@ let () = let intern ist (loc, id) = let env = match Genintern.Store.get ist.extra ltac2_env with | None -> - (** Only happens when Ltac2 is called from a constr or ltac1 quotation *) + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) let env = empty_env () in if !Ltac_plugin.Tacintern.strict_check then env else { env with env_str = false } diff --git a/src/tac2interp.ml b/src/tac2interp.ml index 6f158ac66e..b0f8083aeb 100644 --- a/src/tac2interp.ml +++ b/src/tac2interp.ml @@ -114,7 +114,7 @@ let rec interp (ist : environment) = function | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } in let ist = List.fold_left fold ist fixs in - (** Hack to make a cycle imperatively in the environment *) + (* Hack to make a cycle imperatively in the environment *) let iter (_, e, _) = e.clos_env <- ist.env_ist in let () = List.iter iter fixs in interp ist e diff --git a/src/tac2match.mli b/src/tac2match.mli index 7cfa1ed25f..c82c40d238 100644 --- a/src/tac2match.mli +++ b/src/tac2match.mli @@ -28,6 +28,6 @@ val match_goal: constr -> rev:bool -> match_rule -> - ((Id.t * context option) list * (** List of hypotheses matching: name + context *) - context option * (** Context for conclusion *) - Ltac_pretype.patvar_map (** Pattern variable substitution *)) Proofview.tactic + ((Id.t * context option) list * (* List of hypotheses matching: name + context *) + context option * (* Context for conclusion *) + Ltac_pretype.patvar_map (* Pattern variable substitution *)) Proofview.tactic diff --git a/src/tac2print.ml b/src/tac2print.ml index 0b20cf9f58..f4cb290265 100644 --- a/src/tac2print.ml +++ b/src/tac2print.ml @@ -272,7 +272,7 @@ let pr_glbexpr_gen lvl c = paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) | GTacExt (tag, arg) -> let tpe = interp_ml_object tag in - hov 0 (tpe.ml_print (Global.env ()) arg) (** FIXME *) + hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) | GTacPrm (prm, args) -> let args = match args with | [] -> mt () @@ -379,7 +379,7 @@ let rec pr_valexpr env sigma v t = match kind t with else match repr with | GTydDef None -> str "" | GTydDef (Some _) -> - (** Shouldn't happen thanks to kind *) + (* Shouldn't happen thanks to kind *) assert false | GTydAlg alg -> if Valexpr.is_int v then diff --git a/src/tac2quote.ml b/src/tac2quote.ml index 5a26e7465c..a98264745e 100644 --- a/src/tac2quote.ml +++ b/src/tac2quote.ml @@ -233,9 +233,9 @@ let abstract_vars loc vars tac = let na, tac = match def with | None -> (Anonymous, tac) | Some id0 -> - (** Trick: in order not to shadow a variable nor to choose an arbitrary - name, we reuse one which is going to be shadowed by the matched - variables anyways. *) + (* Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) let build_bindings (n, accu) na = match na with | Anonymous -> (n + 1, accu) | Name _ -> @@ -263,7 +263,7 @@ let of_conversion {loc;v=c} = match c with let vars = pattern_vars pat in let pat = of_option ?loc of_pattern (Some pat) in let c = of_constr c in - (** Order is critical here *) + (* Order is critical here *) let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in let c = abstract_vars loc vars c in of_tuple [pat; c] @@ -388,7 +388,7 @@ let of_constr_matching {loc;v=m} = (knd, pat, na) in let vars = pattern_vars pat in - (** Order of elements is crucial here! *) + (* Order of elements is crucial here! *) let vars = Id.Set.elements vars in let vars = List.map (fun id -> Name id) vars in let e = abstract_vars loc vars tac in @@ -429,7 +429,7 @@ let of_goal_matching {loc;v=gm} = let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in let map (_, na, _, _) = na in let hctx = List.map map hyps_pats in - (** Order of elements is crucial here! *) + (* Order of elements is crucial here! *) let vars = Id.Set.elements vars in let subst = List.map (fun id -> Name id) vars in (r, hyps, hctx, subst, concl_ctx) -- cgit v1.2.3 From c5a6a100844803b2da370e4828655a9da377e624 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 15 Mar 2019 12:04:49 +0100 Subject: Adapt to changes in Coq's printers API --- src/tac2core.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index e5499f0c73..15fd625650 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1184,8 +1184,8 @@ let () = GlobEnv.register_constr_interp0 wit_ltac2_quotation interp let () = - let pr_raw id = Genprint.PrinterBasic mt in - let pr_glb id = Genprint.PrinterBasic (fun () -> str "$" ++ Id.print id) in + let pr_raw id = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb id = Genprint.PrinterBasic (fun _env _sigma -> str "$" ++ Id.print id) in let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top @@ -1209,8 +1209,8 @@ let () = Geninterp.register_interp0 wit_ltac2 interp let () = - let pr_raw _ = Genprint.PrinterBasic mt in - let pr_glb e = Genprint.PrinterBasic (fun () -> Tac2print.pr_glbexpr e) in + let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top -- cgit v1.2.3 From ea68d316725cd5012abf1012497e1c00e9bbb9d2 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Sun, 17 Feb 2019 02:54:17 +0100 Subject: [coq] Adapt to coq/coq#9129 "removal of imperative proof state" --- src/g_ltac2.mlg | 9 +++++---- src/tac2core.ml | 8 +++++--- src/tac2entries.ml | 28 +++++++++++++++------------- src/tac2entries.mli | 8 ++++++-- src/tac2tactics.ml | 1 + 5 files changed, 32 insertions(+), 22 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 7b058a339a..a404227d3d 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -890,8 +890,8 @@ let classify_ltac2 = function } VERNAC COMMAND EXTEND VernacDeclareTactic2Definition -| #[ local = locality ] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { - Tac2entries.register_struct ?local e +| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate } END @@ -914,10 +914,11 @@ open Vernacextend } VERNAC { tac2mode } EXTEND VernacLtac2 -| [ ltac2_expr(t) ltac_use_default(default) ] => +| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => { classify_as_proofstep } -> { (* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - Tac2entries.call ~default t + fun ~pstate -> + Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate } END diff --git a/src/tac2core.ml b/src/tac2core.ml index 15fd625650..30beee58de 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -979,6 +979,7 @@ let constr_flags () = fail_evar = true; expand_evars = true; program_mode = false; + polymorphic = false; } let open_constr_no_classes_flags () = @@ -989,6 +990,7 @@ let open_constr_no_classes_flags () = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } (** Embed all Ltac2 data into Values *) @@ -1164,17 +1166,17 @@ let () = (** Ltac2 in terms *) let () = - let interp ist env sigma concl tac = + let interp ist poly env sigma concl tac = let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in - let name, poly = Id.of_string "ltac2", false in + let name, poly = Id.of_string "ltac2", poly in let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_ltac2 interp let () = - let interp ist env sigma concl id = + let interp ist poly env sigma concl id = let ist = Tac2interp.get_env ist in let c = Id.Map.find id ist.env_ist in let c = Value.to_constr c in diff --git a/src/tac2entries.ml b/src/tac2entries.ml index b7ce363957..3073aad84f 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -739,19 +739,20 @@ let register_redefinition ?(local = false) qid e = } in Lib.add_anonymous_leaf (inTac2Redefinition def) -let perform_eval e = +let perform_eval ~pstate e = let open Proofview.Notations in let env = Global.env () in let (e, ty) = Tac2intern.intern ~strict:false e in let v = Tac2interp.interp Tac2interp.empty_environment e in let selector, proof = - try - Goal_select.get_default_goal_selector (), - Proof_global.give_me_the_proof () - with Proof_global.NoCurrentProof -> + match pstate with + | None -> let sigma = Evd.from_env env in let name, poly = Id.of_string "ltac2", false in Goal_select.SelectAll, Proof.start ~name ~poly sigma [] + | Some pstate -> + Goal_select.get_default_goal_selector (), + Proof_global.give_me_the_proof pstate in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v @@ -773,13 +774,13 @@ let perform_eval e = (** Toplevel entries *) -let register_struct ?local str = match str with +let register_struct ?local ~pstate str = match str with | StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e | StrMut (qid, e) -> register_redefinition ?local qid e -| StrRun e -> perform_eval e +| StrRun e -> perform_eval ~pstate e (** Toplevel exception *) @@ -860,8 +861,8 @@ let print_ltac qid = (** Calling tactics *) -let solve default tac = - let status = Proof_global.with_current_proof begin fun etac p -> +let solve ~pstate default tac = + let pstate, status = Proof_global.with_current_proof begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in let (p, status) = Pfedit.solve g None tac ?with_end_tac p in @@ -869,15 +870,16 @@ let solve default tac = go back to the top of the prooftree *) let p = Proof.maximal_unfocus Vernacentries.command_focus p in p, status - end in - if not status then Feedback.feedback Feedback.AddedAxiom + end pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate -let call ~default e = +let call ~pstate ~default e = let loc = e.loc in let (e, t) = intern ~strict:false e in let () = check_unit ?loc t in let tac = Tac2interp.interp Tac2interp.empty_environment e in - solve default (Proofview.tclIGNORE tac) + solve ~pstate default (Proofview.tclIGNORE tac) (** Primitive algebraic types than can't be defined Coq-side *) diff --git a/src/tac2entries.mli b/src/tac2entries.mli index f97e35fec0..28b2120537 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -21,7 +21,11 @@ val register_type : ?local:bool -> rec_flag -> val register_primitive : ?local:bool -> Names.lident -> raw_typexpr -> ml_tactic_name -> unit -val register_struct : ?local:bool -> strexpr -> unit +val register_struct + : ?local:bool + -> pstate:Proof_global.t option + -> strexpr + -> unit val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit @@ -46,7 +50,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : default:bool -> raw_tacexpr -> unit +val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t (** {5 Toplevel exceptions} *) diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 059a1babd7..0c8522f495 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -24,6 +24,7 @@ let tactic_infer_flags with_evar = { Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } (** FIXME: export a better interface in Tactics *) -- cgit v1.2.3 From 9788d6d3b2799e5aeabaa4fbde9ae50d71f8b39b Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 26 Mar 2019 08:46:48 +0000 Subject: Fix for https://github.com/coq/coq/pull/8984 --- src/tac2tactics.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tac2tactics.ml b/src/tac2tactics.ml index 059a1babd7..5d9b14eab0 100644 --- a/src/tac2tactics.ml +++ b/src/tac2tactics.ml @@ -404,7 +404,7 @@ let eauto debug n p lems dbs = let typeclasses_eauto strategy depth dbs = let only_classes, dbs = match dbs with | None -> - true, [Hints.typeclasses_db] + true, [Class_tactics.typeclasses_db] | Some dbs -> let dbs = List.map Id.to_string dbs in false, dbs -- cgit v1.2.3 From 28d60e8f729ee6b66c9252c9766f3fe2d8d854cf Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 19 Nov 2018 20:10:59 +0100 Subject: [dune] Full Dune support. This add experimental support for building the full Ltac2 plugin with Dune, see tree at https://github.com/ejgallego/dune/tree/coq --- .gitignore | 3 +++ dune | 3 +++ dune-project | 3 +++ ltac2.opam | 0 src/dune | 6 +++--- theories/dune | 6 ++++++ 6 files changed, 18 insertions(+), 3 deletions(-) create mode 100644 dune create mode 100644 dune-project create mode 100644 ltac2.opam create mode 100644 theories/dune diff --git a/.gitignore b/.gitignore index 50ed772be3..00e15f8daa 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,6 @@ Makefile.coq.conf *.a *.aux tests/*.log +*.install +_build +.merlin diff --git a/dune b/dune new file mode 100644 index 0000000000..5dbc4db66a --- /dev/null +++ b/dune @@ -0,0 +1,3 @@ +(env + (dev (flags :standard -rectypes)) + (release (flags :standard -rectypes))) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000000..8154e999de --- /dev/null +++ b/dune-project @@ -0,0 +1,3 @@ +(lang dune 1.6) +(using coq 0.1) +(name ltac2) diff --git a/ltac2.opam b/ltac2.opam new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/dune b/src/dune index 4a018adb9a..332f3644b0 100644 --- a/src/dune +++ b/src/dune @@ -1,8 +1,8 @@ (library - (name ltac2) - (public_name coq.plugins.ltac2) + (name ltac2_plugin) + (public_name ltac2.plugin) (modules_without_implementation tac2expr tac2qexpr tac2types) - (flags :standard -w -50) + (flags :standard -warn-error -9-27-50) (libraries coq.plugins.firstorder)) (rule diff --git a/theories/dune b/theories/dune new file mode 100644 index 0000000000..1fe3ba28fe --- /dev/null +++ b/theories/dune @@ -0,0 +1,6 @@ +(coqlib + (name Ltac2) ; This determines the -R flag + (public_name ltac2.Ltac2) + (synopsis "Ltac 2 Plugin") + (libraries ltac2.plugin)) + -- cgit v1.2.3 From 93524ed2dfb3bbcc2006286954001039c95732cd Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 13 Mar 2019 11:09:06 +0100 Subject: overlay for PR 9733 --- src/g_ltac2.mlg | 8 ++++---- src/tac2core.ml | 2 +- src/tac2entries.ml | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index a404227d3d..2483ef459a 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -831,7 +831,7 @@ let open Tok in let (++) r s = Next (r, s) in let rules = [ Rule ( - Stop ++ Aentry test_dollar_ident ++ Atoken (KEYWORD "$") ++ Aentry Prim.ident, + Stop ++ Aentry test_dollar_ident ++ Atoken (pattern_for_KEYWORD "$") ++ Aentry Prim.ident, begin fun id _ _ loc -> let id = Loc.tag ~loc id in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in @@ -840,7 +840,7 @@ let rules = [ ); Rule ( - Stop ++ Aentry test_ampersand_ident ++ Atoken (KEYWORD "&") ++ Aentry Prim.ident, + Stop ++ Aentry test_ampersand_ident ++ Atoken (pattern_for_KEYWORD "&") ++ Aentry Prim.ident, begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in @@ -849,8 +849,8 @@ let rules = [ ); Rule ( - Stop ++ Atoken (IDENT "ltac2") ++ Atoken (KEYWORD ":") ++ - Atoken (KEYWORD "(") ++ Aentry tac2expr ++ Atoken (KEYWORD ")"), + Stop ++ Atoken (pattern_for_IDENT "ltac2") ++ Atoken (pattern_for_KEYWORD ":") ++ + Atoken (pattern_for_KEYWORD "(") ++ Aentry tac2expr ++ Atoken (pattern_for_KEYWORD ")"), begin fun _ tac _ _ _ loc -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) diff --git a/src/tac2core.ml b/src/tac2core.ml index 30beee58de..0f85f56c22 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1251,7 +1251,7 @@ open CAst let () = add_scope "keyword" begin function | [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (Tok.KEYWORD s) in + let scope = Extend.Atoken (Tok.pattern_for_KEYWORD s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "keyword" arg end diff --git a/src/tac2entries.ml b/src/tac2entries.ml index 3073aad84f..bce58653e6 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -539,7 +539,7 @@ let parse_scope = function CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) | SexprStr {v=str} -> let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in - ScopeRule (Extend.Atoken (Tok.IDENT str), (fun _ -> v_unit)) + ScopeRule (Extend.Atoken (Tok.pattern_for_IDENT str), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in CErrors.user_err ?loc (str "Invalid parsing token") -- cgit v1.2.3 From 70650127254e8122252e6c7201d4d835320a5585 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Sun, 31 Mar 2019 20:06:30 +0200 Subject: Remove test file with Timeout that failed spuriously. See https://gitlab.com/coq/coq/-/jobs/187496964 --- test-suite/bugs/closed/bug_4429.v | 31 ------------------------------- 1 file changed, 31 deletions(-) delete mode 100644 test-suite/bugs/closed/bug_4429.v diff --git a/test-suite/bugs/closed/bug_4429.v b/test-suite/bugs/closed/bug_4429.v deleted file mode 100644 index bf0e570ab8..0000000000 --- a/test-suite/bugs/closed/bug_4429.v +++ /dev/null @@ -1,31 +0,0 @@ -Require Import Arith.Compare_dec. -Require Import Unicode.Utf8. - -Fixpoint my_nat_iter (n : nat) {A} (f : A → A) (x : A) : A := - match n with - | O => x - | S n' => f (my_nat_iter n' f x) - end. - -Definition gcd_IT_F (f : nat * nat → nat) (mn : nat * nat) : nat := - match mn with - | (0, 0) => 0 - | (0, S n') => S n' - | (S m', 0) => S m' - | (S m', S n') => - match le_gt_dec (S m') (S n') with - | left _ => f (S m', S n' - S m') - | right _ => f (S m' - S n', S n') - end - end. - -Axiom max_correct_l : ∀ m n : nat, m <= max m n. -Axiom max_correct_r : ∀ m n : nat, n <= max m n. - -Hint Resolve max_correct_l max_correct_r : arith. - -Theorem foo : ∀ p p' p'' : nat, p'' < S (max p (max p' p'')). -Proof. - intros. - Timeout 3 eauto with arith. -Qed. -- cgit v1.2.3 From 6a10b18d428178a9accd70a9717e153bb180868f Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sun, 24 Mar 2019 22:53:38 +0100 Subject: [coq] Adapt to coq/coq#9815 --- src/g_ltac2.mlg | 8 ++++---- src/tac2core.ml | 38 ++++++++++++++------------------------ src/tac2entries.ml | 6 +++--- src/tac2entries.mli | 2 +- 4 files changed, 22 insertions(+), 32 deletions(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index 2483ef459a..fcf5d59ec9 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -831,7 +831,7 @@ let open Tok in let (++) r s = Next (r, s) in let rules = [ Rule ( - Stop ++ Aentry test_dollar_ident ++ Atoken (pattern_for_KEYWORD "$") ++ Aentry Prim.ident, + Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, begin fun id _ _ loc -> let id = Loc.tag ~loc id in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in @@ -840,7 +840,7 @@ let rules = [ ); Rule ( - Stop ++ Aentry test_ampersand_ident ++ Atoken (pattern_for_KEYWORD "&") ++ Aentry Prim.ident, + Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in @@ -849,8 +849,8 @@ let rules = [ ); Rule ( - Stop ++ Atoken (pattern_for_IDENT "ltac2") ++ Atoken (pattern_for_KEYWORD ":") ++ - Atoken (pattern_for_KEYWORD "(") ++ Aentry tac2expr ++ Atoken (pattern_for_KEYWORD ")"), + Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ + Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), begin fun _ tac _ _ _ loc -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) diff --git a/src/tac2core.ml b/src/tac2core.ml index 0f85f56c22..a584933e00 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1251,7 +1251,7 @@ open CAst let () = add_scope "keyword" begin function | [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (Tok.pattern_for_KEYWORD s) in + let scope = Extend.Atoken (Tok.PKEYWORD s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "keyword" arg end @@ -1381,34 +1381,25 @@ let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern open Extend exception SelfSymbol -type 'a any_symbol = { any_symbol : 'r. ('r, 'a) symbol } - let rec generalize_symbol : - type a s. (s, a) Extend.symbol -> a any_symbol = function -| Atoken tok -> - { any_symbol = Atoken tok } -| Alist1 e -> - let e = generalize_symbol e in - { any_symbol = Alist1 e.any_symbol } + type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function +| Atoken tok -> Atoken tok +| Alist1 e -> Alist1 (generalize_symbol e) | Alist1sep (e, sep) -> let e = generalize_symbol e in let sep = generalize_symbol sep in - { any_symbol = Alist1sep (e.any_symbol, sep.any_symbol) } -| Alist0 e -> - let e = generalize_symbol e in - { any_symbol = Alist0 e.any_symbol } + Alist1sep (e, sep) +| Alist0 e -> Alist0 (generalize_symbol e) | Alist0sep (e, sep) -> let e = generalize_symbol e in let sep = generalize_symbol sep in - { any_symbol = Alist0sep (e.any_symbol, sep.any_symbol) } -| Aopt e -> - let e = generalize_symbol e in - { any_symbol = Aopt e.any_symbol } + Alist0sep (e, sep) +| Aopt e -> Aopt (generalize_symbol e) | Aself -> raise SelfSymbol | Anext -> raise SelfSymbol -| Aentry e -> { any_symbol = Aentry e } -| Aentryl (e, l) -> { any_symbol = Aentryl (e, l) } -| Arules r -> { any_symbol = Arules r } +| Aentry e -> Aentry e +| Aentryl (e, l) -> Aentryl (e, l) +| Arules r -> Arules r type _ converter = | CvNil : (Loc.t -> raw_tacexpr) converter @@ -1420,17 +1411,16 @@ let rec apply : type a. a converter -> raw_tacexpr list -> a = function | CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) type seqrule = -| Seqrule : ('act, Loc.t -> raw_tacexpr) norec_rule * 'act converter -> seqrule +| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule let rec make_seq_rule = function | [] -> - let r = { norec_rule = Stop } in - Seqrule (r, CvNil) + Seqrule (Stop, CvNil) | tok :: rem -> let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in let scope = generalize_symbol scope in let Seqrule (r, c) = make_seq_rule rem in - let r = { norec_rule = Next (r.norec_rule, scope.any_symbol) } in + let r = NextNoRec (r, scope) in let f = match tok with | SexprStr _ -> None (* Leave out mere strings *) | _ -> Some f diff --git a/src/tac2entries.ml b/src/tac2entries.ml index bce58653e6..9fd01426de 100644 --- a/src/tac2entries.ml +++ b/src/tac2entries.ml @@ -514,7 +514,7 @@ type 'a token = | TacNonTerm of Name.t * 'a type scope_rule = -| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule type scope_interpretation = sexpr list -> scope_rule @@ -539,7 +539,7 @@ let parse_scope = function CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) | SexprStr {v=str} -> let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in - ScopeRule (Extend.Atoken (Tok.pattern_for_IDENT str), (fun _ -> v_unit)) + ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in CErrors.user_err ?loc (str "Invalid parsing token") @@ -567,7 +567,7 @@ type synext = { type krule = | KRule : - (raw_tacexpr, 'act, Loc.t -> raw_tacexpr) Extend.rule * + (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule let rec get_rule (tok : scope_rule token list) : krule = match tok with diff --git a/src/tac2entries.mli b/src/tac2entries.mli index 28b2120537..d493192bb3 100644 --- a/src/tac2entries.mli +++ b/src/tac2entries.mli @@ -33,7 +33,7 @@ val register_notation : ?local:bool -> sexpr list -> int option -> (** {5 Notations} *) type scope_rule = -| ScopeRule : (raw_tacexpr, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule type scope_interpretation = sexpr list -> scope_rule -- cgit v1.2.3 From 80ad88ea8e2aab71c3dd0bf05b39776c61c93392 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 2 Apr 2019 12:36:27 +0200 Subject: [opam] Update file to newer format and build system. Using Dune in the OPAM file does allow to use some goodies such as `dune-release` etc... --- ltac2.opam | 18 ++++++++++++++++++ opam/descr | 1 - opam/opam | 17 ----------------- 3 files changed, 18 insertions(+), 18 deletions(-) delete mode 100644 opam/descr delete mode 100644 opam/opam diff --git a/ltac2.opam b/ltac2.opam index e69de29bb2..47ceb882b1 100644 --- a/ltac2.opam +++ b/ltac2.opam @@ -0,0 +1,18 @@ +synopsis: "A Tactic Language for Coq." +description: "A Tactic Language for Coq." +name: "coq-ltac2" +opam-version: "2.0" +maintainer: "Pierre-Marie Pédrot " +authors: "Pierre-Marie Pédrot " +homepage: "https://github.com/ppedrot/ltac2" +dev-repo: "https://github.com/ppedrot/ltac2.git" +bug-reports: "https://github.com/ppedrot/ltac2/issues" +license: "LGPL 2.1" +doc: "https://ppedrot.github.io/ltac2/doc" + +depends: [ + "coq" { = "dev" } + "dune" { build & >= "1.9.0" } +] + +build: [ "dune" "build" "-p" name "-j" jobs ] diff --git a/opam/descr b/opam/descr deleted file mode 100644 index 82463c4f45..0000000000 --- a/opam/descr +++ /dev/null @@ -1 +0,0 @@ -A tactic language for Coq. diff --git a/opam/opam b/opam/opam deleted file mode 100644 index e461b97942..0000000000 --- a/opam/opam +++ /dev/null @@ -1,17 +0,0 @@ -opam-version: "1.2" -name: "coq-ltac2" -version: "0.1" -maintainer: "Pierre-Marie Pédrot " -author: "Pierre-Marie Pédrot " -license: "LGPL 2.1" -homepage: "https://github.com/ppedrot/ltac2" -dev-repo: "https://github.com/ppedrot/ltac2.git" -bug-reports: "https://github.com/ppedrot/ltac2/issues" -build: [ - [make "COQBIN=\"\"" "-j%{jobs}%"] -] -install: [make "install"] -remove: [make "uninstall"] -depends: [ - "coq" { = "dev" } -] -- cgit v1.2.3 From 0d8a4ec0f7486f47b7cff4cda465e2bd10c163ac Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sun, 27 Jan 2019 16:01:31 +0100 Subject: Adapt to coq/coq#8764 --- src/g_ltac2.mlg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg index fcf5d59ec9..0071dbb088 100644 --- a/src/g_ltac2.mlg +++ b/src/g_ltac2.mlg @@ -44,7 +44,7 @@ let lk_ident n strm = match stream_nth n strm with | _ -> None let lk_int n strm = match stream_nth n strm with -| INT _ -> Some (n + 1) +| NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) | _ -> None let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) -- cgit v1.2.3 From 5463cfbaaaab2e696c4bbeeeb38f03ca79d5949e Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 9 Apr 2019 11:03:13 +0200 Subject: Adapt to Coq's PR #9909 --- src/tac2core.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/tac2core.ml b/src/tac2core.ml index a584933e00..d7e7b91ee6 100644 --- a/src/tac2core.ml +++ b/src/tac2core.ml @@ -1030,9 +1030,10 @@ let () = let intern = intern_constr in let interp ist c = interp_constr (constr_flags ()) ist c in let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in let obj = { ml_intern = intern; - ml_subst = Detyping.subst_glob_constr; + ml_subst = subst; ml_interp = interp; ml_print = print; } in @@ -1042,9 +1043,10 @@ let () = let intern = intern_constr in let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in let obj = { ml_intern = intern; - ml_subst = Detyping.subst_glob_constr; + ml_subst = subst; ml_interp = interp; ml_print = print; } in @@ -1069,12 +1071,17 @@ let () = let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in GlbVal pat, gtypref t_pattern in + let subst subst c = + let env = Global.env () in + let sigma = Evd.from_env env in + Patternops.subst_pattern env sigma subst c + in let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in let interp _ c = return (Value.of_pattern c) in let obj = { ml_intern = intern; ml_interp = interp; - ml_subst = Patternops.subst_pattern; + ml_subst = subst; ml_print = print; } in define_ml_object Tac2quote.wit_pattern obj -- cgit v1.2.3 From 478db417e1a3a493870f012495bbc7348581ac17 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 12 Apr 2019 15:23:57 +0200 Subject: Remove `constr_of_global_in_context` This function seems unused. --- kernel/typeops.ml | 22 ---------------------- kernel/typeops.mli | 8 -------- library/global.ml | 1 - library/global.mli | 4 ---- 4 files changed, 35 deletions(-) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 12ffbf4357..af710e7822 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -462,28 +462,6 @@ let type_of_global_in_context env r = let inst = Univ.make_abstract_instance univs in Inductive.type_of_constructor (cstr,inst) specif, univs -(* Build a fresh instance for a given context, its associated substitution and - the instantiated constraints. *) - -let constr_of_global_in_context env r = - let open GlobRef in - match r with - | VarRef id -> mkVar id, Univ.AUContext.empty - | ConstRef c -> - let cb = lookup_constant c env in - let univs = Declareops.constant_polymorphic_context cb in - mkConstU (c, Univ.make_abstract_instance univs), univs - | IndRef ind -> - let (mib,_) = Inductive.lookup_mind_specif env ind in - let univs = Declareops.inductive_polymorphic_context mib in - mkIndU (ind, Univ.make_abstract_instance univs), univs - | ConstructRef cstr -> - let (mib,_) = - Inductive.lookup_mind_specif env (inductive_of_constructor cstr) - in - let univs = Declareops.inductive_polymorphic_context mib in - mkConstructU (cstr, Univ.make_abstract_instance univs), univs - (************************************************************************) (************************************************************************) diff --git a/kernel/typeops.mli b/kernel/typeops.mli index cc1885f42d..c8f3e506e6 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -107,14 +107,6 @@ val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t usage. For non-universe-polymorphic constants, it does not matter. *) -(** {6 Building a term from a global reference *) - -(** Map a global reference to a term in its local universe - context. The term should not be used without pushing it's universe - context in the environmnent of usage. For non-universe-polymorphic - constants, it does not matter. *) -val constr_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t - (** {6 Miscellaneous. } *) (** Check that hyps are included in env and fails with error otherwise *) diff --git a/library/global.ml b/library/global.ml index d9f8a6ffa3..55aed1c56e 100644 --- a/library/global.ml +++ b/library/global.ml @@ -157,7 +157,6 @@ let import c u d = globalize (Safe_typing.import c u d) let env_of_context hyps = reset_with_named_context hyps (env()) -let constr_of_global_in_context = Typeops.constr_of_global_in_context let type_of_global_in_context = Typeops.type_of_global_in_context let universes_of_global gr = diff --git a/library/global.mli b/library/global.mli index ca88d2dafd..76ac3f6279 100644 --- a/library/global.mli +++ b/library/global.mli @@ -131,10 +131,6 @@ val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool val is_type_in_type : GlobRef.t -> bool -val constr_of_global_in_context : Environ.env -> - GlobRef.t -> Constr.types * Univ.AUContext.t - [@@ocaml.deprecated "alias of [Typeops.constr_of_global_in_context]"] - val type_of_global_in_context : Environ.env -> GlobRef.t -> Constr.types * Univ.AUContext.t [@@ocaml.deprecated "alias of [Typeops.type_of_global_in_context]"] -- cgit v1.2.3 From d54d63adfd9bd399ca5c31d77977c81887a2e4f0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 23 Apr 2019 18:31:45 +0200 Subject: Deprecate the *_no_check variants of conversion tactics. --- plugins/ltac/g_auto.mlg | 2 +- plugins/ltac/rewrite.ml | 4 ++-- plugins/omega/coq_omega.ml | 8 ++++---- plugins/ssr/ssrcommon.ml | 4 +--- plugins/ssr/ssrtacticals.ml | 2 +- tactics/eauto.ml | 2 +- tactics/tactics.ml | 16 ++++++++-------- tactics/tactics.mli | 2 ++ 8 files changed, 20 insertions(+), 20 deletions(-) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 523c7c8305..ec5e46d89b 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -184,7 +184,7 @@ END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl_no_check x DEFAULTcast } +| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl ~check:false x DEFAULTcast } END { diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 2d40ba6562..99a9c1ab9a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1596,7 +1596,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> + convert_hyp ~check:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> @@ -1610,7 +1610,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = end | None, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_concl_no_check newt DEFAULTcast + convert_concl ~check:false newt DEFAULTcast in Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 4802608fda..f3bc791b8d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -535,7 +535,7 @@ let focused_simpl path = let open Tacmach.New in Proofview.Goal.enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast + convert_concl ~check:false newc DEFAULTcast end let focused_simpl path = focused_simpl path @@ -687,7 +687,7 @@ let simpl_coeffs path_init path_k = let n = Pervasives.(-) (List.length path_k) (List.length path_init) in let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast + convert_concl ~check:false newc DEFAULTcast end let rec shuffle p (t1,t2) = @@ -1849,12 +1849,12 @@ let destructure_hyps = match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 2a84469af0..f9b3284037 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -426,7 +426,7 @@ let mk_anon_id t gl_ids = (set s i (Char.chr (Char.code (get s i) + 1)); s) in Id.of_string_soft (Bytes.to_string (loop (n - 1))) -let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast +let convert_concl_no_check t = Tactics.convert_concl ~check:false t DEFAULTcast let convert_concl t = Tactics.convert_concl t DEFAULTcast let rename_hd_prod orig_name_ref gl = @@ -1408,8 +1408,6 @@ let tclINTRO_ANON ?seed () = | Some seed -> tclINTRO ~id:(Seed seed) ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> - let convert_concl_no_check t = - Tactics.convert_concl_no_check t DEFAULTcast in let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index bbe7bde78b..17e4114958 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -110,7 +110,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic - (Tactics.convert_hyp_no_check (NamedDecl.map_constr unmark hyp)) in + (Tactics.convert_hyp ~check:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 3019fc0231..70854e6e3c 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -515,6 +515,6 @@ let autounfold_one db cl = if did then match cl with | Some hyp -> change_in_hyp None (make_change_arg c') hyp - | None -> convert_concl_no_check c' DEFAULTcast + | None -> convert_concl ~check:false c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 066b9c7794..60027b06e8 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -697,7 +697,7 @@ let bind_red_expr_occurrences occs nbcl redexp = let reduct_in_concl (redfun,sty) = Proofview.Goal.enter begin fun gl -> - convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty + convert_concl ~check:false (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty end let reduct_in_hyp ?(check=false) redfun (id,where) = @@ -756,7 +756,7 @@ let e_change_in_concl (redfun,sty) = let sigma = Proofview.Goal.sigma gl in let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_concl_no_check c sty) + (convert_concl ~check:false c sty) end let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = @@ -2174,7 +2174,7 @@ let constructor_tac with_evars expctdnumopt i lbind = let nconstr = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; Tacticals.New.tclTHENLIST [ - convert_concl_no_check redcl DEFAULTcast; + convert_concl ~check:false redcl DEFAULTcast; intros; constructor_core with_evars (ind, i) lbind ] @@ -2203,7 +2203,7 @@ let any_constructor with_evars tacopt = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; Tacticals.New.tclTHENLIST [ - convert_concl_no_check redcl DEFAULTcast; + convert_concl ~check:false redcl DEFAULTcast; intros; any_constr ind nconstr 1 () ] @@ -2647,9 +2647,9 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = in Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; - convert_concl_no_check newcl DEFAULTcast; + convert_concl ~check:false newcl DEFAULTcast; intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; - Tacticals.New.tclMAP convert_hyp_no_check depdecls; + Tacticals.New.tclMAP (convert_hyp ~check:false) depdecls; eq_tac ] end @@ -4799,7 +4799,7 @@ let symmetry_red allowred = match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN - (convert_concl_no_check concl DEFAULTcast) + (convert_concl ~check:false concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym >>= apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind end @@ -4894,7 +4894,7 @@ let transitivity_red allowred t = match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN - (convert_concl_no_check concl DEFAULTcast) + (convert_concl ~check:false concl DEFAULTcast) (match t with | None -> Tacticals.New.pf_constr_of_global eq_data.trans >>= eapply | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t]) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 75b5caaa36..e545ec9b5f 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -36,7 +36,9 @@ val introduction : Id.t -> unit Proofview.tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic +[@@ocaml.deprecated "use [Tactics.convert_concl]"] val convert_hyp_no_check : named_declaration -> unit Proofview.tactic +[@@ocaml.deprecated "use [Tactics.convert_hyp]"] val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t -> int -> unit Proofview.tactic -- cgit v1.2.3 From db72bf79423fc17a3eecdfd559736bb887936cc6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 23 Apr 2019 18:39:13 +0200 Subject: Code factorization in conversion tactics. --- tactics/tactics.ml | 121 ++++++++++++++++++---------------------------------- tactics/tactics.mli | 4 +- 2 files changed, 43 insertions(+), 82 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 60027b06e8..af7db6f79b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -614,18 +614,22 @@ let cofix id = mutual_cofix id [] 0 type tactic_reduction = Reductionops.reduction_function type e_tactic_reduction = Reductionops.e_reduction_function -let pf_reduce_decl redfun where decl gl = +let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = let open Context.Named.Declaration in - let redfun' c = Tacmach.New.pf_apply redfun gl c in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then user_err (Id.print id.binder_name ++ str " has no value."); - LocalAssum (id,redfun' ty) + let (sigma, ty') = redfun false env sigma ty in + (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> - let b' = if where != InHypTypeOnly then redfun' b else b in - let ty' = if where != InHypValueOnly then redfun' ty else ty in - LocalDef (id,b',ty') + let (sigma, b') = + if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) + in + let (sigma, ty') = + if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) + in + (sigma, LocalDef (id,b',ty')) (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) @@ -695,41 +699,9 @@ let bind_red_expr_occurrences occs nbcl redexp = reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl (redfun,sty) = - Proofview.Goal.enter begin fun gl -> - convert_concl ~check:false (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty - end - -let reduct_in_hyp ?(check=false) redfun (id,where) = - Proofview.Goal.enter begin fun gl -> - convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) - end - -let revert_cast (redfun,kind as r) = - if kind == DEFAULTcast then (redfun,REVERTcast) else r - -let reduct_option ?(check=false) redfun = function - | Some id -> reduct_in_hyp ~check (fst redfun) id - | None -> reduct_in_concl (revert_cast redfun) - (** Tactic reduction modulo evars (for universes essentially) *) -let pf_e_reduce_decl redfun where decl gl = - let open Context.Named.Declaration in - let sigma = Proofview.Goal.sigma gl in - let redfun sigma c = redfun (Tacmach.New.pf_env gl) sigma c in - match decl with - | LocalAssum (id,ty) -> - if where == InHypValueOnly then - user_err (Id.print id.binder_name ++ str " has no value."); - let (sigma, ty') = redfun sigma ty in - (sigma, LocalAssum (id, ty')) - | LocalDef (id,b,ty) -> - let (sigma, b') = if where != InHypTypeOnly then redfun sigma b else (sigma, b) in - let (sigma, ty') = if where != InHypValueOnly then redfun sigma ty else (sigma, ty) in - (sigma, LocalDef (id, b', ty')) - -let e_reduct_in_concl ~check (redfun, sty) = +let e_change_in_concl ?(check = false) (redfun, sty) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in @@ -737,53 +709,39 @@ let e_reduct_in_concl ~check (redfun, sty) = (convert_concl ~check c' sty) end -let e_reduct_in_hyp ?(check=false) redfun (id, where) = +let e_change_in_hyp ?(check = false) redfun (id,where) = Proofview.Goal.enter begin fun gl -> - let (sigma, decl') = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + let sigma = Proofview.Goal.sigma gl in + let hyp = Tacmach.New.pf_get_hyp id gl in + let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp ~check decl') + (convert_hyp ~check c) end -let e_reduct_option ?(check=false) redfun = function - | Some id -> e_reduct_in_hyp ~check (fst redfun) id - | None -> e_reduct_in_concl ~check (revert_cast redfun) +let e_reduct_in_concl = e_change_in_concl -(** Versions with evars to maintain the unification of universes resulting - from conversions. *) +let reduct_in_concl ?(check = false) (redfun, sty) = + let redfun env sigma c = (sigma, redfun env sigma c) in + e_change_in_concl ~check (redfun, sty) -let e_change_in_concl (redfun,sty) = - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_concl ~check:false c sty) - end +let e_reduct_in_hyp ?(check=false) redfun (id, where) = + let redfun _ env sigma c = redfun env sigma c in + e_change_in_hyp ~check redfun (id, where) -let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = - let open Context.Named.Declaration in - match decl with - | LocalAssum (id,ty) -> - if where == InHypValueOnly then - user_err (Id.print id.binder_name ++ str " has no value."); - let (sigma, ty') = redfun false env sigma ty in - (sigma, LocalAssum (id, ty')) - | LocalDef (id,b,ty) -> - let (sigma, b') = - if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) - in - let (sigma, ty') = - if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) - in - (sigma, LocalDef (id,b',ty')) +let reduct_in_hyp ?(check = false) redfun (id, where) = + let redfun _ env sigma c = (sigma, redfun env sigma c) in + e_change_in_hyp ~check redfun (id, where) -let e_change_in_hyp redfun (id,where) = - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let hyp = Tacmach.New.pf_get_hyp id gl in - let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp c) - end +let revert_cast (redfun,kind as r) = + if kind == DEFAULTcast then (redfun,REVERTcast) else r + +let e_reduct_option ?(check=false) redfun = function + | Some id -> e_reduct_in_hyp ~check (fst redfun) id + | None -> e_change_in_concl ~check (revert_cast redfun) + +let reduct_option ?(check = false) (redfun, sty) where = + let redfun env sigma c = (sigma, redfun env sigma c) in + e_reduct_option ~check (redfun, sty) where type change_arg = Ltac_pretype.patvar_map -> env -> evar_map -> evar_map * EConstr.constr @@ -837,10 +795,13 @@ let change_on_subterm cv_pb deep t where env sigma c = (sigma, c) let change_in_concl occl t = - e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) + e_change_in_concl ~check:false ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) let change_in_hyp occl t id = - e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id + (* FIXME: we set the [check] flag only to reorder hypotheses in case of + introduction of dependencies in new variables. We should separate this + check from the conversion function. *) + e_change_in_hyp ~check:true (fun x -> change_on_subterm Reduction.CONV x t occl) id let change_option occl t = function | Some id -> change_in_hyp occl t id diff --git a/tactics/tactics.mli b/tactics/tactics.mli index e545ec9b5f..e7b95a820e 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -154,8 +154,8 @@ type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic -val reduct_in_concl : tactic_reduction * cast_kind -> unit Proofview.tactic -val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val reduct_in_concl : ?check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic +val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> -- cgit v1.2.3 From 7e8fbed8df5e3f819e4775df791fc85f235854fb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 23 Apr 2019 20:58:16 +0200 Subject: Allocate only one evar when applying a group of conversion tactics. --- tactics/tactics.ml | 83 +++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 60 insertions(+), 23 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index af7db6f79b..b70dd63211 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -718,6 +718,31 @@ let e_change_in_hyp ?(check = false) redfun (id,where) = (convert_hyp ~check c) end +let e_change_in_hyps ?(check=true) f args = + Proofview.Goal.enter begin fun gl -> + let fold (env, sigma) arg = + let (redfun, id, where) = f arg in + let hyp = + try lookup_named id env + with Not_found -> + raise (RefinerError (env, sigma, NoSuchHyp id)) + in + let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in + let sign = Logic.convert_hyp check (named_context_val env) sigma d in + let env = reset_with_named_context sign env in + (env, sigma) + in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (env, sigma) = List.fold_left fold (env, sigma) args in + let ty = Proofview.Goal.concl gl in + Proofview.Unsafe.tclEVARS sigma + <*> + Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true ty + end + end + let e_reduct_in_concl = e_change_in_concl let reduct_in_concl ?(check = false) (redfun, sty) = @@ -803,19 +828,27 @@ let change_in_hyp occl t id = check from the conversion function. *) e_change_in_hyp ~check:true (fun x -> change_on_subterm Reduction.CONV x t occl) id -let change_option occl t = function - | Some id -> change_in_hyp occl t id - | None -> change_in_concl occl t +let concrete_clause_of enum_hyps cl = match cl.onhyps with +| None -> + let f id = (id, AllOccurrences, InHyp) in + List.map f (enum_hyps ()) +| Some l -> + List.map (fun ((occs, id), w) -> (id, occs, w)) l let change chg c cls = Proofview.Goal.enter begin fun gl -> - let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in - Tacticals.New.tclMAP (function - | OnHyp (id,occs,where) -> - change_option (bind_change_occurrences occs chg) c (Some (id,where)) - | OnConcl occs -> - change_option (bind_change_occurrences occs chg) c None) - cls + let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in + begin match cls.concl_occs with + | NoOccurrences -> Proofview.tclUNIT () + | occs -> change_in_concl (bind_change_occurrences occs chg) c + end + <*> + let f (id, occs, where) = + let occl = bind_change_occurrences occs chg in + let redfun deep env sigma t = change_on_subterm Reduction.CONV deep c occl env sigma t in + (redfun, id, where) + in + e_change_in_hyps ~check:true f hyps end let change_concl t = @@ -842,14 +875,6 @@ let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) (* The main reduction function *) -let reduction_clause redexp cl = - let nbcl = List.length cl in - List.map (function - | OnHyp (id,occs,where) -> - (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) - | OnConcl occs -> - (None, bind_red_expr_occurrences occs nbcl redexp)) cl - let reduce redexp cl = let trace env sigma = let open Printer in @@ -858,12 +883,24 @@ let reduce redexp cl = in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> - let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in - let redexps = reduction_clause redexp cl' in + let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in + let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in - Tacticals.New.tclMAP (fun (where,redexp) -> - e_reduct_option ~check - (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps + begin match cl.concl_occs with + | NoOccurrences -> Proofview.tclUNIT () + | occs -> + let redexp = bind_red_expr_occurrences occs nbcl redexp in + let redfun = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + e_change_in_concl ~check (revert_cast redfun) + end + <*> + let f (id, occs, where) = + let redexp = bind_red_expr_occurrences occs nbcl redexp in + let (redfun, _) = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + let redfun _ env sigma c = redfun env sigma c in + (redfun, id, where) + in + e_change_in_hyps ~check f hyps end end -- cgit v1.2.3 From 66b6e83f4f4c32ad86333e13d65329be02c46048 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 25 Apr 2019 12:02:43 +0200 Subject: Prepare merge into Coq --- .gitignore | 18 - .travis.yml | 40 - LICENSE | 458 ---------- Makefile | 14 - README.md | 25 - _CoqProject | 51 -- doc/ltac2.md | 1036 ----------------------- dune | 3 - dune-project | 3 - ltac2.opam | 18 - src/dune | 11 - src/g_ltac2.mlg | 933 -------------------- src/ltac2_plugin.mlpack | 14 - src/tac2core.ml | 1446 ------------------------------- src/tac2core.mli | 30 - src/tac2dyn.ml | 27 - src/tac2dyn.mli | 34 - src/tac2entries.ml | 938 --------------------- src/tac2entries.mli | 93 -- src/tac2env.ml | 298 ------- src/tac2env.mli | 146 ---- src/tac2expr.mli | 190 ----- src/tac2extffi.ml | 40 - src/tac2extffi.mli | 16 - src/tac2ffi.ml | 382 --------- src/tac2ffi.mli | 189 ----- src/tac2intern.ml | 1545 ---------------------------------- src/tac2intern.mli | 46 - src/tac2interp.ml | 227 ----- src/tac2interp.mli | 37 - src/tac2match.ml | 232 ----- src/tac2match.mli | 33 - src/tac2print.ml | 488 ----------- src/tac2print.mli | 46 - src/tac2qexpr.mli | 173 ---- src/tac2quote.ml | 465 ---------- src/tac2quote.mli | 102 --- src/tac2stdlib.ml | 578 ------------- src/tac2stdlib.mli | 9 - src/tac2tactics.ml | 455 ---------- src/tac2tactics.mli | 124 --- src/tac2types.mli | 92 -- tests/Makefile | 16 - tests/compat.v | 58 -- tests/errors.v | 12 - tests/example1.v | 27 - tests/example2.v | 281 ------- tests/matching.v | 71 -- tests/quot.v | 26 - tests/rebind.v | 34 - tests/stuff/ltac2.v | 143 ---- tests/tacticals.v | 34 - tests/typing.v | 72 -- theories/Array.v | 14 - theories/Char.v | 12 - theories/Constr.v | 72 -- theories/Control.v | 76 -- theories/Env.v | 27 - theories/Fresh.v | 26 - theories/Ident.v | 17 - theories/Init.v | 69 -- theories/Int.v | 18 - theories/Ltac1.v | 36 - theories/Ltac2.v | 24 - theories/Message.v | 25 - theories/Notations.v | 568 ------------- theories/Pattern.v | 145 ---- theories/Std.v | 263 ------ theories/String.v | 14 - theories/dune | 6 - vendor/Ltac2/.gitignore | 18 + vendor/Ltac2/.travis.yml | 40 + vendor/Ltac2/LICENSE | 458 ++++++++++ vendor/Ltac2/Makefile | 14 + vendor/Ltac2/README.md | 25 + vendor/Ltac2/_CoqProject | 51 ++ vendor/Ltac2/doc/ltac2.md | 1036 +++++++++++++++++++++++ vendor/Ltac2/dune | 3 + vendor/Ltac2/dune-project | 3 + vendor/Ltac2/ltac2.opam | 18 + vendor/Ltac2/src/dune | 11 + vendor/Ltac2/src/g_ltac2.mlg | 933 ++++++++++++++++++++ vendor/Ltac2/src/ltac2_plugin.mlpack | 14 + vendor/Ltac2/src/tac2core.ml | 1446 +++++++++++++++++++++++++++++++ vendor/Ltac2/src/tac2core.mli | 30 + vendor/Ltac2/src/tac2dyn.ml | 27 + vendor/Ltac2/src/tac2dyn.mli | 34 + vendor/Ltac2/src/tac2entries.ml | 938 +++++++++++++++++++++ vendor/Ltac2/src/tac2entries.mli | 93 ++ vendor/Ltac2/src/tac2env.ml | 298 +++++++ vendor/Ltac2/src/tac2env.mli | 146 ++++ vendor/Ltac2/src/tac2expr.mli | 190 +++++ vendor/Ltac2/src/tac2extffi.ml | 40 + vendor/Ltac2/src/tac2extffi.mli | 16 + vendor/Ltac2/src/tac2ffi.ml | 382 +++++++++ vendor/Ltac2/src/tac2ffi.mli | 189 +++++ vendor/Ltac2/src/tac2intern.ml | 1545 ++++++++++++++++++++++++++++++++++ vendor/Ltac2/src/tac2intern.mli | 46 + vendor/Ltac2/src/tac2interp.ml | 227 +++++ vendor/Ltac2/src/tac2interp.mli | 37 + vendor/Ltac2/src/tac2match.ml | 232 +++++ vendor/Ltac2/src/tac2match.mli | 33 + vendor/Ltac2/src/tac2print.ml | 488 +++++++++++ vendor/Ltac2/src/tac2print.mli | 46 + vendor/Ltac2/src/tac2qexpr.mli | 173 ++++ vendor/Ltac2/src/tac2quote.ml | 465 ++++++++++ vendor/Ltac2/src/tac2quote.mli | 102 +++ vendor/Ltac2/src/tac2stdlib.ml | 578 +++++++++++++ vendor/Ltac2/src/tac2stdlib.mli | 9 + vendor/Ltac2/src/tac2tactics.ml | 455 ++++++++++ vendor/Ltac2/src/tac2tactics.mli | 124 +++ vendor/Ltac2/src/tac2types.mli | 92 ++ vendor/Ltac2/tests/Makefile | 16 + vendor/Ltac2/tests/compat.v | 58 ++ vendor/Ltac2/tests/errors.v | 12 + vendor/Ltac2/tests/example1.v | 27 + vendor/Ltac2/tests/example2.v | 281 +++++++ vendor/Ltac2/tests/matching.v | 71 ++ vendor/Ltac2/tests/quot.v | 26 + vendor/Ltac2/tests/rebind.v | 34 + vendor/Ltac2/tests/stuff/ltac2.v | 143 ++++ vendor/Ltac2/tests/tacticals.v | 34 + vendor/Ltac2/tests/typing.v | 72 ++ vendor/Ltac2/theories/Array.v | 14 + vendor/Ltac2/theories/Char.v | 12 + vendor/Ltac2/theories/Constr.v | 72 ++ vendor/Ltac2/theories/Control.v | 76 ++ vendor/Ltac2/theories/Env.v | 27 + vendor/Ltac2/theories/Fresh.v | 26 + vendor/Ltac2/theories/Ident.v | 17 + vendor/Ltac2/theories/Init.v | 69 ++ vendor/Ltac2/theories/Int.v | 18 + vendor/Ltac2/theories/Ltac1.v | 36 + vendor/Ltac2/theories/Ltac2.v | 24 + vendor/Ltac2/theories/Message.v | 25 + vendor/Ltac2/theories/Notations.v | 568 +++++++++++++ vendor/Ltac2/theories/Pattern.v | 145 ++++ vendor/Ltac2/theories/Std.v | 263 ++++++ vendor/Ltac2/theories/String.v | 14 + vendor/Ltac2/theories/dune | 6 + 140 files changed, 13291 insertions(+), 13291 deletions(-) delete mode 100644 .gitignore delete mode 100644 .travis.yml delete mode 100644 LICENSE delete mode 100644 Makefile delete mode 100644 README.md delete mode 100644 _CoqProject delete mode 100644 doc/ltac2.md delete mode 100644 dune delete mode 100644 dune-project delete mode 100644 ltac2.opam delete mode 100644 src/dune delete mode 100644 src/g_ltac2.mlg delete mode 100644 src/ltac2_plugin.mlpack delete mode 100644 src/tac2core.ml delete mode 100644 src/tac2core.mli delete mode 100644 src/tac2dyn.ml delete mode 100644 src/tac2dyn.mli delete mode 100644 src/tac2entries.ml delete mode 100644 src/tac2entries.mli delete mode 100644 src/tac2env.ml delete mode 100644 src/tac2env.mli delete mode 100644 src/tac2expr.mli delete mode 100644 src/tac2extffi.ml delete mode 100644 src/tac2extffi.mli delete mode 100644 src/tac2ffi.ml delete mode 100644 src/tac2ffi.mli delete mode 100644 src/tac2intern.ml delete mode 100644 src/tac2intern.mli delete mode 100644 src/tac2interp.ml delete mode 100644 src/tac2interp.mli delete mode 100644 src/tac2match.ml delete mode 100644 src/tac2match.mli delete mode 100644 src/tac2print.ml delete mode 100644 src/tac2print.mli delete mode 100644 src/tac2qexpr.mli delete mode 100644 src/tac2quote.ml delete mode 100644 src/tac2quote.mli delete mode 100644 src/tac2stdlib.ml delete mode 100644 src/tac2stdlib.mli delete mode 100644 src/tac2tactics.ml delete mode 100644 src/tac2tactics.mli delete mode 100644 src/tac2types.mli delete mode 100644 tests/Makefile delete mode 100644 tests/compat.v delete mode 100644 tests/errors.v delete mode 100644 tests/example1.v delete mode 100644 tests/example2.v delete mode 100644 tests/matching.v delete mode 100644 tests/quot.v delete mode 100644 tests/rebind.v delete mode 100644 tests/stuff/ltac2.v delete mode 100644 tests/tacticals.v delete mode 100644 tests/typing.v delete mode 100644 theories/Array.v delete mode 100644 theories/Char.v delete mode 100644 theories/Constr.v delete mode 100644 theories/Control.v delete mode 100644 theories/Env.v delete mode 100644 theories/Fresh.v delete mode 100644 theories/Ident.v delete mode 100644 theories/Init.v delete mode 100644 theories/Int.v delete mode 100644 theories/Ltac1.v delete mode 100644 theories/Ltac2.v delete mode 100644 theories/Message.v delete mode 100644 theories/Notations.v delete mode 100644 theories/Pattern.v delete mode 100644 theories/Std.v delete mode 100644 theories/String.v delete mode 100644 theories/dune create mode 100644 vendor/Ltac2/.gitignore create mode 100644 vendor/Ltac2/.travis.yml create mode 100644 vendor/Ltac2/LICENSE create mode 100644 vendor/Ltac2/Makefile create mode 100644 vendor/Ltac2/README.md create mode 100644 vendor/Ltac2/_CoqProject create mode 100644 vendor/Ltac2/doc/ltac2.md create mode 100644 vendor/Ltac2/dune create mode 100644 vendor/Ltac2/dune-project create mode 100644 vendor/Ltac2/ltac2.opam create mode 100644 vendor/Ltac2/src/dune create mode 100644 vendor/Ltac2/src/g_ltac2.mlg create mode 100644 vendor/Ltac2/src/ltac2_plugin.mlpack create mode 100644 vendor/Ltac2/src/tac2core.ml create mode 100644 vendor/Ltac2/src/tac2core.mli create mode 100644 vendor/Ltac2/src/tac2dyn.ml create mode 100644 vendor/Ltac2/src/tac2dyn.mli create mode 100644 vendor/Ltac2/src/tac2entries.ml create mode 100644 vendor/Ltac2/src/tac2entries.mli create mode 100644 vendor/Ltac2/src/tac2env.ml create mode 100644 vendor/Ltac2/src/tac2env.mli create mode 100644 vendor/Ltac2/src/tac2expr.mli create mode 100644 vendor/Ltac2/src/tac2extffi.ml create mode 100644 vendor/Ltac2/src/tac2extffi.mli create mode 100644 vendor/Ltac2/src/tac2ffi.ml create mode 100644 vendor/Ltac2/src/tac2ffi.mli create mode 100644 vendor/Ltac2/src/tac2intern.ml create mode 100644 vendor/Ltac2/src/tac2intern.mli create mode 100644 vendor/Ltac2/src/tac2interp.ml create mode 100644 vendor/Ltac2/src/tac2interp.mli create mode 100644 vendor/Ltac2/src/tac2match.ml create mode 100644 vendor/Ltac2/src/tac2match.mli create mode 100644 vendor/Ltac2/src/tac2print.ml create mode 100644 vendor/Ltac2/src/tac2print.mli create mode 100644 vendor/Ltac2/src/tac2qexpr.mli create mode 100644 vendor/Ltac2/src/tac2quote.ml create mode 100644 vendor/Ltac2/src/tac2quote.mli create mode 100644 vendor/Ltac2/src/tac2stdlib.ml create mode 100644 vendor/Ltac2/src/tac2stdlib.mli create mode 100644 vendor/Ltac2/src/tac2tactics.ml create mode 100644 vendor/Ltac2/src/tac2tactics.mli create mode 100644 vendor/Ltac2/src/tac2types.mli create mode 100644 vendor/Ltac2/tests/Makefile create mode 100644 vendor/Ltac2/tests/compat.v create mode 100644 vendor/Ltac2/tests/errors.v create mode 100644 vendor/Ltac2/tests/example1.v create mode 100644 vendor/Ltac2/tests/example2.v create mode 100644 vendor/Ltac2/tests/matching.v create mode 100644 vendor/Ltac2/tests/quot.v create mode 100644 vendor/Ltac2/tests/rebind.v create mode 100644 vendor/Ltac2/tests/stuff/ltac2.v create mode 100644 vendor/Ltac2/tests/tacticals.v create mode 100644 vendor/Ltac2/tests/typing.v create mode 100644 vendor/Ltac2/theories/Array.v create mode 100644 vendor/Ltac2/theories/Char.v create mode 100644 vendor/Ltac2/theories/Constr.v create mode 100644 vendor/Ltac2/theories/Control.v create mode 100644 vendor/Ltac2/theories/Env.v create mode 100644 vendor/Ltac2/theories/Fresh.v create mode 100644 vendor/Ltac2/theories/Ident.v create mode 100644 vendor/Ltac2/theories/Init.v create mode 100644 vendor/Ltac2/theories/Int.v create mode 100644 vendor/Ltac2/theories/Ltac1.v create mode 100644 vendor/Ltac2/theories/Ltac2.v create mode 100644 vendor/Ltac2/theories/Message.v create mode 100644 vendor/Ltac2/theories/Notations.v create mode 100644 vendor/Ltac2/theories/Pattern.v create mode 100644 vendor/Ltac2/theories/Std.v create mode 100644 vendor/Ltac2/theories/String.v create mode 100644 vendor/Ltac2/theories/dune diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 00e15f8daa..0000000000 --- a/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -Makefile.coq -Makefile.coq.conf -*.glob -*.d -*.d.raw -*.vio -*.vo -*.cm* -*.annot -*.spit -*.spot -*.o -*.a -*.aux -tests/*.log -*.install -_build -.merlin diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 2628abde45..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,40 +0,0 @@ -dist: trusty -sudo: required -language: generic - -services: - - docker - -env: - global: - - NJOBS="2" - - CONTRIB_NAME="ltac2" - matrix: - - COQ_IMAGE="coqorg/coq:dev" - -install: | - # Prepare the COQ container - docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/${CONTRIB_NAME} -w /home/coq/${CONTRIB_NAME} ${COQ_IMAGE} - docker exec COQ /bin/bash --login -c " - # This bash script is double-quoted to interpolate Travis CI env vars: - echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" - export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' - set -ex # -e = exit on failure; -x = trace for debug - # opam update -y - # opam install -y -j ${NJOBS} coq-mathcomp-ssreflect - opam config list - opam repo list - opam list - " -script: -- echo -e "${ANSI_YELLOW}Building ${CONTRIB_NAME}...${ANSI_RESET}" && echo -en 'travis_fold:start:script\\r' -- | - docker exec COQ /bin/bash --login -c " - export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' - set -ex - sudo chown -R coq:coq /home/coq/${CONTRIB_NAME} - make - make tests - " -- docker stop COQ # optional -- echo -en 'travis_fold:end:script\\r' diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 27950e8d20..0000000000 --- a/LICENSE +++ /dev/null @@ -1,458 +0,0 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 2.1, February 1999 - - Copyright (C) 1991, 1999 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the Lesser GPL. It also counts - as the successor of the GNU Library Public License, version 2, hence - the version number 2.1.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Lesser General Public License, applies to some -specially designated software packages--typically libraries--of the -Free Software Foundation and other authors who decide to use it. You -can use it too, but we suggest you first think carefully about whether -this license or the ordinary General Public License is the better -strategy to use in any particular case, based on the explanations below. - - When we speak of free software, we are referring to freedom of use, -not price. Our General Public Licenses are designed to make sure that -you have the freedom to distribute copies of free software (and charge -for this service if you wish); that you receive source code or can get -it if you want it; that you can change the software and use pieces of -it in new free programs; and that you are informed that you can do -these things. - - To protect your rights, we need to make restrictions that forbid -distributors to deny you these rights or to ask you to surrender these -rights. These restrictions translate to certain responsibilities for -you if you distribute copies of the library or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link other code with the library, you must provide -complete object files to the recipients, so that they can relink them -with the library after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - We protect your rights with a two-step method: (1) we copyright the -library, and (2) we offer you this license, which gives you legal -permission to copy, distribute and/or modify the library. - - To protect each distributor, we want to make it very clear that -there is no warranty for the free library. Also, if the library is -modified by someone else and passed on, the recipients should know -that what they have is not the original version, so that the original -author's reputation will not be affected by problems that might be -introduced by others. - - Finally, software patents pose a constant threat to the existence of -any free program. We wish to make sure that a company cannot -effectively restrict the users of a free program by obtaining a -restrictive license from a patent holder. Therefore, we insist that -any patent license obtained for a version of the library must be -consistent with the full freedom of use specified in this license. - - Most GNU software, including some libraries, is covered by the -ordinary GNU General Public License. This license, the GNU Lesser -General Public License, applies to certain designated libraries, and -is quite different from the ordinary General Public License. We use -this license for certain libraries in order to permit linking those -libraries into non-free programs. - - When a program is linked with a library, whether statically or using -a shared library, the combination of the two is legally speaking a -combined work, a derivative of the original library. The ordinary -General Public License therefore permits such linking only if the -entire combination fits its criteria of freedom. The Lesser General -Public License permits more lax criteria for linking other code with -the library. - - We call this license the "Lesser" General Public License because it -does Less to protect the user's freedom than the ordinary General -Public License. It also provides other free software developers Less -of an advantage over competing non-free programs. These disadvantages -are the reason we use the ordinary General Public License for many -libraries. However, the Lesser license provides advantages in certain -special circumstances. - - For example, on rare occasions, there may be a special need to -encourage the widest possible use of a certain library, so that it becomes -a de-facto standard. To achieve this, non-free programs must be -allowed to use the library. A more frequent case is that a free -library does the same job as widely used non-free libraries. In this -case, there is little to gain by limiting the free library to free -software only, so we use the Lesser General Public License. - - In other cases, permission to use a particular library in non-free -programs enables a greater number of people to use a large body of -free software. For example, permission to use the GNU C Library in -non-free programs enables many more people to use the whole GNU -operating system, as well as its variant, the GNU/Linux operating -system. - - Although the Lesser General Public License is Less protective of the -users' freedom, it does ensure that the user of a program that is -linked with the Library has the freedom and the wherewithal to run -that program using a modified version of the Library. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, whereas the latter must -be combined with the library in order to run. - - GNU LESSER GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). -Each licensee is addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also combine or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (1) uses at run time a - copy of the library already present on the user's computer system, - rather than copying library functions into the executable, and (2) - will operate properly with a modified version of the library, if - the user installs one, as long as the modified version is - interface-compatible with the version that the work was made with. - - c) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - d) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - e) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties with -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS diff --git a/Makefile b/Makefile deleted file mode 100644 index e0e197650d..0000000000 --- a/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -ifeq "$(COQBIN)" "" - COQBIN=$(dir $(shell which coqtop))/ -endif - -%: Makefile.coq - -Makefile.coq: _CoqProject - $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq - -tests: all - @$(MAKE) -C tests -s clean - @$(MAKE) -C tests -s all - --include Makefile.coq diff --git a/README.md b/README.md deleted file mode 100644 index d49dd88076..0000000000 --- a/README.md +++ /dev/null @@ -1,25 +0,0 @@ -[![Build Status](https://travis-ci.org/ppedrot/ltac2.svg?branch=master)](https://travis-ci.org/ppedrot/ltac2) - -Overview -======== - -This is a standalone version of the Ltac2 plugin. Ltac2 is an attempt at -providing the Coq users with a tactic language that is more robust and more -expressive than the venerable Ltac language. - -Status -======== - -It is mostly a toy to experiment for now, and the implementation is quite -bug-ridden. Don't mistake this for a final product! - -Installation -============ - -This should compile with Coq master, assuming the `COQBIN` variable is set -correctly. Standard procedures for `coq_makefile`-generated plugins apply. - -Demo -==== - -Horrible test-files are provided in the `tests` folder. Not for kids. diff --git a/_CoqProject b/_CoqProject deleted file mode 100644 index dda5a8001a..0000000000 --- a/_CoqProject +++ /dev/null @@ -1,51 +0,0 @@ --R theories/ Ltac2 --I src/ - -src/tac2dyn.ml -src/tac2dyn.mli -src/tac2expr.mli -src/tac2types.mli -src/tac2env.ml -src/tac2env.mli -src/tac2print.ml -src/tac2print.mli -src/tac2intern.ml -src/tac2intern.mli -src/tac2interp.ml -src/tac2interp.mli -src/tac2entries.ml -src/tac2entries.mli -src/tac2ffi.ml -src/tac2ffi.mli -src/tac2qexpr.mli -src/tac2quote.ml -src/tac2quote.mli -src/tac2match.ml -src/tac2match.mli -src/tac2core.ml -src/tac2core.mli -src/tac2extffi.ml -src/tac2extffi.mli -src/tac2tactics.ml -src/tac2tactics.mli -src/tac2stdlib.ml -src/tac2stdlib.mli -src/g_ltac2.mlg -src/ltac2_plugin.mlpack - -theories/Init.v -theories/Int.v -theories/Char.v -theories/String.v -theories/Ident.v -theories/Array.v -theories/Control.v -theories/Message.v -theories/Constr.v -theories/Pattern.v -theories/Fresh.v -theories/Std.v -theories/Env.v -theories/Notations.v -theories/Ltac1.v -theories/Ltac2.v diff --git a/doc/ltac2.md b/doc/ltac2.md deleted file mode 100644 index b217cb08e6..0000000000 --- a/doc/ltac2.md +++ /dev/null @@ -1,1036 +0,0 @@ -# Summary - -The Ltac tactic language is probably one of the ingredients of the success of -Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: - -- has nothing like intended semantics -- is very non-uniform due to organic growth -- lacks expressivity and requires programming-by-hacking -- is slow -- is error-prone and fragile -- has an intricate implementation - -This has a lot of terrible consequences, most notably the fact that it is never -clear whether some observed behaviour is a bug or a proper one. - -Following the need of users that start developing huge projects relying -critically on Ltac, we believe that we should offer a proper modern language -that features at least the following: - -- at least informal, predictable semantics -- a typing system -- standard programming facilities (i.e. datatypes) - -This document describes the implementation of such a language. The -implementation of Ltac as of Coq 8.7 will be referred to as Ltac1. - -# Contents - - -**Table of Contents** - -- [Summary](#summary) -- [Contents](#contents) -- [General design](#general-design) -- [ML component](#ml-component) - - [Overview](#overview) - - [Type Syntax](#type-syntax) - - [Type declarations](#type-declarations) - - [Term Syntax](#term-syntax) - - [Ltac Definitions](#ltac-definitions) - - [Reduction](#reduction) - - [Typing](#typing) - - [Effects](#effects) - - [Standard IO](#standard-io) - - [Fatal errors](#fatal-errors) - - [Backtrack](#backtrack) - - [Goals](#goals) -- [Meta-programming](#meta-programming) - - [Overview](#overview-1) - - [Generic Syntax for Quotations](#generic-syntax-for-quotations) - - [Built-in quotations](#built-in-quotations) - - [Strict vs. non-strict mode](#strict-vs-non-strict-mode) - - [Term Antiquotations](#term-antiquotations) - - [Syntax](#syntax) - - [Semantics](#semantics) - - [Static semantics](#static-semantics) - - [Dynamic semantics](#dynamic-semantics) - - [Trivial Term Antiquotations](#trivial-term-antiquotations) - - [Match over terms](#match-over-terms) - - [Match over goals](#match-over-goals) -- [Notations](#notations) - - [Scopes](#scopes) - - [Notations](#notations-1) - - [Abbreviations](#abbreviations) -- [Evaluation](#evaluation) -- [Debug](#debug) -- [Compatibility layer with Ltac1](#compatibility-layer-with-ltac1) - - [Ltac1 from Ltac2](#ltac1-from-ltac2) - - [Ltac2 from Ltac1](#ltac2-from-ltac1) -- [Transition from Ltac1](#transition-from-ltac1) - - [Syntax changes](#syntax-changes) - - [Tactic delay](#tactic-delay) - - [Variable binding](#variable-binding) - - [In Ltac expressions](#in-ltac-expressions) - - [In quotations](#in-quotations) - - [Exception catching](#exception-catching) -- [TODO](#todo) - - - - -# General design - -There are various alternatives to Ltac1, such that Mtac or Rtac for instance. -While those alternatives can be quite distinct from Ltac1, we designed -Ltac2 to be closest as reasonably possible to Ltac1, while fixing the -aforementioned defects. - -In particular, Ltac2 is: -- a member of the ML family of languages, i.e. - * a call-by-value functional language - * with effects - * together with Hindley-Milner type system -- a language featuring meta-programming facilities for the manipulation of - Coq-side terms -- a language featuring notation facilities to help writing palatable scripts - -We describe more in details each point in the remainder of this document. - -# ML component - -## Overview - -Ltac2 is a member of the ML family of languages, in the sense that it is an -effectful call-by-value functional language, with static typing à la -Hindley-Milner. It is commonly accepted that ML constitutes a sweet spot in PL -design, as it is relatively expressive while not being either too lax -(contrarily to dynamic typing) nor too strict (contrarily to say, dependent -types). - -The main goal of Ltac2 is to serve as a meta-language for Coq. As such, it -naturally fits in the ML lineage, just as the historical ML was designed as -the tactic language for the LCF prover. It can also be seen as a general-purpose -language, by simply forgetting about the Coq-specific features. - -Sticking to a standard ML type system can be considered somewhat weak for a -meta-language designed to manipulate Coq terms. In particular, there is no -way to statically guarantee that a Coq term resulting from an Ltac2 -computation will be well-typed. This is actually a design choice, motivated -by retro-compatibility with Ltac1. Instead, well-typedness is deferred to -dynamic checks, allowing many primitive functions to fail whenever they are -provided with an ill-typed term. - -The language is naturally effectful as it manipulates the global state of the -proof engine. This allows to think of proof-modifying primitives as effects -in a straightforward way. Semantically, proof manipulation lives in a monad, -which allows to ensure that Ltac2 satisfies the same equations as a generic ML -with unspecified effects would do, e.g. function reduction is substitution -by a value. - -## Type Syntax - -At the level of terms, we simply elaborate on Ltac1 syntax, which is quite -close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. - -``` -TYPE := -| "(" TYPE₀ "," ... "," TYPEₙ ")" TYPECONST -| "(" TYPE₀ "*" ... "*" TYPEₙ ")" -| TYPE₁ "->" TYPE₂ -| TYPEVAR - -TYPECONST := ( MODPATH "." )* LIDENT - -TYPEVAR := "'" LIDENT - -TYPEPARAMS := "(" TYPEVAR₀ "," ... "," TYPEVARₙ ")" -``` - -The set of base types can be extended thanks to the usual ML type -declarations such as algebraic datatypes and records. - -Built-in types include: -- `int`, machine integers (size not specified, in practice inherited from OCaml) -- `string`, mutable strings -- `'a array`, mutable arrays -- `exn`, exceptions -- `constr`, kernel-side terms -- `pattern`, term patterns -- `ident`, well-formed identifiers - -## Type declarations - -One can define new types by the following commands. - -``` -VERNAC ::= -| "Ltac2" "Type" TYPEPARAMS LIDENT -| "Ltac2" "Type" RECFLAG TYPEPARAMS LIDENT ":=" TYPEDEF - -RECFLAG := ( "rec" ) -``` - -The first command defines an abstract type. It has no use for the end user and -is dedicated to types representing data coming from the OCaml world. - -The second command defines a type with a manifest. There are four possible -kinds of such definitions: alias, variant, record and open variant types. - -``` -TYPEDEF := -| TYPE -| "[" CONSTRUCTORDEF₀ "|" ... "|" CONSTRUCTORDEFₙ "]" -| "{" FIELDDEF₀ ";" ... ";" FIELDDEFₙ "}" -| "[" ".." "]" - -CONSTRUCTORDEF := -| IDENT ( "(" TYPE₀ "," ... "," TYPE₀ ")" ) - -FIELDDEF := -| MUTFLAG IDENT ":" TYPE - -MUTFLAG := ( "mutable" ) -``` - -Aliases are just a name for a given type expression and are transparently -unfoldable to it. They cannot be recursive. - -Variants are sum types defined by constructors and eliminated by -pattern-matching. They can be recursive, but the `RECFLAG` must be explicitly -set. Pattern-maching must be exhaustive. - -Records are product types with named fields and eliminated by projection. -Likewise they can be recursive if the `RECFLAG` is set. - -Open variants are a special kind of variant types whose constructors are not -statically defined, but can instead be extended dynamically. A typical example -is the standard `exn` type. Pattern-matching must always include a catch-all -clause. They can be extended by the following command. - -``` -VERNAC ::= -| "Ltac2" "Type" TYPEPARAMS QUALID ":=" "[" CONSTRUCTORDEF "]" -``` - -## Term Syntax - -The syntax of the functional fragment is very close to the one of Ltac1, except -that it adds a true pattern-matching feature, as well as a few standard -constructions from ML. - -``` -VAR := LIDENT - -QUALID := ( MODPATH "." )* LIDENT - -CONSTRUCTOR := UIDENT - -TERM := -| QUALID -| CONSTRUCTOR TERM₀ ... TERMₙ -| TERM TERM₀ ... TERMₙ -| "fun" VAR "=>" TERM -| "let" VAR ":=" TERM "in" TERM -| "let" "rec" VAR ":=" TERM "in" TERM -| "match" TERM "with" BRANCH* "end" -| INT -| STRING -| "[|" TERM₀ ";" ... ";" TERMₙ "|]" -| "(" TERM₀ "," ... "," TERMₙ ")" -| "{" FIELD+ "}" -| TERM "." "(" QUALID ")" -| TERM₁ "." "(" QUALID ")" ":=" TERM₂ -| "["; TERM₀ ";" ... ";" TERMₙ "]" -| TERM₁ "::" TERM₂ -| ... - -BRANCH := -| PATTERN "=>" TERM - -PATTERN := -| VAR -| "_" -| "(" PATTERN₀ "," ... "," PATTERNₙ ")" -| CONSTRUCTOR PATTERN₀ ... PATTERNₙ -| "[" "]" -| PATTERN₁ "::" PATTERN₂ - -FIELD := -| QUALID ":=" TERM - -``` - -In practice, there is some additional syntactic sugar that allows e.g. to -bind a variable and match on it at the same time, in the usual ML style. - -There is a dedicated syntax for list and array litterals. - -Limitations: for now, deep pattern matching is not implemented yet. - -## Ltac Definitions - -One can define a new global Ltac2 value using the following syntax. -``` -VERNAC ::= -| "Ltac2" MUTFLAG RECFLAG LIDENT ":=" TERM -``` - -For semantic reasons, the body of the Ltac2 definition must be a syntactical -value, i.e. a function, a constant or a pure constructor recursively applied to -values. - -If the `RECFLAG` is set, the tactic is expanded into a recursive binding. - -If the `MUTFLAG` is set, the definition can be redefined at a later stage. This -can be performed through the following command. - -``` -VERNAC ::= -| "Ltac2" "Set" QUALID ":=" TERM -``` - -Mutable definitions act like dynamic binding, i.e. at runtime, the last defined -value for this entry is chosen. This is useful for global flags and the like. - -## Reduction - -We use the usual ML call-by-value reduction, with an otherwise unspecified -evaluation order. This is a design choice making it compatible with OCaml, -if ever we implement native compilation. The expected equations are as follows. -``` -(fun x => t) V ≡ t{x := V} (βv) - -let x := V in t ≡ t{x := V} (let) - -match C V₀ ... Vₙ with ... | C x₀ ... xₙ => t | ... end ≡ t {xᵢ := Vᵢ} (ι) - -(t any term, V values, C constructor) -``` - -Note that call-by-value reduction is already a departure from Ltac1 which uses -heuristics to decide when evaluating an expression. For instance, the following -expressions do not evaluate the same way in Ltac1. - -``` -foo (idtac; let x := 0 in bar) - -foo (let x := 0 in bar) -``` - -Instead of relying on the `idtac` hack, we would now require an explicit thunk -not to compute the argument, and `foo` would have e.g. type -`(unit -> unit) -> unit`. - -``` -foo (fun () => let x := 0 in bar) -``` - -## Typing - -Typing is strict and follows Hindley-Milner system. We will not implement the -current hackish subtyping semantics, and one will have to resort to conversion -functions. See notations though to make things more palatable. - -In this setting, all usual argument-free tactics have type `unit -> unit`, but -one can return as well a value of type `t` thanks to terms of type `unit -> t`, -or take additional arguments. - -## Effects - -Regarding effects, nothing involved here, except that instead of using the -standard IO monad as the ambient effectful world, Ltac2 is going to use the -tactic monad. - -Note that the order of evaluation of application is *not* specified and is -implementation-dependent, as in OCaml. - -We recall that the `Proofview.tactic` monad is essentially a IO monad together -with backtracking state representing the proof state. - -Intuitively a thunk of type `unit -> 'a` can do the following: -- It can perform non-backtracking IO like printing and setting mutable variables -- It can fail in a non-recoverable way -- It can use first-class backtrack. The proper way to figure that is that we - morally have the following isomorphism: - `(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a - lazy list of results where each tail is waiting for a continuation exception. -- It can access a backtracking proof state, made out amongst other things of - the current evar assignation and the list of goals under focus. - -We describe more thoroughly the various effects existing in Ltac2 hereafter. - -### Standard IO - -The Ltac2 language features non-backtracking IO, notably mutable data and -printing operations. - -Mutable fields of records can be modified using the set syntax. Likewise, -built-in types like `string` and `array` feature imperative assignment. See -modules `String` and `Array` respectively. - -A few printing primitives are provided in the `Message` module, allowing to -display information to the user. - -### Fatal errors - -The Ltac2 language provides non-backtracking exceptions through the -following primitive in module `Control`. - -``` -val throw : exn -> 'a -``` - -Contrarily to backtracking exceptions from the next section, this kind of error -is never caught by backtracking primitives, that is, throwing an exception -destroys the stack. This is materialized by the following equation, where `E` -is an evaluation context. - -``` -E[throw e] ≡ throw e - -(e value) -``` - -There is currently no way to catch such an exception and it is a design choice. -There might be at some future point a way to catch it in a brutal way, -destroying all backtrack and return values. - -### Backtrack - -In Ltac2, we have the following backtracking primitives, defined in the -`Control` module. - -``` -Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. - -val zero : exn -> 'a -val plus : (unit -> 'a) -> (exn -> 'a) -> 'a -val case : (unit -> 'a) -> ('a * (exn -> 'a)) result -``` - -If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is -list concatenation, while `case` is pattern-matching. - -The backtracking is first-class, i.e. one can write -`plus (fun () => "x") (fun _ => "y") : string` producing a backtracking string. - -These operations are expected to satisfy a few equations, most notably that they -form a monoid compatible with sequentialization. - -``` -plus t zero ≡ t () -plus (fun () => zero e) f ≡ f e -plus (plus t f) g ≡ plus t (fun e => plus (f e) g) - -case (fun () => zero e) ≡ Err e -case (fun () => plus (fun () => t) f) ≡ Val t f - -let x := zero e in u ≡ zero e -let x := plus t f in u ≡ plus (fun () => let x := t in u) (fun e => let x := f e in u) - -(t, u, f, g, e values) -``` - -### Goals - -A goal is given by the data of its conclusion and hypotheses, i.e. it can be -represented as `[Γ ⊢ A]`. - -The tactic monad naturally operates over the whole proofview, which may -represent several goals, including none. Thus, there is no such thing as -*the current goal*. Goals are naturally ordered, though. - -It is natural to do the same in Ltac2, but we must provide a way to get access -to a given goal. This is the role of the `enter` primitive, that applies a -tactic to each currently focused goal in turn. - -``` -val enter : (unit -> unit) -> unit -``` - -It is guaranteed that when evaluating `enter f`, `f` is called with exactly one -goal under focus. Note that `f` may be called several times, or never, depending -on the number of goals under focus before the call to `enter`. - -Accessing the goal data is then implicit in the Ltac2 primitives, and may panic -if the invariants are not respected. The two essential functions for observing -goals are given below. - -``` -val hyp : ident -> constr -val goal : unit -> constr -``` - -The two above functions panic if there is not exactly one goal under focus. -In addition, `hyp` may also fail if there is no hypothesis with the -corresponding name. - -# Meta-programming - -## Overview - -One of the horrendous implementation issues of Ltac is the fact that it is -never clear whether an object refers to the object world or the meta-world. -This is an incredible source of slowness, as the interpretation must be -aware of bound variables and must use heuristics to decide whether a variable -is a proper one or referring to something in the Ltac context. - -Likewise, in Ltac1, constr parsing is implicit, so that `foo 0` is -not `foo` applied to the Ltac integer expression `0` (Ltac does have a -non-first-class notion of integers), but rather the Coq term `Datatypes.O`. - -We should stop doing that! We need to mark when quoting and unquoting, although -we need to do that in a short and elegant way so as not to be too cumbersome -to the user. - -## Generic Syntax for Quotations - -In general, quotations can be introduced in term by the following syntax, where -`QUOTENTRY` is some parsing entry. -``` -TERM ::= -| QUOTNAME ":" "(" QUOTENTRY ")" - -QUOTNAME := IDENT -``` - -### Built-in quotations - -The current implementation recognizes the following built-in quotations: -- "ident", which parses identifiers (type `Init.ident`). -- "constr", which parses Coq terms and produces an-evar free term at runtime - (type `Init.constr`). -- "open_constr", which parses Coq terms and produces a term potentially with - holes at runtime (type `Init.constr` as well). -- "pattern", which parses Coq patterns and produces a pattern used for term - matching (type `Init.pattern`). -- "reference", which parses either a `QUALID` or `"&" IDENT`. Qualified names - are globalized at internalization into the corresponding global reference, - while `&id` is turned into `Std.VarRef id`. This produces at runtime a - `Std.reference`. - -The following syntactic sugar is provided for two common cases. -- `@id` is the same as ident:(id) -- `'t` is the same as open_constr:(t) - -### Strict vs. non-strict mode - -Depending on the context, quotations producing terms (i.e. `constr` or -`open_constr`) are not internalized in the same way. There are two possible -modes, respectively called the *strict* and the *non-strict* mode. - -- In strict mode, all simple identifiers appearing in a term quotation are -required to be resolvable statically. That is, they must be the short name of -a declaration which is defined globally, excluding section variables and -hypotheses. If this doesn't hold, internalization will fail. To work around -this error, one has to specifically use the `&` notation. -- In non-strict mode, any simple identifier appearing in a term quotation which -is not bound in the global context is turned into a dynamic reference to a -hypothesis. That is to say, internalization will succeed, but the evaluation -of the term at runtime will fail if there is no such variable in the dynamic -context. - -Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict -mode is only set when evaluating Ltac2 snippets in interactive proof mode. The -rationale is that it is cumbersome to explicitly add `&` interactively, while it -is expected that global tactics enforce more invariants on their code. - -## Term Antiquotations - -### Syntax - -One can also insert Ltac2 code into Coq term, similarly to what was possible in -Ltac1. - -``` -COQCONSTR ::= -| "ltac2" ":" "(" TERM ")" -``` - -Antiquoted terms are expected to have type `unit`, as they are only evaluated -for their side-effects. - -### Semantics - -Interpretation of a quoted Coq term is done in two phases, internalization and -evaluation. - -- Internalization is part of the static semantics, i.e. it is done at Ltac2 - typing time. -- Evaluation is part of the dynamic semantics, i.e. it is done when - a term gets effectively computed by Ltac2. - -Remark that typing of Coq terms is a *dynamic* process occuring at Ltac2 -evaluation time, and not at Ltac2 typing time. - -#### Static semantics - -During internalization, Coq variables are resolved and antiquotations are -type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq -implementation terminology. Note that although it went through the -type-checking of **Ltac2**, the resulting term has not been fully computed and -is potentially ill-typed as a runtime **Coq** term. - -``` -Ltac2 Definition myconstr () := constr:(nat -> 0). -// Valid with type `unit -> constr`, but will fail at runtime. -``` - -Term antiquotations are type-checked in the enclosing Ltac2 typing context -of the corresponding term expression. For instance, the following will -type-check. - -``` -let x := '0 in constr:(1 + ltac2:(exact x)) -// type constr -``` - -Beware that the typing environment of typing of antiquotations is **not** -expanded by the Coq binders from the term. Namely, it means that the following -Ltac2 expression will **not** type-check. -``` -constr:(fun x : nat => ltac2:(exact x)) -// Error: Unbound variable 'x' -``` - -There is a simple reason for that, which is that the following expression would -not make sense in general. -``` -constr:(fun x : nat => ltac2:(clear @x; exact x)) -``` -Indeed, a hypothesis can suddenly disappear from the runtime context if some -other tactic pulls the rug from under you. - -Rather, the tactic writer has to resort to the **dynamic** goal environment, -and must write instead explicitly that she is accessing a hypothesis, typically -as follows. -``` -constr:(fun x : nat => ltac2:(exact (hyp @x))) -``` - -This pattern is so common that we provide dedicated Ltac2 and Coq term notations -for it. - -- `&x` as an Ltac2 expression expands to `hyp @x`. -- `&x` as a Coq constr expression expands to - `ltac2:(Control.refine (fun () => hyp @x))`. - -#### Dynamic semantics - -During evaluation, a quoted term is fully evaluated to a kernel term, and is -in particular type-checked in the current environment. - -Evaluation of a quoted term goes as follows. -- The quoted term is first evaluated by the pretyper. -- Antiquotations are then evaluated in a context where there is exactly one goal -under focus, with the hypotheses coming from the current environment extended -with the bound variables of the term, and the resulting term is fed into the -quoted term. - -Relative orders of evaluation of antiquotations and quoted term are not -specified. - -For instance, in the following example, `tac` will be evaluated in a context -with exactly one goal under focus, whose last hypothesis is `H : nat`. The -whole expression will thus evaluate to the term `fun H : nat => nat`. -``` -let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ())) -``` - -Many standard tactics perform type-checking of their argument before going -further. It is your duty to ensure that terms are well-typed when calling -such tactics. Failure to do so will result in non-recoverable exceptions. - -## Trivial Term Antiquotations - -It is possible to refer to a variable of type `constr` in the Ltac2 environment -through a specific syntax consistent with the antiquotations presented in -the notation section. - -``` -COQCONSTR ::= -| "$" LIDENT -``` - -In a Coq term, writing `$x` is semantically equivalent to -`ltac2:(Control.refine (fun () => x))`, up to re-typechecking. It allows to -insert in a concise way an Ltac2 variable of type `constr` into a Coq term. - -## Match over terms - -Ltac2 features a construction similar to Ltac1 `match` over terms, although -in a less hard-wired way. - -``` -TERM ::= -| "match!" TERM "with" CONSTR-MATCHING* "end" -| "lazy_match!" TERM "with" CONSTR-MATCHING* "end" -| "multi_match!" TERM "with" CONSTR-MATCHING*"end" - -CONSTR-MATCHING := -| "|" CONSTR-PATTERN "=>" TERM - -CONSTR-PATTERN := -| CONSTR -| "context" LIDENT? "[" CONSTR "]" -``` - -This construction is not primitive and is desugared at parsing time into -calls to term matching functions from the `Pattern` module. Internally, it is -implemented thanks to a specific scope accepting the `CONSTR-MATCHING` syntax. - -Variables from the `CONSTR-PATTERN` are statically bound in the body of the branch, to -values of type `constr` for the variables from the `CONSTR` pattern and to a -value of type `Pattern.context` for the variable `LIDENT`. - -Note that contrarily to Ltac, only lowercase identifiers are valid as Ltac2 -bindings, so that there will be a syntax error if one of the bound variables -starts with an uppercase character. - -The semantics of this construction is otherwise the same as the corresponding -one from Ltac1, except that it requires the goal to be focused. - -## Match over goals - -Similarly, there is a way to match over goals in an elegant way, which is -just a notation desugared at parsing time. - -``` -TERM ::= -| "match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" -| "lazy_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" -| "multi_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING*"end" - -GOAL-MATCHING := -| "|" "[" HYP-MATCHING* "|-" CONSTR-PATTERN "]" "=>" TERM - -HYP-MATCHING := -| LIDENT ":" CONSTR-PATTERN - -MATCH-ORDER := -| "reverse" -``` - -Variables from `HYP-MATCHING` and `CONSTR-PATTERN` are bound in the body of the -branch. Their types are: -- `constr` for pattern variables appearing in a `CONSTR` -- `Pattern.context` for variables binding a context -- `ident` for variables binding a hypothesis name. - -The same identifier caveat as in the case of matching over constr applies, and -this features has the same semantics as in Ltac1. In particular, a `reverse` -flag can be specified to match hypotheses from the more recently introduced to -the least recently introduced one. - -# Notations - -Notations are the crux of the usability of Ltac1. We should be able to recover -a feeling similar to the old implementation by using and abusing notations. - -## Scopes - -A scope is a name given to a grammar entry used to produce some Ltac2 expression -at parsing time. Scopes are described using a form of S-expression. - -``` -SCOPE := -| STRING -| INT -| LIDENT ( "(" SCOPE₀ "," ... "," SCOPEₙ ")" ) -``` - -A few scopes contain antiquotation features. For sake of uniformity, all -antiquotations are introduced by the syntax `"$" VAR`. - -The following scopes are built-in. -- constr: - + parses `c = COQCONSTR` and produces `constr:(c)` -- ident: - + parses `id = IDENT` and produces `ident:(id)` - + parses `"$" (x = IDENT)` and produces the variable `x` -- list0(*scope*): - + if *scope* parses `ENTRY`, parses ̀`(x₀, ..., xₙ = ENTRY*)` and produces - `[x₀; ...; xₙ]`. -- list0(*scope*, sep = STRING): - + if *scope* parses `ENTRY`, parses `(x₀ = ENTRY, "sep", ..., "sep", xₙ = ENTRY)` - and produces `[x₀; ...; xₙ]`. -- list1: same as list0 (with or without separator) but parses `ENTRY+` instead - of `ENTRY*`. -- opt(*scope*) - + if *scope* parses `ENTRY`, parses `ENTRY?` and produces either `None` or - `Some x` where `x` is the parsed expression. -- self: - + parses a Ltac2 expression at the current level and return it as is. -- next: - + parses a Ltac2 expression at the next level and return it as is. -- tactic(n = INT): - + parses a Ltac2 expression at the provided level *n* and return it as is. -- thunk(*scope*): - + parses the same as *scope*, and if *e* is the parsed expression, returns - `fun () => e`. -- STRING: - + parses the corresponding string as a CAMLP5 IDENT and returns `()`. -- keyword(s = STRING): - + parses the string *s* as a keyword and returns `()`. -- terminal(s = STRING): - + parses the string *s* as a keyword, if it is already a - keyword, otherwise as an IDENT. Returns `()`. -- seq(*scope₁*, ..., *scopeₙ*): - + parses *scope₁*, ..., *scopeₙ* in this order, and produces a tuple made - out of the parsed values in the same order. As an optimization, all - subscopes of the form STRING are left out of the returned tuple, instead - of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using self of next. - -A few other specific scopes exist to handle Ltac1-like syntax, but their use is -discouraged and they are thus not documented. - -For now there is no way to declare new scopes from Ltac2 side, but this is -planned. - -## Notations - -The Ltac2 parser can be extended by syntactic notations. -``` -VERNAC ::= -| "Ltac2" "Notation" TOKEN+ LEVEL? ":=" TERM - -LEVEL := ":" INT - -TOKEN := -| VAR "(" SCOPE ")" -| STRING -``` - -A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded -to the provided body where every token from the notation is let-bound to the -corresponding generated expression. - -For instance, assume we perform: -``` -Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. -``` -Then the following expression -``` -let y := @X in foo (nat -> nat) x $y -``` -will expand at parsing time to -``` -let y := @X in -let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids -``` - -Beware that the order of evaluation of multiple let-bindings is not specified, -so that you may have to resort to thunking to ensure that side-effects are -performed at the right time. - -## Abbreviations - -There exists a special kind of notations, called abbreviations, that is designed -so that it does not add any parsing rules. It is similar in spirit to Coq -abbreviations, insofar as its main purpose is to give an absolute name to a -piece of pure syntax, which can be transparently referred by this name as if it -were a proper definition. Abbreviations are introduced by the following -syntax. - -``` -VERNAC ::= -| "Ltac2" "Notation" IDENT ":=" TERM -``` - -The abbreviation can then be manipulated just as a normal Ltac2 definition, -except that it is expanded at internalization time into the given expression. -Furthermore, in order to make this kind of construction useful in practice in -an effectful language such as Ltac2, any syntactic argument to an abbreviation -is thunked on-the-fly during its expansion. - -For instance, suppose that we define the following. -``` -Ltac2 Notation foo := fun x => x (). -``` -Then we have the following expansion at internalization time. -``` -foo 0 ↦ (fun x => x ()) (fun _ => 0) -``` - -Note that abbreviations are not typechecked at all, and may result in typing -errors after expansion. - -# Evaluation - -Ltac2 features a toplevel loop that can be used to evaluate expressions. - -``` -VERNAC ::= -| "Ltac2" "Eval" TERM -``` - -This command evaluates the term in the current proof if there is one, or in the -global environment otherwise, and displays the resulting value to the user -together with its type. This function is pure in the sense that it does not -modify the state of the proof, and in particular all side-effects are discarded. - -# Debug - -When the option `Ltac2 Backtrace` is set, toplevel failures will be printed with -a backtrace. - -# Compatibility layer with Ltac1 - -## Ltac1 from Ltac2 - -### Simple API - -One can call Ltac1 code from Ltac2 by using the `ltac1` quotation. It parses -a Ltac1 expression, and semantics of this quotation is the evaluation of the -corresponding code for its side effects. In particular, in cannot return values, -and the quotation has type `unit`. - -Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited -to the use of standalone function calls. - -### Low-level API - -There exists a lower-level FFI into Ltac1 that is not recommended for daily use, -which is available in the `Ltac2.Ltac1` module. This API allows to directly -manipulate dynamically-typed Ltac1 values, either through the function calls, -or using the `ltac1val` quotation. The latter parses the same as `ltac1`, but -has type `Ltac2.Ltac1.t` instead of `unit`, and dynamically behaves as an Ltac1 -thunk, i.e. `ltac1val:(foo)` corresponds to the tactic closure that Ltac1 -would generate from `idtac; foo`. - -Due to intricate dynamic semantics, understanding when Ltac1 value quotations -focus is very hard. This is why some functions return a continuation-passing -style value, as it can dispatch dynamically between focused and unfocused -behaviour. - -## Ltac2 from Ltac1 - -Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation -instead. - -Note that the tactic expression is evaluated eagerly, if one wants to use it as -an argument to a Ltac1 function, she has to resort to the good old -`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately -and won't print anything. - -``` -Ltac mytac tac := idtac "wow"; tac. - -Goal True. -Proof. -mytac ltac2:(fail). -``` - -# Transition from Ltac1 - -Owing to the use of a bunch of notations, the transition shouldn't be -atrociously horrible and shockingly painful up to the point you want to retire -in the Ariège mountains, living off the land and insulting careless bypassers in -proto-georgian. - -That said, we do *not* guarantee you it is going to be a blissful walk either. -Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq -will help you. - -We list the major changes and the transition strategies hereafter. - -## Syntax changes - -Due to conflicts, a few syntactic rules have changed. - -- The dispatch tactical `tac; [foo|bar]` is now written `tac > [foo|bar]`. -- Levels of a few operators have been revised. Some tacticals now parse as if - they were a normal function, i.e. one has to put parentheses around the - argument when it is complex, e.g an abstraction. List of affected tacticals: - `try`, `repeat`, `do`, `once`, `progress`, `time`, `abstract`. -- `idtac` is no more. Either use `()` if you expect nothing to happen, - `(fun () => ())` if you want a thunk (see next section), or use printing - primitives from the `Message` module if you want to display something. - -## Tactic delay - -Tactics are not magically delayed anymore, neither as functions nor as -arguments. It is your responsibility to thunk them beforehand and apply them -at the call site. - -A typical example of a delayed function: -``` -Ltac foo := blah. -``` -becomes -``` -Ltac2 foo () := blah. -``` - -All subsequent calls to `foo` must be applied to perform the same effect as -before. - -Likewise, for arguments: -``` -Ltac bar tac := tac; tac; tac. -``` -becomes -``` -Ltac2 bar tac := tac (); tac (); tac (). -``` - -We recommend the use of syntactic notations to ease the transition. For -instance, the first example can alternatively written as: -``` -Ltac2 foo0 () := blah. -Ltac2 Notation foo := foo0 (). -``` - -This allows to keep the subsequent calls to the tactic as-is, as the -expression `foo` will be implicitly expanded everywhere into `foo0 ()`. Such -a trick also works for arguments, as arguments of syntactic notations are -implicitly thunked. The second example could thus be written as follows. - -``` -Ltac2 bar0 tac := tac (); tac (); tac (). -Ltac2 Notation bar := bar0. -``` - -## Variable binding - -Ltac1 relies on a crazy amount of dynamic trickery to be able to tell apart -bound variables from terms, hypotheses and whatnot. There is no such thing in -Ltac2, as variables are recognized statically and other constructions do not -live in the same syntactic world. Due to the abuse of quotations, it can -sometimes be complicated to know what a mere identifier represents in a tactic -expression. We recommend tracking the context and letting the compiler spit -typing errors to understand what is going on. - -We list below the typical changes one has to perform depending on the static -errors produced by the typechecker. - -### In Ltac expressions - -- `Unbound value X`, `Unbound constructor X`: - * if `X` is meant to be a term from the current stactic environment, replace - the problematic use by `'X`. - * if `X` is meant to be a hypothesis from the goal context, replace the - problematic use by `&X`. - -### In quotations - -- `The reference X was not found in the current environment`: - * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, - replace the problematic use by `$X`. - * if `X` is meant to be a hypothesis from the goal context, replace the - problematic use by `&X`. - -## Exception catching - -Ltac2 features a proper exception-catching mechanism. For this reason, the -Ltac1 mechanism relying on `fail` taking integers and tacticals decreasing it -has been removed. Now exceptions are preserved by all tacticals, and it is -your duty to catch it and reraise it depending on your use. - -# TODO - -- Implement deep pattern-matching. -- Craft an expressive set of primitive functions -- Implement native compilation to OCaml diff --git a/dune b/dune deleted file mode 100644 index 5dbc4db66a..0000000000 --- a/dune +++ /dev/null @@ -1,3 +0,0 @@ -(env - (dev (flags :standard -rectypes)) - (release (flags :standard -rectypes))) diff --git a/dune-project b/dune-project deleted file mode 100644 index 8154e999de..0000000000 --- a/dune-project +++ /dev/null @@ -1,3 +0,0 @@ -(lang dune 1.6) -(using coq 0.1) -(name ltac2) diff --git a/ltac2.opam b/ltac2.opam deleted file mode 100644 index 47ceb882b1..0000000000 --- a/ltac2.opam +++ /dev/null @@ -1,18 +0,0 @@ -synopsis: "A Tactic Language for Coq." -description: "A Tactic Language for Coq." -name: "coq-ltac2" -opam-version: "2.0" -maintainer: "Pierre-Marie Pédrot " -authors: "Pierre-Marie Pédrot " -homepage: "https://github.com/ppedrot/ltac2" -dev-repo: "https://github.com/ppedrot/ltac2.git" -bug-reports: "https://github.com/ppedrot/ltac2/issues" -license: "LGPL 2.1" -doc: "https://ppedrot.github.io/ltac2/doc" - -depends: [ - "coq" { = "dev" } - "dune" { build & >= "1.9.0" } -] - -build: [ "dune" "build" "-p" name "-j" jobs ] diff --git a/src/dune b/src/dune deleted file mode 100644 index 332f3644b0..0000000000 --- a/src/dune +++ /dev/null @@ -1,11 +0,0 @@ -(library - (name ltac2_plugin) - (public_name ltac2.plugin) - (modules_without_implementation tac2expr tac2qexpr tac2types) - (flags :standard -warn-error -9-27-50) - (libraries coq.plugins.firstorder)) - -(rule - (targets g_ltac2.ml) - (deps (:mlg-file g_ltac2.mlg)) - (action (run coqpp %{mlg-file}))) diff --git a/src/g_ltac2.mlg b/src/g_ltac2.mlg deleted file mode 100644 index 0071dbb088..0000000000 --- a/src/g_ltac2.mlg +++ /dev/null @@ -1,933 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tok.t Stream.t -> int option - -let entry_of_lookahead s (lk : lookahead) = - let run strm = match lk 0 strm with None -> err () | Some _ -> () in - Pcoq.Entry.of_parser s run - -let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> None -| Some n -> lk2 n strm - -let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> lk2 n strm -| Some n -> Some n - -let lk_kw kw n strm = match stream_nth n strm with -| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None -| _ -> None - -let lk_ident n strm = match stream_nth n strm with -| IDENT _ -> Some (n + 1) -| _ -> None - -let lk_int n strm = match stream_nth n strm with -| NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) -| _ -> None - -let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) - -(* lookahead for (x:=t), (?x:=t) and (1:=t) *) -let test_lpar_idnum_coloneq = - entry_of_lookahead "test_lpar_idnum_coloneq" begin - lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" - end - -(* lookahead for (x:t), (?x:t) *) -let test_lpar_id_colon = - entry_of_lookahead "test_lpar_id_colon" begin - lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" - end - -(* Hack to recognize "(x := t)" and "($x := t)" *) -let test_lpar_id_coloneq = - entry_of_lookahead "test_lpar_id_coloneq" begin - lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" - end - -(* Hack to recognize "(x)" *) -let test_lpar_id_rpar = - entry_of_lookahead "test_lpar_id_rpar" begin - lk_kw "(" >> lk_ident >> lk_kw ")" - end - -let test_ampersand_ident = - entry_of_lookahead "test_ampersand_ident" begin - lk_kw "&" >> lk_ident - end - -let test_dollar_ident = - entry_of_lookahead "test_dollar_ident" begin - lk_kw "$" >> lk_ident - end - -let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Entry.create "tactic:tac2type" -let tac2def_val = Entry.create "tactic:tac2def_val" -let tac2def_typ = Entry.create "tactic:tac2def_typ" -let tac2def_ext = Entry.create "tactic:tac2def_ext" -let tac2def_syn = Entry.create "tactic:tac2def_syn" -let tac2def_mut = Entry.create "tactic:tac2def_mut" -let tac2def_run = Entry.create "tactic:tac2def_run" -let tac2mode = Entry.create "vernac:ltac2_command" - -let ltac1_expr = Pltac.tactic_expr - -let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) -let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c -let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c -let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c -let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e -let inj_ltac1val loc e = inj_wit Tac2quote.wit_ltac1val loc e - -let pattern_of_qualid qid = - if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) - else - let open Libnames in - if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) - else - CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") - -} - -GRAMMAR EXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut tac2def_run; - tac2pat: - [ "1" LEFTA - [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { - if Tac2env.is_constructor qid then - CAst.make ~loc @@ CPatRef (RelId qid, pl) - else - CErrors.user_err ~loc (Pp.str "Syntax error") } - | qid = Prim.qualid -> { pattern_of_qualid qid } - | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } - | p1 = tac2pat; "::"; p2 = tac2pat -> - { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])} - ] - | "0" - [ "_" -> { CAst.make ~loc @@ CPatVar Anonymous } - | "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } - | qid = Prim.qualid -> { pattern_of_qualid qid } - | "("; p = atomic_tac2pat; ")" -> { p } - ] ] - ; - atomic_tac2pat: - [ [ -> - { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } - | p = tac2pat; ":"; t = tac2type -> - { CAst.make ~loc @@ CPatCnv (p, t) } - | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> - { let pl = p :: pl in - CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) } - | p = tac2pat -> { p } - ] ] - ; - tac2expr: - [ "6" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] - | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> - { CAst.make ~loc @@ CTacFun (it, body) } - | "let"; isrec = rec_flag; - lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "6" -> - { CAst.make ~loc @@ CTacLet (isrec, lc, e) } - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> - { CAst.make ~loc @@ CTacCse (e, bl) } - ] - | "4" LEFTA [ ] - | "::" RIGHTA - [ e1 = tac2expr; "::"; e2 = tac2expr -> - { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } - ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> - { let el = e0 :: el in - CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] - | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> - { CAst.make ~loc @@ CTacApp (e, el) } - | e = SELF; ".("; qid = Prim.qualid; ")" -> - { CAst.make ~loc @@ CTacPrj (e, RelId qid) } - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> - { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] - | "0" - [ "("; a = SELF; ")" -> { a } - | "("; a = SELF; ":"; t = tac2type; ")" -> - { CAst.make ~loc @@ CTacCnv (a, t) } - | "()" -> - { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } - | "("; ")" -> - { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } - | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> - { Tac2quote.of_list ~loc (fun x -> x) a } - | "{"; a = tac2rec_fieldexprs; "}" -> - { CAst.make ~loc @@ CTacRec a } - | a = tactic_atom -> { a } ] - ] - ; - branches: - [ [ -> { [] } - | "|"; bl = LIST1 branch SEP "|" -> { bl } - | bl = LIST1 branch SEP "|" -> { bl } ] - ] - ; - branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] - ; - rec_flag: - [ [ IDENT "rec" -> { true } - | -> { false } ] ] - ; - mut_flag: - [ [ IDENT "mutable" -> { true } - | -> { false } ] ] - ; - typ_param: - [ [ "'"; id = Prim.ident -> { id } ] ] - ; - tactic_atom: - [ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) } - | s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) } - | qid = Prim.qualid -> - { if Tac2env.is_constructor qid then - CAst.make ~loc @@ CTacCst (RelId qid) - else - CAst.make ~loc @@ CTacRef (RelId qid) } - | "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) } - | "&"; id = lident -> { Tac2quote.of_hyp ~loc id } - | "'"; c = Constr.constr -> { inj_open_constr loc c } - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } - | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } - | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } - | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } - | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } - | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1val loc qid } - ] ] - ; - let_clause: - [ [ binder = let_binder; ":="; te = tac2expr -> - { let (pat, fn) = binder in - let te = match fn with - | None -> te - | Some args -> CAst.make ~loc @@ CTacFun (args, te) - in - (pat, te) } - ] ] - ; - let_binder: - [ [ pats = LIST1 input_fun -> - { match pats with - | [{CAst.v=CPatVar _} as pat] -> (pat, None) - | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) - | [pat] -> (pat, None) - | _ -> CErrors.user_err ~loc (str "Invalid pattern") } - ] ] - ; - tac2type: - [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] - | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> - { let tl = t :: tl in - CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] - | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] - | "0" - [ "("; t = tac2type LEVEL "5"; ")" -> { t } - | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } - | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } - | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } - | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] - ]; - locident: - [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] - ; - binder: - [ [ "_" -> { CAst.make ~loc Anonymous } - | l = Prim.ident -> { CAst.make ~loc (Name l) } ] ] - ; - input_fun: - [ [ b = tac2pat LEVEL "0" -> { b } ] ] - ; - tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> - { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in - (name, e) } - ] ] - ; - tac2def_val: - [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> - { StrVal (mut, isrec, l) } - ] ] - ; - tac2def_mut: - [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] - ; - tac2def_run: - [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] - ; - tac2typ_knd: - [ [ t = tac2type -> { CTydDef (Some t) } - | "["; ".."; "]" -> { CTydOpn } - | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } - | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] - ; - tac2alg_constructors: - [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs } - | cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ] - ; - tac2alg_constructor: - [ [ c = Prim.ident -> { (c, []) } - | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] - ; - tac2rec_fields: - [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } - | f = tac2rec_field; ";" -> { [f] } - | f = tac2rec_field -> { [f] } - | -> { [] } ] ] - ; - tac2rec_field: - [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] - ; - tac2rec_fieldexprs: - [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } - | f = tac2rec_fieldexpr; ";" -> { [f] } - | f = tac2rec_fieldexpr-> { [f] } - | -> { [] } ] ] - ; - tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] - ; - tac2typ_prm: - [ [ -> { [] } - | id = typ_param -> { [CAst.make ~loc id] } - | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } - ] ] - ; - tac2typ_def: - [ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ] - ; - tac2type_body: - [ [ -> { false, CTydDef None } - | ":="; e = tac2typ_knd -> { false, e } - | "::="; e = tac2typ_knd -> { true, e } - ] ] - ; - tac2def_typ: - [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> - { StrTyp (isrec, l) } - ] ] - ; - tac2def_ext: - [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; - plugin = Prim.string; name = Prim.string -> - { let ml = { mltac_plugin = plugin; mltac_tactic = name } in - StrPrm (id, t, ml) } - ] ] - ; - syn_node: - [ [ "_" -> { CAst.make ~loc None } - | id = Prim.ident -> { CAst.make ~loc (Some id) } - ] ] - ; - sexpr: - [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } - | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } - | id = syn_node -> { SexprRec (loc, id, []) } - | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> - { SexprRec (loc, id, tok) } - ] ] - ; - syn_level: - [ [ -> { None } - | ":"; n = Prim.integer -> { Some n } - ] ] - ; - tac2def_syn: - [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; - e = tac2expr -> - { StrSyn (toks, n, e) } - ] ] - ; - lident: - [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] - ; - globref: - [ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) } - | qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid } - ] ] - ; -END - -(* Quotation scopes used by notations *) - -{ - -open Tac2entries.Pltac - -let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) - -} - -GRAMMAR EXTEND Gram - GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_destruction_arg q_reference q_with_bindings q_constr_matching - q_goal_matching q_hintdb q_move_location q_pose q_assert; - anti: - [ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ] - ; - ident_or_anti: - [ [ id = lident -> { QExpr id } - | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } - ] ] - ; - lident: - [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] - ; - lnatural: - [ [ n = Prim.natural -> { CAst.make ~loc n } ] ] - ; - q_ident: - [ [ id = ident_or_anti -> { id } ] ] - ; - qhyp: - [ [ x = anti -> { x } - | n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) } - | id = lident -> { QExpr (CAst.make ~loc @@ QNamedHyp id) } - ] ] - ; - simple_binding: - [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> - { CAst.make ~loc (h, c) } - ] ] - ; - bindings: - [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - { CAst.make ~loc @@ QExplicitBindings bl } - | bl = LIST1 Constr.constr -> - { CAst.make ~loc @@ QImplicitBindings bl } - ] ] - ; - q_bindings: - [ [ bl = bindings -> { bl } ] ] - ; - q_with_bindings: - [ [ bl = with_bindings -> { bl } ] ] - ; - intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ] - ; -(* ne_intropatterns: *) -(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) -(* ; *) - or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc } - | "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) } - | "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) } - | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> - { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) } - | "("; si = simple_intropattern; "&"; - tc = LIST1 simple_intropattern SEP "&" ; ")" -> - (* (A & B & C) is translated into (A,(B,C)) *) - { let rec pairify = function - | ([]|[_]|[_;_]) as l -> CAst.make ~loc l - | t::q -> - let q = - CAst.make ~loc @@ - QIntroAction (CAst.make ~loc @@ - QIntroOrAndPattern (CAst.make ~loc @@ - QIntroAndPattern (pairify q))) - in - CAst.make ~loc [t; q] - in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ] - ; - equality_intropattern: - [ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true } - | "<-" -> { CAst.make ~loc @@ QIntroRewrite false } - | "[="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ] - ; - naming_intropattern: - [ [ LEFTQMARK; id = lident -> - { CAst.make ~loc @@ QIntroFresh (QExpr id) } - | "?$"; id = lident -> - { CAst.make ~loc @@ QIntroFresh (QAnti id) } - | "?" -> - { CAst.make ~loc @@ QIntroAnonymous } - | id = ident_or_anti -> - { CAst.make ~loc @@ QIntroIdentifier id } - ] ] - ; - nonsimple_intropattern: - [ [ l = simple_intropattern -> { l } - | "*" -> { CAst.make ~loc @@ QIntroForthcoming true } - | "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ] - ; - simple_intropattern: - [ [ pat = simple_intropattern_closed -> -(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) - (** TODO: handle %pat *) - { pat } - ] ] - ; - simple_intropattern_closed: - [ [ pat = or_and_intropattern -> - { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) } - | pat = equality_intropattern -> - { CAst.make ~loc @@ QIntroAction pat } - | "_" -> - { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) } - | pat = naming_intropattern -> - { CAst.make ~loc @@ QIntroNaming pat } - ] ] - ; - q_intropatterns: - [ [ ipat = intropatterns -> { ipat } ] ] - ; - q_intropattern: - [ [ ipat = simple_intropattern -> { ipat } ] ] - ; - nat_or_anti: - [ [ n = lnatural -> { QExpr n } - | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } - ] ] - ; - eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat } - | -> { None } - ] ] - ; - with_bindings: - [ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ] - ; - constr_with_bindings: - [ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ] - ; - destruction_arg: - [ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n } - | id = lident -> { CAst.make ~loc @@ QElimOnIdent id } - | c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c } - ] ] - ; - q_destruction_arg: - [ [ arg = destruction_arg -> { arg } ] ] - ; - as_or_and_ipat: - [ [ "as"; ipat = or_and_intropattern -> { Some ipat } - | -> { None } - ] ] - ; - occs_nums: - [ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl } - | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> - { CAst.make ~loc @@ QAllOccurrencesBut (n::nl) } - ] ] - ; - occs: - [ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ] - ; - hypident: - [ [ id = ident_or_anti -> - { id,Locus.InHyp } - | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> - { id,Locus.InHypTypeOnly } - | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> - { id,Locus.InHypValueOnly } - ] ] - ; - hypident_occ: - [ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ] - ; - in_clause: - [ [ "*"; occs=occs -> - { { q_onhyps = None; q_concl_occs = occs } } - | "*"; "|-"; occs = concl_occ -> - { { q_onhyps = None; q_concl_occs = occs } } - | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> - { { q_onhyps = Some hl; q_concl_occs = occs } } - | hl = LIST0 hypident_occ SEP "," -> - { { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } } - ] ] - ; - clause: - [ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl } - | "at"; occs = occs_nums -> - { CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } } - ] ] - ; - q_clause: - [ [ cl = clause -> { cl } ] ] - ; - concl_occ: - [ [ "*"; occs = occs -> { occs } - | -> { CAst.make ~loc QNoOccurrences } - ] ] - ; - induction_clause: - [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = OPT clause -> - { CAst.make ~loc @@ { - indcl_arg = c; - indcl_eqn = eq; - indcl_as = pat; - indcl_in = cl; - } } - ] ] - ; - q_induction_clause: - [ [ cl = induction_clause -> { cl } ] ] - ; - conversion: - [ [ c = Constr.constr -> - { CAst.make ~loc @@ QConvert c } - | c1 = Constr.constr; "with"; c2 = Constr.constr -> - { CAst.make ~loc @@ QConvertWith (c1, c2) } - ] ] - ; - q_conversion: - [ [ c = conversion -> { c } ] ] - ; - orient: - [ [ "->" -> { CAst.make ~loc (Some true) } - | "<-" -> { CAst.make ~loc (Some false) } - | -> { CAst.make ~loc None } - ]] - ; - rewriter: - [ [ "!"; c = constr_with_bindings -> - { (CAst.make ~loc @@ QRepeatPlus,c) } - | [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> - { (CAst.make ~loc @@ QRepeatStar,c) } - | n = lnatural; "!"; c = constr_with_bindings -> - { (CAst.make ~loc @@ QPrecisely n,c) } - | n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> - { (CAst.make ~loc @@ QUpTo n,c) } - | n = lnatural; c = constr_with_bindings -> - { (CAst.make ~loc @@ QPrecisely n,c) } - | c = constr_with_bindings -> - { (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) } - ] ] - ; - oriented_rewriter: - [ [ b = orient; r = rewriter -> - { let (m, c) = r in - CAst.make ~loc @@ { - rew_orient = b; - rew_repeat = m; - rew_equatn = c; - } } - ] ] - ; - q_rewriting: - [ [ r = oriented_rewriter -> { r } ] ] - ; - tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } - | -> { [] } - ] ] - ; - tactic_then_gen: - [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } - | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } - | ".."; l = tactic_then_last -> { ([], Some (None, l)) } - | ta = tac2expr -> { ([Some ta], None) } - | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } - | -> { ([None], None) } - ] ] - ; - q_dispatch: - [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] - ; - q_occurrences: - [ [ occs = occs -> { occs } ] ] - ; - red_flag: - [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } - | IDENT "iota" -> { CAst.make ~loc @@ QIota } - | IDENT "match" -> { CAst.make ~loc @@ QMatch } - | IDENT "fix" -> { CAst.make ~loc @@ QFix } - | IDENT "cofix" -> { CAst.make ~loc @@ QCofix } - | IDENT "zeta" -> { CAst.make ~loc @@ QZeta } - | IDENT "delta"; d = delta_flag -> { d } - ] ] - ; - refglobal: - [ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) } - | qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) } - | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } - ] ] - ; - q_reference: - [ [ r = refglobal -> { r } ] ] - ; - refglobals: - [ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ] - ; - delta_flag: - [ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl } - | "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl } - | -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) } - ] ] - ; - strategy_flag: - [ [ s = LIST1 red_flag -> { CAst.make ~loc s } - | d = delta_flag -> - { CAst.make ~loc - [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } - ] ] - ; - q_strategy_flag: - [ [ flag = strategy_flag -> { flag } ] ] - ; - hintdb: - [ [ "*" -> { CAst.make ~loc @@ QHintAll } - | l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l } - ] ] - ; - q_hintdb: - [ [ db = hintdb -> { db } ] ] - ; - match_pattern: - [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } - | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; tac = tac2expr -> - { CAst.make ~loc @@ (mp, tac) } - ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } - | "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] - ; - q_constr_matching: - [ [ m = match_list -> { m } ] ] - ; - gmatch_hyp_pattern: - [ [ na = Prim.name; ":"; pat = match_pattern -> { (na, pat) } ] ] - ; - gmatch_pattern: - [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> - { CAst.make ~loc @@ { - q_goal_match_concl = p; - q_goal_match_hyps = hl; - } } - ] ] - ; - gmatch_rule: - [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> - { CAst.make ~loc @@ (mp, tac) } - ] ] - ; - gmatch_list: - [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } - | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] - ; - q_goal_matching: - [ [ m = gmatch_list -> { m } ] ] - ; - move_location: - [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } - | "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast } - | IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id } - | IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id } - ] ] - ; - q_move_location: - [ [ mv = move_location -> { mv } ] ] - ; - as_name: - [ [ -> { None } - | "as"; id = ident_or_anti -> { Some id } - ] ] - ; - pose: - [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - { CAst.make ~loc (Some id, c) } - | c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) } - ] ] - ; - q_pose: - [ [ p = pose -> { p } ] ] - ; - as_ipat: - [ [ "as"; ipat = simple_intropattern -> { Some ipat } - | -> { None } - ] ] - ; - by_tactic: - [ [ "by"; tac = tac2expr -> { Some tac } - | -> { None } - ] ] - ; - assertion: - [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - { CAst.make ~loc (QAssertValue (id, c)) } - | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> - { let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in - CAst.make ~loc (QAssertType (Some ipat, c, tac)) } - | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> - { CAst.make ~loc (QAssertType (ipat, c, tac)) } - ] ] - ; - q_assert: - [ [ a = assertion -> { a } ] ] - ; -END - -(** Extension of constr syntax *) - -(* -GRAMMAR EXTEND Gram - Pcoq.Constr.operconstr: LEVEL "0" - [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> - { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } - | test_ampersand_ident; "&"; id = Prim.ident -> - { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } - | test_dollar_ident; "$"; id = Prim.ident -> - { let id = Loc.tag ~loc id in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } - ] ] - ; -END -*) -{ - -let () = - -let open Extend in -let open Tok in -let (++) r s = Next (r, s) in -let rules = [ - Rule ( - Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, - begin fun id _ _ loc -> - let id = Loc.tag ~loc id in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - end - ); - - Rule ( - Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, - begin fun id _ _ loc -> - let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - end - ); - - Rule ( - Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ - Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), - begin fun _ tac _ _ _ loc -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - end - ) -] in - -Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) -end - -} - -{ - -let pr_ltac2entry _ = mt () (* FIXME *) -let pr_ltac2expr _ = mt () (* FIXME *) - -} - -VERNAC ARGUMENT EXTEND ltac2_entry -PRINTED BY { pr_ltac2entry } -| [ tac2def_val(v) ] -> { v } -| [ tac2def_typ(t) ] -> { t } -| [ tac2def_ext(e) ] -> { e } -| [ tac2def_syn(e) ] -> { e } -| [ tac2def_mut(e) ] -> { e } -| [ tac2def_run(e) ] -> { e } -END - -{ - -let classify_ltac2 = function -| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) -| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff - -} - -VERNAC COMMAND EXTEND VernacDeclareTactic2Definition -| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { - fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate - } -END - -{ - -let _ = Pvernac.register_proof_mode "Ltac2" tac2mode - -} - -VERNAC ARGUMENT EXTEND ltac2_expr -PRINTED BY { pr_ltac2expr } -| [ tac2expr(e) ] -> { e } -END - -{ - -open G_ltac -open Vernacextend - -} - -VERNAC { tac2mode } EXTEND VernacLtac2 -| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => - { classify_as_proofstep } -> { -(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - fun ~pstate -> - Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate - } -END - -{ - -open Stdarg - -} - -VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF -| [ "Print" "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac tac } -END diff --git a/src/ltac2_plugin.mlpack b/src/ltac2_plugin.mlpack deleted file mode 100644 index 2a25e825cb..0000000000 --- a/src/ltac2_plugin.mlpack +++ /dev/null @@ -1,14 +0,0 @@ -Tac2dyn -Tac2ffi -Tac2env -Tac2print -Tac2intern -Tac2interp -Tac2entries -Tac2quote -Tac2match -Tac2core -Tac2extffi -Tac2tactics -Tac2stdlib -G_ltac2 diff --git a/src/tac2core.ml b/src/tac2core.ml deleted file mode 100644 index d7e7b91ee6..0000000000 --- a/src/tac2core.ml +++ /dev/null @@ -1,1446 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Value.of_option Value.of_ident None -| Name id -> Value.of_option Value.of_ident (Some id) - -let to_name c = match Value.to_option Value.to_ident c with -| None -> Anonymous -| Some id -> Name id - -let of_relevance = function - | Sorts.Relevant -> ValInt 0 - | Sorts.Irrelevant -> ValInt 1 - -let to_relevance = function - | ValInt 0 -> Sorts.Relevant - | ValInt 1 -> Sorts.Irrelevant - | _ -> assert false - -let of_annot f Context.{binder_name;binder_relevance} = - of_tuple [|(f binder_name); of_relevance binder_relevance|] - -let to_annot f x = - match to_tuple x with - | [|x;y|] -> - let x = f x in - let y = to_relevance y in - Context.make_annot x y - | _ -> assert false - -let of_instance u = - let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in - Value.of_array (fun v -> Value.of_ext Value.val_univ v) u - -let to_instance u = - let u = Value.to_array (fun v -> Value.to_ext Value.val_univ v) u in - EConstr.EInstance.make (Univ.Instance.of_array u) - -let of_rec_declaration (nas, ts, cs) = - (Value.of_array (of_annot of_name) nas, - Value.of_array Value.of_constr ts, - Value.of_array Value.of_constr cs) - -let to_rec_declaration (nas, ts, cs) = - (Value.to_array (to_annot to_name) nas, - Value.to_array Value.to_constr ts, - Value.to_array Value.to_constr cs) - -let of_result f = function -| Inl c -> v_blk 0 [|f c|] -| Inr e -> v_blk 1 [|Value.of_exn e|] - -(** Stdlib exceptions *) - -let err_notfocussed = - Tac2interp.LtacError (coq_core "Not_focussed", [||]) - -let err_outofbounds = - Tac2interp.LtacError (coq_core "Out_of_bounds", [||]) - -let err_notfound = - Tac2interp.LtacError (coq_core "Not_found", [||]) - -let err_matchfailure = - Tac2interp.LtacError (coq_core "Match_failure", [||]) - -(** Helper functions *) - -let thaw f = Tac2ffi.apply f [v_unit] - -let fatal_flag : unit Exninfo.t = Exninfo.make () - -let set_bt info = - if !Tac2interp.print_ltac2_backtrace then - Tac2interp.get_backtrace >>= fun bt -> - Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) - else Proofview.tclUNIT info - -let throw ?(info = Exninfo.null) e = - set_bt info >>= fun info -> - let info = Exninfo.add info fatal_flag () in - Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) - -let fail ?(info = Exninfo.null) e = - set_bt info >>= fun info -> - Proofview.tclZERO ~info e - -let return x = Proofview.tclUNIT x -let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } - -let wrap f = - return () >>= fun () -> return (f ()) - -let wrap_unit f = - return () >>= fun () -> f (); return v_unit - -let assert_focussed = - Proofview.Goal.goals >>= fun gls -> - match gls with - | [_] -> Proofview.tclUNIT () - | [] | _ :: _ :: _ -> throw err_notfocussed - -let pf_apply f = - Proofview.Goal.goals >>= function - | [] -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - f env sigma - | [gl] -> - gl >>= fun gl -> - f (Proofview.Goal.env gl) (Tacmach.New.project gl) - | _ :: _ :: _ -> - throw err_notfocussed - -(** Primitives *) - -let define_primitive name arity f = - Tac2env.define_primitive (pname name) (mk_closure arity f) - -let define0 name f = define_primitive name arity_one (fun _ -> f) - -let define1 name r0 f = define_primitive name arity_one begin fun x -> - f (Value.repr_to r0 x) -end - -let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> - f (Value.repr_to r0 x) (Value.repr_to r1 y) -end - -let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> - f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) -end - -(** Printing *) - -let () = define1 "print" pp begin fun pp -> - wrap_unit (fun () -> Feedback.msg_notice pp) -end - -let () = define1 "message_of_int" int begin fun n -> - return (Value.of_pp (Pp.int n)) -end - -let () = define1 "message_of_string" string begin fun s -> - return (Value.of_pp (str (Bytes.to_string s))) -end - -let () = define1 "message_of_constr" constr begin fun c -> - pf_apply begin fun env sigma -> - let pp = Printer.pr_econstr_env env sigma c in - return (Value.of_pp pp) - end -end - -let () = define1 "message_of_ident" ident begin fun c -> - let pp = Id.print c in - return (Value.of_pp pp) -end - -let () = define1 "message_of_exn" valexpr begin fun v -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - let pp = Tac2print.pr_valexpr env sigma v (GTypRef (Other Core.t_exn, [])) in - return (Value.of_pp pp) -end - - -let () = define2 "message_concat" pp pp begin fun m1 m2 -> - return (Value.of_pp (Pp.app m1 m2)) -end - -(** Array *) - -let () = define2 "array_make" int valexpr begin fun n x -> - if n < 0 || n > Sys.max_array_length then throw err_outofbounds - else wrap (fun () -> v_blk 0 (Array.make n x)) -end - -let () = define1 "array_length" block begin fun (_, v) -> - return (Value.of_int (Array.length v)) -end - -let () = define3 "array_set" block int valexpr begin fun (_, v) n x -> - if n < 0 || n >= Array.length v then throw err_outofbounds - else wrap_unit (fun () -> v.(n) <- x) -end - -let () = define2 "array_get" block int begin fun (_, v) n -> - if n < 0 || n >= Array.length v then throw err_outofbounds - else wrap (fun () -> v.(n)) -end - -(** Ident *) - -let () = define2 "ident_equal" ident ident begin fun id1 id2 -> - return (Value.of_bool (Id.equal id1 id2)) -end - -let () = define1 "ident_to_string" ident begin fun id -> - return (Value.of_string (Bytes.of_string (Id.to_string id))) -end - -let () = define1 "ident_of_string" string begin fun s -> - let id = try Some (Id.of_string (Bytes.to_string s)) with _ -> None in - return (Value.of_option Value.of_ident id) -end - -(** Int *) - -let () = define2 "int_equal" int int begin fun m n -> - return (Value.of_bool (m == n)) -end - -let binop n f = define2 n int int begin fun m n -> - return (Value.of_int (f m n)) -end - -let () = binop "int_compare" Int.compare -let () = binop "int_add" (+) -let () = binop "int_sub" (-) -let () = binop "int_mul" ( * ) - -let () = define1 "int_neg" int begin fun m -> - return (Value.of_int (~- m)) -end - -(** Char *) - -let () = define1 "char_of_int" int begin fun n -> - wrap (fun () -> Value.of_char (Char.chr n)) -end - -let () = define1 "char_to_int" char begin fun n -> - wrap (fun () -> Value.of_int (Char.code n)) -end - -(** String *) - -let () = define2 "string_make" int char begin fun n c -> - if n < 0 || n > Sys.max_string_length then throw err_outofbounds - else wrap (fun () -> Value.of_string (Bytes.make n c)) -end - -let () = define1 "string_length" string begin fun s -> - return (Value.of_int (Bytes.length s)) -end - -let () = define3 "string_set" string int char begin fun s n c -> - if n < 0 || n >= Bytes.length s then throw err_outofbounds - else wrap_unit (fun () -> Bytes.set s n c) -end - -let () = define2 "string_get" string int begin fun s n -> - if n < 0 || n >= Bytes.length s then throw err_outofbounds - else wrap (fun () -> Value.of_char (Bytes.get s n)) -end - -(** Terms *) - -(** constr -> constr *) -let () = define1 "constr_type" constr begin fun c -> - let get_type env sigma = - Proofview.V82.wrap_exceptions begin fun () -> - let (sigma, t) = Typing.type_of env sigma c in - let t = Value.of_constr t in - Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t - end in - pf_apply get_type -end - -(** constr -> constr *) -let () = define2 "constr_equal" constr constr begin fun c1 c2 -> - Proofview.tclEVARMAP >>= fun sigma -> - let b = EConstr.eq_constr sigma c1 c2 in - Proofview.tclUNIT (Value.of_bool b) -end - -let () = define1 "constr_kind" constr begin fun c -> - let open Constr in - Proofview.tclEVARMAP >>= fun sigma -> - return begin match EConstr.kind sigma c with - | Rel n -> - v_blk 0 [|Value.of_int n|] - | Var id -> - v_blk 1 [|Value.of_ident id|] - | Meta n -> - v_blk 2 [|Value.of_int n|] - | Evar (evk, args) -> - v_blk 3 [| - Value.of_int (Evar.repr evk); - Value.of_array Value.of_constr args; - |] - | Sort s -> - v_blk 4 [|Value.of_ext Value.val_sort s|] - | Cast (c, k, t) -> - v_blk 5 [| - Value.of_constr c; - Value.of_ext Value.val_cast k; - Value.of_constr t; - |] - | Prod (na, t, u) -> - v_blk 6 [| - of_annot of_name na; - Value.of_constr t; - Value.of_constr u; - |] - | Lambda (na, t, c) -> - v_blk 7 [| - of_annot of_name na; - Value.of_constr t; - Value.of_constr c; - |] - | LetIn (na, b, t, c) -> - v_blk 8 [| - of_annot of_name na; - Value.of_constr b; - Value.of_constr t; - Value.of_constr c; - |] - | App (c, cl) -> - v_blk 9 [| - Value.of_constr c; - Value.of_array Value.of_constr cl; - |] - | Const (cst, u) -> - v_blk 10 [| - Value.of_constant cst; - of_instance u; - |] - | Ind (ind, u) -> - v_blk 11 [| - Value.of_ext Value.val_inductive ind; - of_instance u; - |] - | Construct (cstr, u) -> - v_blk 12 [| - Value.of_ext Value.val_constructor cstr; - of_instance u; - |] - | Case (ci, c, t, bl) -> - v_blk 13 [| - Value.of_ext Value.val_case ci; - Value.of_constr c; - Value.of_constr t; - Value.of_array Value.of_constr bl; - |] - | Fix ((recs, i), def) -> - let (nas, ts, cs) = of_rec_declaration def in - v_blk 14 [| - Value.of_array Value.of_int recs; - Value.of_int i; - nas; - ts; - cs; - |] - | CoFix (i, def) -> - let (nas, ts, cs) = of_rec_declaration def in - v_blk 15 [| - Value.of_int i; - nas; - ts; - cs; - |] - | Proj (p, c) -> - v_blk 16 [| - Value.of_ext Value.val_projection p; - Value.of_constr c; - |] - | Int _ -> - assert false - end -end - -let () = define1 "constr_make" valexpr begin fun knd -> - let c = match Tac2ffi.to_block knd with - | (0, [|n|]) -> - let n = Value.to_int n in - EConstr.mkRel n - | (1, [|id|]) -> - let id = Value.to_ident id in - EConstr.mkVar id - | (2, [|n|]) -> - let n = Value.to_int n in - EConstr.mkMeta n - | (3, [|evk; args|]) -> - let evk = Evar.unsafe_of_int (Value.to_int evk) in - let args = Value.to_array Value.to_constr args in - EConstr.mkEvar (evk, args) - | (4, [|s|]) -> - let s = Value.to_ext Value.val_sort s in - EConstr.mkSort (EConstr.Unsafe.to_sorts s) - | (5, [|c; k; t|]) -> - let c = Value.to_constr c in - let k = Value.to_ext Value.val_cast k in - let t = Value.to_constr t in - EConstr.mkCast (c, k, t) - | (6, [|na; t; u|]) -> - let na = to_annot to_name na in - let t = Value.to_constr t in - let u = Value.to_constr u in - EConstr.mkProd (na, t, u) - | (7, [|na; t; c|]) -> - let na = to_annot to_name na in - let t = Value.to_constr t in - let u = Value.to_constr c in - EConstr.mkLambda (na, t, u) - | (8, [|na; b; t; c|]) -> - let na = to_annot to_name na in - let b = Value.to_constr b in - let t = Value.to_constr t in - let c = Value.to_constr c in - EConstr.mkLetIn (na, b, t, c) - | (9, [|c; cl|]) -> - let c = Value.to_constr c in - let cl = Value.to_array Value.to_constr cl in - EConstr.mkApp (c, cl) - | (10, [|cst; u|]) -> - let cst = Value.to_constant cst in - let u = to_instance u in - EConstr.mkConstU (cst, u) - | (11, [|ind; u|]) -> - let ind = Value.to_ext Value.val_inductive ind in - let u = to_instance u in - EConstr.mkIndU (ind, u) - | (12, [|cstr; u|]) -> - let cstr = Value.to_ext Value.val_constructor cstr in - let u = to_instance u in - EConstr.mkConstructU (cstr, u) - | (13, [|ci; c; t; bl|]) -> - let ci = Value.to_ext Value.val_case ci in - let c = Value.to_constr c in - let t = Value.to_constr t in - let bl = Value.to_array Value.to_constr bl in - EConstr.mkCase (ci, c, t, bl) - | (14, [|recs; i; nas; ts; cs|]) -> - let recs = Value.to_array Value.to_int recs in - let i = Value.to_int i in - let def = to_rec_declaration (nas, ts, cs) in - EConstr.mkFix ((recs, i), def) - | (15, [|i; nas; ts; cs|]) -> - let i = Value.to_int i in - let def = to_rec_declaration (nas, ts, cs) in - EConstr.mkCoFix (i, def) - | (16, [|p; c|]) -> - let p = Value.to_ext Value.val_projection p in - let c = Value.to_constr c in - EConstr.mkProj (p, c) - | _ -> assert false - in - return (Value.of_constr c) -end - -let () = define1 "constr_check" constr begin fun c -> - pf_apply begin fun env sigma -> - try - let (sigma, _) = Typing.type_of env sigma c in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - return (of_result Value.of_constr (Inl c)) - with e when CErrors.noncritical e -> - let e = CErrors.push e in - return (of_result Value.of_constr (Inr e)) - end -end - -let () = define3 "constr_substnl" (list constr) int constr begin fun subst k c -> - let ans = EConstr.Vars.substnl subst k c in - return (Value.of_constr ans) -end - -let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> - let ans = EConstr.Vars.substn_vars k ids c in - return (Value.of_constr ans) -end - -let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> - Proofview.tclENV >>= fun env -> - try - let ans = Inductiveops.make_case_info env ind Sorts.Relevant Constr.RegularStyle in - return (Value.of_ext Value.val_case ans) - with e when CErrors.noncritical e -> - throw err_notfound -end - -let () = define2 "constr_constructor" (repr_ext val_inductive) int begin fun (ind, i) k -> - Proofview.tclENV >>= fun env -> - try - let open Declarations in - let ans = Environ.lookup_mind ind env in - let _ = ans.mind_packets.(i).mind_consnames.(k) in - return (Value.of_ext val_constructor ((ind, i), (k + 1))) - with e when CErrors.noncritical e -> - throw err_notfound -end - -let () = define3 "constr_in_context" ident constr closure begin fun id t c -> - Proofview.Goal.goals >>= function - | [gl] -> - gl >>= fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let has_var = - try - let _ = Environ.lookup_named_val id env in - true - with Not_found -> false - in - if has_var then - Tacticals.New.tclZEROMSG (str "Variable already exists") - else - let open Context.Named.Declaration in - let nenv = EConstr.push_named (LocalAssum (Context.make_annot id Sorts.Relevant, t)) env in - let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in - let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> - thaw c >>= fun _ -> - Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> - let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in - let args = Array.of_list (EConstr.mkRel 1 :: args) in - let ans = EConstr.mkEvar (evk, args) in - let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in - return (Value.of_constr ans) - | _ -> - throw err_notfocussed -end - -(** Patterns *) - -let empty_context = EConstr.mkMeta Constr_matching.special_meta - -let () = define0 "pattern_empty_context" begin - return (Value.of_constr empty_context) -end - -let () = define2 "pattern_matches" pattern constr begin fun pat c -> - pf_apply begin fun env sigma -> - let ans = - try Some (Constr_matching.matches env sigma pat c) - with Constr_matching.PatternMatchingFailure -> None - in - begin match ans with - | None -> fail err_matchfailure - | Some ans -> - let ans = Id.Map.bindings ans in - let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - return (Value.of_list of_pair ans) - end - end -end - -let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> - let open Constr_matching in - let rec of_ans s = match IStream.peek s with - | IStream.Nil -> fail err_matchfailure - | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> - let ans = Id.Map.bindings sub in - let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_list of_pair ans |] in - Proofview.tclOR (return ans) (fun _ -> of_ans s) - in - pf_apply begin fun env sigma -> - let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in - of_ans ans - end -end - -let () = define2 "pattern_matches_vect" pattern constr begin fun pat c -> - pf_apply begin fun env sigma -> - let ans = - try Some (Constr_matching.matches env sigma pat c) - with Constr_matching.PatternMatchingFailure -> None - in - begin match ans with - | None -> fail err_matchfailure - | Some ans -> - let ans = Id.Map.bindings ans in - let ans = Array.map_of_list snd ans in - return (Value.of_array Value.of_constr ans) - end - end -end - -let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c -> - let open Constr_matching in - let rec of_ans s = match IStream.peek s with - | IStream.Nil -> fail err_matchfailure - | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> - let ans = Id.Map.bindings sub in - let ans = Array.map_of_list snd ans in - let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_array Value.of_constr ans |] in - Proofview.tclOR (return ans) (fun _ -> of_ans s) - in - pf_apply begin fun env sigma -> - let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in - of_ans ans - end -end - -let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bool pattern) begin fun rev hp cp -> - assert_focussed >>= fun () -> - Proofview.Goal.enter_one begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let concl = Proofview.Goal.concl gl in - let mk_pattern (b, pat) = if b then Tac2match.MatchPattern pat else Tac2match.MatchContext pat in - let r = (List.map mk_pattern hp, mk_pattern cp) in - Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> - let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in - let hids = Value.of_array Value.of_ident (Array.map_of_list fst hyps) in - let hctx = Value.of_array of_ctxopt (Array.map_of_list snd hyps) in - let subs = Value.of_array Value.of_constr (Array.map_of_list snd (Id.Map.bindings subst)) in - let cctx = of_ctxopt ctx in - let ans = Value.of_tuple [| hids; hctx; subs; cctx |] in - Proofview.tclUNIT ans - end -end - -let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> - let ctx = EConstr.Unsafe.to_constr ctx in - let c = EConstr.Unsafe.to_constr c in - let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in - return (Value.of_constr (EConstr.of_constr ans)) -end - -(** Error *) - -let () = define1 "throw" exn begin fun (e, info) -> - throw ~info e -end - -(** Control *) - -(** exn -> 'a *) -let () = define1 "zero" exn begin fun (e, info) -> - fail ~info e -end - -(** (unit -> 'a) -> (exn -> 'a) -> 'a *) -let () = define2 "plus" closure closure begin fun x k -> - Proofview.tclOR (thaw x) (fun e -> Tac2ffi.apply k [Value.of_exn e]) -end - -(** (unit -> 'a) -> 'a *) -let () = define1 "once" closure begin fun f -> - Proofview.tclONCE (thaw f) -end - -(** (unit -> unit) list -> unit *) -let () = define1 "dispatch" (list closure) begin fun l -> - let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in - Proofview.tclDISPATCH l >>= fun () -> return v_unit -end - -(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let () = define3 "extend" (list closure) closure (list closure) begin fun lft tac rgt -> - let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in - let tac = Proofview.tclIGNORE (thaw tac) in - let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in - Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit -end - -(** (unit -> unit) -> unit *) -let () = define1 "enter" closure begin fun f -> - let f = Proofview.tclIGNORE (thaw f) in - Proofview.tclINDEPENDENT f >>= fun () -> return v_unit -end - -(** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) -let () = define1 "case" closure begin fun f -> - Proofview.tclCASE (thaw f) >>= begin function - | Proofview.Next (x, k) -> - let k = Tac2ffi.mk_closure arity_one begin fun e -> - let (e, info) = Value.to_exn e in - set_bt info >>= fun info -> - k (e, info) - end in - return (v_blk 0 [| Value.of_tuple [| x; Value.of_closure k |] |]) - | Proofview.Fail e -> return (v_blk 1 [| Value.of_exn e |]) - end -end - -(** int -> int -> (unit -> 'a) -> 'a *) -let () = define3 "focus" int int closure begin fun i j tac -> - Proofview.tclFOCUS i j (thaw tac) -end - -(** unit -> unit *) -let () = define0 "shelve" begin - Proofview.shelve >>= fun () -> return v_unit -end - -(** unit -> unit *) -let () = define0 "shelve_unifiable" begin - Proofview.shelve_unifiable >>= fun () -> return v_unit -end - -let () = define1 "new_goal" int begin fun ev -> - let ev = Evar.unsafe_of_int ev in - Proofview.tclEVARMAP >>= fun sigma -> - if Evd.mem sigma ev then - Proofview.Unsafe.tclNEWGOALS [Proofview.with_empty_state ev] <*> Proofview.tclUNIT v_unit - else throw err_notfound -end - -(** unit -> constr *) -let () = define0 "goal" begin - assert_focussed >>= fun () -> - Proofview.Goal.enter_one begin fun gl -> - let concl = Tacmach.New.pf_nf_concl gl in - return (Value.of_constr concl) - end -end - -(** ident -> constr *) -let () = define1 "hyp" ident begin fun id -> - pf_apply begin fun env _ -> - let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in - if mem then return (Value.of_constr (EConstr.mkVar id)) - else Tacticals.New.tclZEROMSG - (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (* FIXME: Do something more sensible *) - end -end - -let () = define0 "hyps" begin - pf_apply begin fun env _ -> - let open Context in - let open Named.Declaration in - let hyps = List.rev (Environ.named_context env) in - let map = function - | LocalAssum (id, t) -> - let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr None; Value.of_constr t|] - | LocalDef (id, c, t) -> - let c = EConstr.of_constr c in - let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr (Some c); Value.of_constr t|] - in - return (Value.of_list map hyps) - end -end - -(** (unit -> constr) -> unit *) -let () = define1 "refine" closure begin fun c -> - let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in - Proofview.Goal.enter begin fun gl -> - Refine.generic_refine ~typecheck:true c gl - end >>= fun () -> return v_unit -end - -let () = define2 "with_holes" closure closure begin fun x f -> - Proofview.tclEVARMAP >>= fun sigma0 -> - thaw x >>= fun ans -> - Proofview.tclEVARMAP >>= fun sigma -> - Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> - Tacticals.New.tclWITHHOLES false (Tac2ffi.apply f [ans]) sigma -end - -let () = define1 "progress" closure begin fun f -> - Proofview.tclPROGRESS (thaw f) -end - -let () = define2 "abstract" (option ident) closure begin fun id f -> - Abstract.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> - return v_unit -end - -let () = define2 "time" (option string) closure begin fun s f -> - let s = Option.map Bytes.to_string s in - Proofview.tclTIME s (thaw f) -end - -let () = define0 "check_interrupt" begin - Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit -end - -(** Fresh *) - -let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun set1 set2 -> - let ans = Id.Set.union set1 set2 in - return (Value.of_ext Value.val_free ans) -end - -let () = define1 "fresh_free_of_ids" (list ident) begin fun ids -> - let free = List.fold_right Id.Set.add ids Id.Set.empty in - return (Value.of_ext Value.val_free free) -end - -let () = define1 "fresh_free_of_constr" constr begin fun c -> - Proofview.tclEVARMAP >>= fun sigma -> - let rec fold accu c = match EConstr.kind sigma c with - | Constr.Var id -> Id.Set.add id accu - | _ -> EConstr.fold sigma fold accu c - in - let ans = fold Id.Set.empty c in - return (Value.of_ext Value.val_free ans) -end - -let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> - let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in - return (Value.of_ident nid) -end - -(** Env *) - -let () = define1 "env_get" (list ident) begin fun ids -> - let r = match ids with - | [] -> None - | _ :: _ as ids -> - let (id, path) = List.sep_last ids in - let path = DirPath.make (List.rev path) in - let fp = Libnames.make_path path id in - try Some (Nametab.global_of_path fp) with Not_found -> None - in - return (Value.of_option Value.of_reference r) -end - -let () = define1 "env_expand" (list ident) begin fun ids -> - let r = match ids with - | [] -> [] - | _ :: _ as ids -> - let (id, path) = List.sep_last ids in - let path = DirPath.make (List.rev path) in - let qid = Libnames.make_qualid path id in - Nametab.locate_all qid - in - return (Value.of_list Value.of_reference r) -end - -let () = define1 "env_path" reference begin fun r -> - match Nametab.path_of_global r with - | fp -> - let (path, id) = Libnames.repr_path fp in - let path = DirPath.repr path in - return (Value.of_list Value.of_ident (List.rev_append path [id])) - | exception Not_found -> - throw err_notfound -end - -let () = define1 "env_instantiate" reference begin fun r -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - let (sigma, c) = Evd.fresh_global env sigma r in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - return (Value.of_constr c) -end - -(** Ltac1 in Ltac2 *) - -let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 -let of_ltac1 v = Value.of_ext Value.val_ltac1 v - -let () = define1 "ltac1_ref" (list ident) begin fun ids -> - let open Ltac_plugin in - let r = match ids with - | [] -> raise Not_found - | _ :: _ as ids -> - let (id, path) = List.sep_last ids in - let path = DirPath.make (List.rev path) in - let fp = Libnames.make_path path id in - if Tacenv.exists_tactic fp then - List.hd (Tacenv.locate_extended_all_tactic (Libnames.qualid_of_path fp)) - else raise Not_found - in - let tac = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) (Tacenv.interp_ltac r) in - return (Value.of_ext val_ltac1 tac) -end - -let () = define1 "ltac1_run" ltac1 begin fun v -> - let open Ltac_plugin in - Tacinterp.tactic_of_value (Tacinterp.default_ist ()) v >>= fun () -> - return v_unit -end - -let () = define3 "ltac1_apply" ltac1 (list ltac1) closure begin fun f args k -> - let open Ltac_plugin in - let open Tacexpr in - let open Locus in - let k ret = - Proofview.tclIGNORE (Tac2ffi.apply k [Value.of_ext val_ltac1 ret]) - in - let fold arg (i, vars, lfun) = - let id = Id.of_string ("x" ^ string_of_int i) in - let x = Reference (ArgVar CAst.(make id)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in - Tacinterp.val_interp ist tac k >>= fun () -> - return v_unit -end - -let () = define1 "ltac1_of_constr" constr begin fun c -> - let open Ltac_plugin in - return (Value.of_ext val_ltac1 (Tacinterp.Value.of_constr c)) -end - -let () = define1 "ltac1_to_constr" ltac1 begin fun v -> - let open Ltac_plugin in - return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) -end - -let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> - let open Geninterp.Val in - return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) -end - -let () = define1 "ltac1_to_list" ltac1 begin fun v -> - let open Ltac_plugin in - return (Value.of_option (Value.of_list of_ltac1) (Tacinterp.Value.to_list v)) -end - -(** ML types *) - -let constr_flags () = - let open Pretyping in - { - use_typeclasses = true; - solve_unification_constraints = true; - fail_evar = true; - expand_evars = true; - program_mode = false; - polymorphic = false; - } - -let open_constr_no_classes_flags () = - let open Pretyping in - { - use_typeclasses = false; - solve_unification_constraints = true; - fail_evar = false; - expand_evars = true; - program_mode = false; - polymorphic = false; - } - -(** Embed all Ltac2 data into Values *) -let to_lvar ist = - let open Glob_ops in - let lfun = Tac2interp.set_env ist Id.Map.empty in - { empty_lvar with Ltac_pretype.ltac_genargs = lfun } - -let gtypref kn = GTypRef (Other kn, []) - -let intern_constr self ist c = - let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in - (GlbVal c, gtypref t_constr) - -let catchable_exception = function - | Logic_monad.Exception _ -> false - | e -> CErrors.noncritical e - -let interp_constr flags ist c = - let open Pretyping in - let ist = to_lvar ist in - pf_apply begin fun env sigma -> - try - let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = Value.of_constr c in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT c - with e when catchable_exception e -> - let (e, info) = CErrors.push e in - set_bt info >>= fun info -> - match Exninfo.get info fatal_flag with - | None -> Proofview.tclZERO ~info e - | Some () -> throw ~info e - end - -let () = - let intern = intern_constr in - let interp ist c = interp_constr (constr_flags ()) ist c in - let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in - let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_constr obj - -let () = - let intern = intern_constr in - let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in - let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in - let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_open_constr obj - -let () = - let interp _ id = return (Value.of_ident id) in - let print _ id = str "ident:(" ++ Id.print id ++ str ")" in - let obj = { - ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); - ml_interp = interp; - ml_subst = (fun _ id -> id); - ml_print = print; - } in - define_ml_object Tac2quote.wit_ident obj - -let () = - let intern self ist c = - let env = ist.Genintern.genv in - let sigma = Evd.from_env env in - let warn = if !Ltac_plugin.Tacintern.strict_check then fun x -> x else Constrintern.for_grammar in - let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in - GlbVal pat, gtypref t_pattern - in - let subst subst c = - let env = Global.env () in - let sigma = Evd.from_env env in - Patternops.subst_pattern env sigma subst c - in - let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in - let interp _ c = return (Value.of_pattern c) in - let obj = { - ml_intern = intern; - ml_interp = interp; - ml_subst = subst; - ml_print = print; - } in - define_ml_object Tac2quote.wit_pattern obj - -let () = - let intern self ist ref = match ref.CAst.v with - | Tac2qexpr.QHypothesis id -> - GlbVal (Globnames.VarRef id), gtypref t_reference - | Tac2qexpr.QReference qid -> - let gr = - try Nametab.locate qid - with Not_found -> - Nametab.error_global_not_found qid - in - GlbVal gr, gtypref t_reference - in - let subst s c = Globnames.subst_global_reference s c in - let interp _ gr = return (Value.of_reference gr) in - let print _ = function - | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" - | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" - in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_reference obj - -let () = - let intern self ist tac = - (* Prevent inner calls to Ltac2 values *) - let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in - let ist = { ist with Genintern.extra } in - let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in - GlbVal tac, gtypref t_unit - in - let interp ist tac = - let ist = { env_ist = Id.Map.empty } in - let lfun = Tac2interp.set_env ist Id.Map.empty in - let ist = Ltac_plugin.Tacinterp.default_ist () in - let ist = { ist with Geninterp.lfun = lfun } in - let tac = (Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in - let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in - Proofview.tclOR tac wrap >>= fun () -> - return v_unit - in - let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in - let print env tac = - str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" - in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_ltac1 obj - -let () = - let open Ltac_plugin in - let intern self ist tac = - (* Prevent inner calls to Ltac2 values *) - let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in - let ist = { ist with Genintern.extra } in - let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in - GlbVal tac, gtypref t_ltac1 - in - let interp ist tac = - let ist = { env_ist = Id.Map.empty } in - let lfun = Tac2interp.set_env ist Id.Map.empty in - let ist = Ltac_plugin.Tacinterp.default_ist () in - let ist = { ist with Geninterp.lfun = lfun } in - return (Value.of_ext val_ltac1 (Tacinterp.Value.of_closure ist tac)) - in - let subst s tac = Genintern.substitute Tacarg.wit_tactic s tac in - let print env tac = - str "ltac1val:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" - in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_ltac1val obj - -(** Ltac2 in terms *) - -let () = - let interp ist poly env sigma concl tac = - let ist = Tac2interp.get_env ist in - let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in - let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in - (EConstr.of_constr c, sigma) - in - GlobEnv.register_constr_interp0 wit_ltac2 interp - -let () = - let interp ist poly env sigma concl id = - let ist = Tac2interp.get_env ist in - let c = Id.Map.find id ist.env_ist in - let c = Value.to_constr c in - let sigma = Typing.check env sigma c concl in - (c, sigma) - in - GlobEnv.register_constr_interp0 wit_ltac2_quotation interp - -let () = - let pr_raw id = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in - let pr_glb id = Genprint.PrinterBasic (fun _env _sigma -> str "$" ++ Id.print id) in - let pr_top _ = Genprint.TopPrinterBasic mt in - Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top - -(** Ltac2 in Ltac1 *) - -let () = - let e = Tac2entries.Pltac.tac2expr in - let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in - Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) - -let () = - let open Ltac_plugin in - let open Tacinterp in - let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in - let interp ist tac = -(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) - let ist = { env_ist = Id.Map.empty } in - Tac2interp.interp ist tac >>= fun _ -> - Ftactic.return idtac - in - Geninterp.register_interp0 wit_ltac2 interp - -let () = - let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in - let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in - let pr_top _ = Genprint.TopPrinterBasic mt in - Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top - -(** Built-in notation scopes *) - -let add_scope s f = - Tac2entries.register_scope (Id.of_string s) f - -let rec pr_scope = let open CAst in function -| SexprStr {v=s} -> qstring s -| SexprInt {v=n} -> Pp.int n -| SexprRec (_, {v=na}, args) -> - let na = match na with - | None -> str "_" - | Some id -> Id.print id - in - na ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" - -let scope_fail s args = - let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in - CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) - -let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) - -let add_generic_scope s entry arg = - let parse = function - | [] -> - let scope = Extend.Aentry entry in - let act x = CAst.make @@ CTacExt (arg, x) in - Tac2entries.ScopeRule (scope, act) - | arg -> scope_fail s arg - in - add_scope s parse - -open CAst - -let () = add_scope "keyword" begin function -| [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (Tok.PKEYWORD s) in - Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) -| arg -> scope_fail "keyword" arg -end - -let () = add_scope "terminal" begin function -| [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (CLexer.terminal s) in - Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) -| arg -> scope_fail "terminal" arg -end - -let () = add_scope "list0" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist0 scope in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr {v=str}] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist0sep (scope, sep) in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "list0" arg -end - -let () = add_scope "list1" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist1 scope in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr {v=str}] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist1sep (scope, sep) in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "list1" arg -end - -let () = add_scope "opt" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Aopt scope in - let act opt = match opt with - | None -> - CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) - | Some x -> - CAst.make @@ CTacApp (CAst.make @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) - in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "opt" arg -end - -let () = add_scope "self" begin function -| [] -> - let scope = Extend.Aself in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "self" arg -end - -let () = add_scope "next" begin function -| [] -> - let scope = Extend.Anext in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "next" arg -end - -let () = add_scope "tactic" begin function -| [] -> - (* Default to level 5 parsing *) - let scope = Extend.Aentryl (tac2expr, "5") in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| [SexprInt {loc;v=n}] as arg -> - let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Extend.Aentryl (tac2expr, string_of_int n) in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "tactic" arg -end - -let () = add_scope "thunk" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let act e = Tac2quote.thunk (act e) in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "thunk" arg -end - -let add_expr_scope name entry f = - add_scope name begin function - | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) - | arg -> scope_fail name arg - end - -let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) -let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings -let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings -let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern -let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns -let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg -let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause -let () = add_expr_scope "conversion" q_conversion Tac2quote.of_conversion -let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting -let () = add_expr_scope "clause" q_clause Tac2quote.of_clause -let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb -let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences -let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch -let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag -let () = add_expr_scope "reference" q_reference Tac2quote.of_reference -let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location -let () = add_expr_scope "pose" q_pose Tac2quote.of_pose -let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion -let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching -let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching - -let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr -let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr -let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern - -(** seq scope, a bit hairy *) - -open Extend -exception SelfSymbol - -let rec generalize_symbol : - type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function -| Atoken tok -> Atoken tok -| Alist1 e -> Alist1 (generalize_symbol e) -| Alist1sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist1sep (e, sep) -| Alist0 e -> Alist0 (generalize_symbol e) -| Alist0sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist0sep (e, sep) -| Aopt e -> Aopt (generalize_symbol e) -| Aself -> raise SelfSymbol -| Anext -> raise SelfSymbol -| Aentry e -> Aentry e -| Aentryl (e, l) -> Aentryl (e, l) -| Arules r -> Arules r - -type _ converter = -| CvNil : (Loc.t -> raw_tacexpr) converter -| CvCns : 'act converter * ('a -> raw_tacexpr) option -> ('a -> 'act) converter - -let rec apply : type a. a converter -> raw_tacexpr list -> a = function -| CvNil -> fun accu loc -> Tac2quote.of_tuple ~loc accu -| CvCns (c, None) -> fun accu x -> apply c accu -| CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) - -type seqrule = -| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule - -let rec make_seq_rule = function -| [] -> - Seqrule (Stop, CvNil) -| tok :: rem -> - let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in - let scope = generalize_symbol scope in - let Seqrule (r, c) = make_seq_rule rem in - let r = NextNoRec (r, scope) in - let f = match tok with - | SexprStr _ -> None (* Leave out mere strings *) - | _ -> Some f - in - Seqrule (r, CvCns (c, f)) - -let () = add_scope "seq" begin fun toks -> - let scope = - try - let Seqrule (r, c) = make_seq_rule (List.rev toks) in - Arules [Rules (r, apply c [])] - with SelfSymbol -> - CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") - in - Tac2entries.ScopeRule (scope, (fun e -> e)) -end diff --git a/src/tac2core.mli b/src/tac2core.mli deleted file mode 100644 index 9fae65bb3e..0000000000 --- a/src/tac2core.mli +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/src/tac2dyn.ml b/src/tac2dyn.ml deleted file mode 100644 index 896676f08b..0000000000 --- a/src/tac2dyn.ml +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('raw * 'glb) pack - include Arg.Map(struct type 'a t = 'a pack end) -end - -module Val = Dyn.Make(struct end) diff --git a/src/tac2dyn.mli b/src/tac2dyn.mli deleted file mode 100644 index e995296840..0000000000 --- a/src/tac2dyn.mli +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('a, 'b) tag - val eq : ('a1, 'b1) tag -> ('a2, 'b2) tag -> ('a1 * 'b1, 'a2 * 'b2) CSig.eq option - val repr : ('a, 'b) tag -> string -end -(** Arguments that are part of an AST. *) - -module type Param = sig type ('raw, 'glb) t end - -module ArgMap (M : Param) : -sig - type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack - type t - val empty : t - val add : ('a, 'b) Arg.tag -> ('a * 'b) pack -> t -> t - val remove : ('a, 'b) Arg.tag -> t -> t - val find : ('a, 'b) Arg.tag -> t -> ('a * 'b) pack - val mem : ('a, 'b) Arg.tag -> t -> bool -end - -module Val : Dyn.S -(** Toplevel values *) diff --git a/src/tac2entries.ml b/src/tac2entries.ml deleted file mode 100644 index 9fd01426de..0000000000 --- a/src/tac2entries.ml +++ /dev/null @@ -1,938 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = - declare_object {(default_object "TAC2-DEFINITION") with - cache_function = cache_tacdef; - load_function = load_tacdef; - open_function = open_tacdef; - subst_function = subst_tacdef; - classify_function = classify_tacdef} - -(** Type definition *) - -type typdef = { - typdef_local : bool; - typdef_expr : glb_quant_typedef; -} - -let change_kn_label kn id = - let mp = KerName.modpath kn in - KerName.make mp (Label.of_id id) - -let change_sp_label sp id = - let (dp, _) = Libnames.repr_path sp in - Libnames.make_path dp id - -let push_typedef visibility sp kn (_, def) = match def with -| GTydDef _ -> - Tac2env.push_type visibility sp kn -| GTydAlg { galg_constructors = cstrs } -> - (* Register constructors *) - let iter (c, _) = - let spc = change_sp_label sp c in - let knc = change_kn_label kn c in - Tac2env.push_constructor visibility spc knc - in - Tac2env.push_type visibility sp kn; - List.iter iter cstrs -| GTydRec fields -> - (* Register fields *) - let iter (c, _, _) = - let spc = change_sp_label sp c in - let knc = change_kn_label kn c in - Tac2env.push_projection visibility spc knc - in - Tac2env.push_type visibility sp kn; - List.iter iter fields -| GTydOpn -> - Tac2env.push_type visibility sp kn - -let next i = - let ans = !i in - let () = incr i in - ans - -let define_typedef kn (params, def as qdef) = match def with -| GTydDef _ -> - Tac2env.define_type kn qdef -| GTydAlg { galg_constructors = cstrs } -> - (* Define constructors *) - let constant = ref 0 in - let nonconstant = ref 0 in - let iter (c, args) = - let knc = change_kn_label kn c in - let tag = if List.is_empty args then next constant else next nonconstant in - let data = { - Tac2env.cdata_prms = params; - cdata_type = kn; - cdata_args = args; - cdata_indx = Some tag; - } in - Tac2env.define_constructor knc data - in - Tac2env.define_type kn qdef; - List.iter iter cstrs -| GTydRec fs -> - (* Define projections *) - let iter i (id, mut, t) = - let knp = change_kn_label kn id in - let proj = { - Tac2env.pdata_prms = params; - pdata_type = kn; - pdata_ptyp = t; - pdata_mutb = mut; - pdata_indx = i; - } in - Tac2env.define_projection knp proj - in - Tac2env.define_type kn qdef; - List.iteri iter fs -| GTydOpn -> - Tac2env.define_type kn qdef - -let perform_typdef vs ((sp, kn), def) = - let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in - define_typedef kn def.typdef_expr - -let load_typdef i obj = perform_typdef (Until i) obj -let open_typdef i obj = perform_typdef (Exactly i) obj - -let cache_typdef ((sp, kn), def) = - let () = push_typedef (Until 1) sp kn def.typdef_expr in - define_typedef kn def.typdef_expr - -let subst_typdef (subst, def) = - let expr' = subst_quant_typedef subst def.typdef_expr in - if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } - -let classify_typdef o = Substitute o - -let inTypDef : typdef -> obj = - declare_object {(default_object "TAC2-TYPE-DEFINITION") with - cache_function = cache_typdef; - load_function = load_typdef; - open_function = open_typdef; - subst_function = subst_typdef; - classify_function = classify_typdef} - -(** Type extension *) - -type extension_data = { - edata_name : Id.t; - edata_args : int glb_typexpr list; -} - -type typext = { - typext_local : bool; - typext_prms : int; - typext_type : type_constant; - typext_expr : extension_data list; -} - -let push_typext vis sp kn def = - let iter data = - let spc = change_sp_label sp data.edata_name in - let knc = change_kn_label kn data.edata_name in - Tac2env.push_constructor vis spc knc - in - List.iter iter def.typext_expr - -let define_typext kn def = - let iter data = - let knc = change_kn_label kn data.edata_name in - let cdata = { - Tac2env.cdata_prms = def.typext_prms; - cdata_type = def.typext_type; - cdata_args = data.edata_args; - cdata_indx = None; - } in - Tac2env.define_constructor knc cdata - in - List.iter iter def.typext_expr - -let cache_typext ((sp, kn), def) = - let () = define_typext kn def in - push_typext (Until 1) sp kn def - -let perform_typext vs ((sp, kn), def) = - let () = if not def.typext_local then push_typext vs sp kn def in - define_typext kn def - -let load_typext i obj = perform_typext (Until i) obj -let open_typext i obj = perform_typext (Exactly i) obj - -let subst_typext (subst, e) = - let open Mod_subst in - let subst_data data = - let edata_args = List.Smart.map (fun e -> subst_type subst e) data.edata_args in - if edata_args == data.edata_args then data - else { data with edata_args } - in - let typext_type = subst_kn subst e.typext_type in - let typext_expr = List.Smart.map subst_data e.typext_expr in - if typext_type == e.typext_type && typext_expr == e.typext_expr then - e - else - { e with typext_type; typext_expr } - -let classify_typext o = Substitute o - -let inTypExt : typext -> obj = - declare_object {(default_object "TAC2-TYPE-EXTENSION") with - cache_function = cache_typext; - load_function = load_typext; - open_function = open_typext; - subst_function = subst_typext; - classify_function = classify_typext} - -(** Toplevel entries *) - -let fresh_var avoid x = - let bad id = - Id.Set.mem id avoid || - (try ignore (Tac2env.locate_ltac (qualid_of_ident id)); true with Not_found -> false) - in - Namegen.next_ident_away_from (Id.of_string x) bad - -let extract_pattern_type ({loc;v=p} as pat) = match p with -| CPatCnv (pat, ty) -> pat, Some ty -| CPatVar _ | CPatRef _ -> pat, None - -(** Mangle recursive tactics *) -let inline_rec_tactic tactics = - let avoid = List.fold_left (fun accu ({v=id}, _) -> Id.Set.add id accu) Id.Set.empty tactics in - let map (id, e) = match e.v with - | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) - | _ -> - user_err ?loc:id.loc (str "Recursive tactic definitions must be functions") - in - let tactics = List.map map tactics in - let map (id, pat, e) = - let fold_var (avoid, ans) (pat, _) = - let id = fresh_var avoid "x" in - let loc = pat.loc in - (Id.Set.add id avoid, CAst.make ?loc id :: ans) - in - (* Fresh variables to abstract over the function patterns *) - let _, vars = List.fold_left fold_var (avoid, []) pat in - let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in - let bnd = List.map map_body tactics in - let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in - let var_of_id {loc;v=id} = - let qid = qualid_of_ident ?loc id in - CAst.make ?loc @@ CTacRef (RelId qid) - in - let loc0 = e.loc in - let vpat = List.map pat_of_id vars in - let varg = List.map var_of_id vars in - let e = CAst.make ?loc:loc0 @@ CTacLet (true, bnd, CAst.make ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in - (id, CAst.make ?loc:loc0 @@ CTacFun (vpat, e)) - in - List.map map tactics - -let check_lowercase {loc;v=id} = - if Tac2env.is_constructor (Libnames.qualid_of_ident id) then - user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") - -let register_ltac ?(local = false) ?(mut = false) isrec tactics = - let map ({loc;v=na}, e) = - let id = match na with - | Anonymous -> - user_err ?loc (str "Tactic definition must have a name") - | Name id -> id - in - let () = check_lowercase CAst.(make ?loc id) in - (CAst.(make ?loc id), e) - in - let tactics = List.map map tactics in - let tactics = - if isrec then inline_rec_tactic tactics else tactics - in - let map ({loc;v=id}, e) = - let (e, t) = intern ~strict:true e in - let () = - if not (is_value e) then - user_err ?loc (str "Tactic definition must be a syntactical value") - in - let kn = Lib.make_kn id in - let exists = - try let _ = Tac2env.interp_global kn in true with Not_found -> false - in - let () = - if exists then - user_err ?loc (str "Tactic " ++ Names.Id.print id ++ str " already exists") - in - (id, e, t) - in - let defs = List.map map tactics in - let iter (id, e, t) = - let def = { - tacdef_local = local; - tacdef_mutable = mut; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) - in - List.iter iter defs - -let qualid_to_ident qid = - if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid - else user_err ?loc:qid.CAst.loc (str "Identifier expected") - -let register_typedef ?(local = false) isrec types = - let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name types with - | [] -> () - | ({loc;v=id}, _) :: _ -> - user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) - in - let check ({loc;v=id}, (params, def)) = - let same_name {v=id1} {v=id2} = Id.equal id1 id2 in - let () = match List.duplicates same_name params with - | [] -> () - | {loc;v=id} :: _ -> - user_err ?loc (str "The type parameter " ++ Id.print id ++ - str " occurs several times") - in - match def with - | CTydDef _ -> - if isrec then - user_err ?loc (str "The type abbreviation " ++ Id.print id ++ - str " cannot be recursive") - | CTydAlg cs -> - let same_name (id1, _) (id2, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name cs with - | [] -> () - | (id, _) :: _ -> - user_err (str "Multiple definitions of the constructor " ++ Id.print id) - in - () - | CTydRec ps -> - let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name ps with - | [] -> () - | (id, _, _) :: _ -> - user_err (str "Multiple definitions of the projection " ++ Id.print id) - in - () - | CTydOpn -> - if isrec then - user_err ?loc (str "The open type declaration " ++ Id.print id ++ - str " cannot be recursive") - in - let () = List.iter check types in - let self = - if isrec then - let fold accu ({v=id}, (params, _)) = - Id.Map.add id (Lib.make_kn id, List.length params) accu - in - List.fold_left fold Id.Map.empty types - else Id.Map.empty - in - let map ({v=id}, def) = - let typdef = { - typdef_local = local; - typdef_expr = intern_typedef self def; - } in - (id, typdef) - in - let types = List.map map types in - let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in - List.iter iter types - -let register_primitive ?(local = false) {loc;v=id} t ml = - let t = intern_open_type t in - let rec count_arrow = function - | GTypArrow (_, t) -> 1 + count_arrow t - | _ -> 0 - in - let arrows = count_arrow (snd t) in - let () = if Int.equal arrows 0 then - user_err ?loc (str "External tactic must have at least one argument") in - let () = - try let _ = Tac2env.interp_primitive ml in () with Not_found -> - user_err ?loc (str "Unregistered primitive " ++ - quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) - in - let init i = Id.of_string (Printf.sprintf "x%i" i) in - let names = List.init arrows init in - let bnd = List.map (fun id -> Name id) names in - let arg = List.map (fun id -> GTacVar id) names in - let e = GTacFun (bnd, GTacPrm (ml, arg)) in - let def = { - tacdef_local = local; - tacdef_mutable = false; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) - -let register_open ?(local = false) qid (params, def) = - let kn = - try Tac2env.locate_type qid - with Not_found -> - user_err ?loc:qid.CAst.loc (str "Unbound type " ++ pr_qualid qid) - in - let (tparams, t) = Tac2env.interp_type kn in - let () = match t with - | GTydOpn -> () - | GTydAlg _ | GTydRec _ | GTydDef _ -> - user_err ?loc:qid.CAst.loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") - in - let () = - if not (Int.equal (List.length params) tparams) then - Tac2intern.error_nparams_mismatch ?loc:qid.CAst.loc (List.length params) tparams - in - match def with - | CTydOpn -> () - | CTydAlg def -> - let intern_type t = - let tpe = CTydDef (Some t) in - let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in - match ans with - | GTydDef (Some t) -> t - | _ -> assert false - in - let map (id, tpe) = - let tpe = List.map intern_type tpe in - { edata_name = id; edata_args = tpe } - in - let def = List.map map def in - let def = { - typext_local = local; - typext_type = kn; - typext_prms = tparams; - typext_expr = def; - } in - Lib.add_anonymous_leaf (inTypExt def) - | CTydRec _ | CTydDef _ -> - user_err ?loc:qid.CAst.loc (str "Extensions only accept inductive constructors") - -let register_type ?local isrec types = match types with -| [qid, true, def] -> - let () = if isrec then user_err ?loc:qid.CAst.loc (str "Extensions cannot be recursive") in - register_open ?local qid def -| _ -> - let map (qid, redef, def) = - let () = if redef then - user_err ?loc:qid.loc (str "Types can only be extended one by one") - in - (qualid_to_ident qid, def) - in - let types = List.map map types in - register_typedef ?local isrec types - -(** Parsing *) - -type 'a token = -| TacTerm of string -| TacNonTerm of Name.t * 'a - -type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule - -type scope_interpretation = sexpr list -> scope_rule - -let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty - -let register_scope id s = - scope_table := Id.Map.add id s !scope_table - -module ParseToken = -struct - -let loc_of_token = function -| SexprStr {loc} -> loc -| SexprInt {loc} -> loc -| SexprRec (loc, _, _) -> Some loc - -let parse_scope = function -| SexprRec (_, {loc;v=Some id}, toks) -> - if Id.Map.mem id !scope_table then - Id.Map.find id !scope_table toks - else - CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) -| SexprStr {v=str} -> - let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in - ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) -| tok -> - let loc = loc_of_token tok in - CErrors.user_err ?loc (str "Invalid parsing token") - -let parse_token = function -| SexprStr {v=s} -> TacTerm s -| SexprRec (_, {v=na}, [tok]) -> - let na = match na with None -> Anonymous | Some id -> Name id in - let scope = parse_scope tok in - TacNonTerm (na, scope) -| tok -> - let loc = loc_of_token tok in - CErrors.user_err ?loc (str "Invalid parsing token") - -end - -let parse_scope = ParseToken.parse_scope - -type synext = { - synext_tok : sexpr list; - synext_exp : raw_tacexpr; - synext_lev : int option; - synext_loc : bool; -} - -type krule = -| KRule : - (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * - ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule - -let rec get_rule (tok : scope_rule token list) : krule = match tok with -| [] -> KRule (Extend.Stop, fun k loc -> k loc []) -| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> - let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, scope) in - let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in - KRule (rule, act) -| TacTerm t :: tok -> - let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in - let act k _ = act k in - KRule (rule, act) - -let perform_notation syn st = - let tok = List.rev_map ParseToken.parse_token syn.synext_tok in - let KRule (rule, act) = get_rule tok in - let mk loc args = - let map (na, e) = - ((CAst.make ?loc:e.loc @@ CPatVar na), e) - in - let bnd = List.map map args in - CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) - in - let rule = Extend.Rule (rule, act mk) in - let lev = match syn.synext_lev with - | None -> None - | Some lev -> Some (string_of_int lev) - in - let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) - -let ltac2_notation = - Pcoq.create_grammar_command "ltac2-notation" perform_notation - -let cache_synext (_, syn) = - Pcoq.extend_grammar_command ltac2_notation syn - -let open_synext i (_, syn) = - if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn - -let subst_synext (subst, syn) = - let e = Tac2intern.subst_rawexpr subst syn.synext_exp in - if e == syn.synext_exp then syn else { syn with synext_exp = e } - -let classify_synext o = - if o.synext_loc then Dispose else Substitute o - -let inTac2Notation : synext -> obj = - declare_object {(default_object "TAC2-NOTATION") with - cache_function = cache_synext; - open_function = open_synext; - subst_function = subst_synext; - classify_function = classify_synext} - -type abbreviation = { - abbr_body : raw_tacexpr; -} - -let perform_abbreviation visibility ((sp, kn), abbr) = - let () = Tac2env.push_ltac visibility sp (TacAlias kn) in - Tac2env.define_alias kn abbr.abbr_body - -let load_abbreviation i obj = perform_abbreviation (Until i) obj -let open_abbreviation i obj = perform_abbreviation (Exactly i) obj - -let cache_abbreviation ((sp, kn), abbr) = - let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in - Tac2env.define_alias kn abbr.abbr_body - -let subst_abbreviation (subst, abbr) = - let body' = subst_rawexpr subst abbr.abbr_body in - if body' == abbr.abbr_body then abbr - else { abbr_body = body' } - -let classify_abbreviation o = Substitute o - -let inTac2Abbreviation : abbreviation -> obj = - declare_object {(default_object "TAC2-ABBREVIATION") with - cache_function = cache_abbreviation; - load_function = load_abbreviation; - open_function = open_abbreviation; - subst_function = subst_abbreviation; - classify_function = classify_abbreviation} - -let register_notation ?(local = false) tkn lev body = match tkn, lev with -| [SexprRec (_, {loc;v=Some id}, [])], None -> - (* Tactic abbreviation *) - let () = check_lowercase CAst.(make ?loc id) in - let body = Tac2intern.globalize Id.Set.empty body in - let abbr = { abbr_body = body } in - ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) -| _ -> - (* Check that the tokens make sense *) - let entries = List.map ParseToken.parse_token tkn in - let fold accu tok = match tok with - | TacTerm _ -> accu - | TacNonTerm (Name id, _) -> Id.Set.add id accu - | TacNonTerm (Anonymous, _) -> accu - in - let ids = List.fold_left fold Id.Set.empty entries in - (* Globalize so that names are absolute *) - let body = Tac2intern.globalize ids body in - let lev = match lev with Some _ -> lev | None -> Some 5 in - let ext = { - synext_tok = tkn; - synext_exp = body; - synext_lev = lev; - synext_loc = local; - } in - Lib.add_anonymous_leaf (inTac2Notation ext) - -type redefinition = { - redef_kn : ltac_constant; - redef_body : glb_tacexpr; -} - -let perform_redefinition (_, redef) = - let kn = redef.redef_kn in - let data = Tac2env.interp_global kn in - let data = { data with Tac2env.gdata_expr = redef.redef_body } in - Tac2env.define_global kn data - -let subst_redefinition (subst, redef) = - let kn = Mod_subst.subst_kn subst redef.redef_kn in - let body = Tac2intern.subst_expr subst redef.redef_body in - if kn == redef.redef_kn && body == redef.redef_body then redef - else { redef_kn = kn; redef_body = body } - -let classify_redefinition o = Substitute o - -let inTac2Redefinition : redefinition -> obj = - declare_object {(default_object "TAC2-REDEFINITION") with - cache_function = perform_redefinition; - open_function = (fun _ -> perform_redefinition); - subst_function = subst_redefinition; - classify_function = classify_redefinition } - -let register_redefinition ?(local = false) qid e = - let kn = - try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) - in - let kn = match kn with - | TacConstant kn -> kn - | TacAlias _ -> - user_err ?loc:qid.CAst.loc (str "Cannot redefine syntactic abbreviations") - in - let data = Tac2env.interp_global kn in - let () = - if not (data.Tac2env.gdata_mutable) then - user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") - in - let (e, t) = intern ~strict:true e in - let () = - if not (is_value e) then - user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") - in - let () = - if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then - let name = int_name () in - user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ - str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) - in - let def = { - redef_kn = kn; - redef_body = e; - } in - Lib.add_anonymous_leaf (inTac2Redefinition def) - -let perform_eval ~pstate e = - let open Proofview.Notations in - let env = Global.env () in - let (e, ty) = Tac2intern.intern ~strict:false e in - let v = Tac2interp.interp Tac2interp.empty_environment e in - let selector, proof = - match pstate with - | None -> - let sigma = Evd.from_env env in - let name, poly = Id.of_string "ltac2", false in - Goal_select.SelectAll, Proof.start ~name ~poly sigma [] - | Some pstate -> - Goal_select.get_default_goal_selector (), - Proof_global.give_me_the_proof pstate - in - let v = match selector with - | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v - | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v - | Goal_select.SelectId id -> Proofview.tclFOCUSID id v - | Goal_select.SelectAll -> v - | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) - in - (* HACK: the API doesn't allow to return a value *) - let ans = ref None in - let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in - let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in - let sigma = Proof.in_proof proof (fun sigma -> sigma) in - let ans = match !ans with None -> assert false | Some r -> r in - let name = int_name () in - Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) - ++ spc () ++ str "=" ++ spc () ++ - Tac2print.pr_valexpr env sigma ans (snd ty)) - -(** Toplevel entries *) - -let register_struct ?local ~pstate str = match str with -| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e -| StrTyp (isrec, t) -> register_type ?local isrec t -| StrPrm (id, t, ml) -> register_primitive ?local id t ml -| StrSyn (tok, lev, e) -> register_notation ?local tok lev e -| StrMut (qid, e) -> register_redefinition ?local qid e -| StrRun e -> perform_eval ~pstate e - -(** Toplevel exception *) - -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "print Ltac2 backtrace"; - Goptions.optkey = ["Ltac2"; "Backtrace"]; - Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); - Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); -} - -let backtrace : backtrace Exninfo.t = Exninfo.make () - -let pr_frame = function -| FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" -| FrLtac kn -> - str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) -| FrPrim ml -> - str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" -| FrExtn (tag, arg) -> - let obj = Tac2env.interp_ml_object tag in - str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ - obj.Tac2env.ml_print (Global.env ()) arg - -let () = register_handler begin function -| Tac2interp.LtacError (kn, args) -> - let t_exn = KerName.make Tac2env.coq_prefix (Label.make "exn") in - let v = Tac2ffi.of_open (kn, args) in - let t = GTypRef (Other t_exn, []) in - let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in - hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) -| _ -> raise Unhandled -end - -let () = ExplainErr.register_additional_error_info begin fun (e, info) -> - if !Tac2interp.print_ltac2_backtrace then - let bt = Exninfo.get info backtrace in - let bt = match bt with - | Some bt -> bt - | None -> raise Exit - in - let bt = - str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () - in - Some (Loc.tag @@ Some bt) - else raise Exit -end - -(** Printing *) - -let print_ltac qid = - if Tac2env.is_constructor qid then - let kn = - try Tac2env.locate_constructor qid - with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown constructor " ++ pr_qualid qid) - in - let _ = Tac2env.interp_constructor kn in - Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) - else - let kn = - try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) - in - match kn with - | TacConstant kn -> - let data = Tac2env.interp_global kn in - let e = data.Tac2env.gdata_expr in - let (_, t) = data.Tac2env.gdata_type in - let name = int_name () in - Feedback.msg_notice ( - hov 0 ( - hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ - hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) - ) - ) - | TacAlias kn -> - Feedback.msg_notice (str "Alias to ...") - -(** Calling tactics *) - -let solve ~pstate default tac = - let pstate, status = Proof_global.with_current_proof begin fun etac p -> - let with_end_tac = if default then Some etac else None in - let g = Goal_select.get_default_goal_selector () in - let (p, status) = Pfedit.solve g None tac ?with_end_tac p in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p, status - end pstate in - if not status then Feedback.feedback Feedback.AddedAxiom; - pstate - -let call ~pstate ~default e = - let loc = e.loc in - let (e, t) = intern ~strict:false e in - let () = check_unit ?loc t in - let tac = Tac2interp.interp Tac2interp.empty_environment e in - solve ~pstate default (Proofview.tclIGNORE tac) - -(** Primitive algebraic types than can't be defined Coq-side *) - -let register_prim_alg name params def = - let id = Id.of_string name in - let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in - let getn (const, nonconst) (c, args) = match args with - | [] -> (succ const, nonconst) - | _ :: _ -> (const, succ nonconst) - in - let nconst, nnonconst = List.fold_left getn (0, 0) def in - let alg = { - galg_constructors = def; - galg_nconst = nconst; - galg_nnonconst = nnonconst; - } in - let def = (params, GTydAlg alg) in - let def = { typdef_local = false; typdef_expr = def } in - ignore (Lib.add_leaf id (inTypDef def)) - -let coq_def n = KerName.make Tac2env.coq_prefix (Label.make n) - -let def_unit = { - typdef_local = false; - typdef_expr = 0, GTydDef (Some (GTypRef (Tuple 0, []))); -} - -let t_list = coq_def "list" - -let (f_register_constr_quotations, register_constr_quotations) = Hook.make () - -let cache_ltac2_init (_, ()) = - Hook.get f_register_constr_quotations () - -let load_ltac2_init _ (_, ()) = - Hook.get f_register_constr_quotations () - -let open_ltac2_init _ (_, ()) = - Goptions.set_string_option_value_gen ["Default"; "Proof"; "Mode"] "Ltac2" - -(** Dummy object that register global rules when Require is called *) -let inTac2Init : unit -> obj = - declare_object {(default_object "TAC2-INIT") with - cache_function = cache_ltac2_init; - load_function = load_ltac2_init; - open_function = open_ltac2_init; - } - -let _ = Mltop.declare_cache_obj begin fun () -> - ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); - register_prim_alg "list" 1 [ - ("[]", []); - ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); - ]; - Lib.add_anonymous_leaf (inTac2Init ()); -end "ltac2_plugin" diff --git a/src/tac2entries.mli b/src/tac2entries.mli deleted file mode 100644 index d493192bb3..0000000000 --- a/src/tac2entries.mli +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?mut:bool -> rec_flag -> - (Names.lname * raw_tacexpr) list -> unit - -val register_type : ?local:bool -> rec_flag -> - (qualid * redef_flag * raw_quant_typedef) list -> unit - -val register_primitive : ?local:bool -> - Names.lident -> raw_typexpr -> ml_tactic_name -> unit - -val register_struct - : ?local:bool - -> pstate:Proof_global.t option - -> strexpr - -> unit - -val register_notation : ?local:bool -> sexpr list -> int option -> - raw_tacexpr -> unit - -(** {5 Notations} *) - -type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule - -type scope_interpretation = sexpr list -> scope_rule - -val register_scope : Id.t -> scope_interpretation -> unit -(** Create a new scope with the provided name *) - -val parse_scope : sexpr -> scope_rule -(** Use this to interpret the subscopes for interpretation functions *) - -(** {5 Inspecting} *) - -val print_ltac : Libnames.qualid -> unit - -(** {5 Eval loop} *) - -(** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t - -(** {5 Toplevel exceptions} *) - -val backtrace : backtrace Exninfo.t - -(** {5 Parsing entries} *) - -module Pltac : -sig -val tac2expr : raw_tacexpr Pcoq.Entry.t - -(** Quoted entries. To be used for complex notations. *) - -open Tac2qexpr - -val q_ident : Id.t CAst.t or_anti Pcoq.Entry.t -val q_bindings : bindings Pcoq.Entry.t -val q_with_bindings : bindings Pcoq.Entry.t -val q_intropattern : intro_pattern Pcoq.Entry.t -val q_intropatterns : intro_pattern list CAst.t Pcoq.Entry.t -val q_destruction_arg : destruction_arg Pcoq.Entry.t -val q_induction_clause : induction_clause Pcoq.Entry.t -val q_conversion : conversion Pcoq.Entry.t -val q_rewriting : rewriting Pcoq.Entry.t -val q_clause : clause Pcoq.Entry.t -val q_dispatch : dispatch Pcoq.Entry.t -val q_occurrences : occurrences Pcoq.Entry.t -val q_reference : reference or_anti Pcoq.Entry.t -val q_strategy_flag : strategy_flag Pcoq.Entry.t -val q_constr_matching : constr_matching Pcoq.Entry.t -val q_goal_matching : goal_matching Pcoq.Entry.t -val q_hintdb : hintdb Pcoq.Entry.t -val q_move_location : move_location Pcoq.Entry.t -val q_pose : pose Pcoq.Entry.t -val q_assert : assertion Pcoq.Entry.t -end - -(** {5 Hooks} *) - -val register_constr_quotations : (unit -> unit) Hook.t diff --git a/src/tac2env.ml b/src/tac2env.ml deleted file mode 100644 index 93ad57e97e..0000000000 --- a/src/tac2env.ml +++ /dev/null @@ -1,298 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* KerName.compare c1 c2 -| TacAlias c1, TacAlias c2 -> KerName.compare c1 c2 -| TacConstant _, TacAlias _ -> -1 -| TacAlias _, TacConstant _ -> 1 - -let equal r1 r2 = compare r1 r2 == 0 - -end - -module KnTab = Nametab.Make(FullPath)(KerName) -module RfTab = Nametab.Make(FullPath)(TacRef) -module RfMap = Map.Make(TacRef) - -type nametab = { - tab_ltac : RfTab.t; - tab_ltac_rev : full_path RfMap.t; - tab_cstr : KnTab.t; - tab_cstr_rev : full_path KNmap.t; - tab_type : KnTab.t; - tab_type_rev : full_path KNmap.t; - tab_proj : KnTab.t; - tab_proj_rev : full_path KNmap.t; -} - -let empty_nametab = { - tab_ltac = RfTab.empty; - tab_ltac_rev = RfMap.empty; - tab_cstr = KnTab.empty; - tab_cstr_rev = KNmap.empty; - tab_type = KnTab.empty; - tab_type_rev = KNmap.empty; - tab_proj = KnTab.empty; - tab_proj_rev = KNmap.empty; -} - -let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" - -let push_ltac vis sp kn = - let tab = !nametab in - let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in - let tab_ltac_rev = RfMap.add kn sp tab.tab_ltac_rev in - nametab := { tab with tab_ltac; tab_ltac_rev } - -let locate_ltac qid = - let tab = !nametab in - RfTab.locate qid tab.tab_ltac - -let locate_extended_all_ltac qid = - let tab = !nametab in - RfTab.find_prefixes qid tab.tab_ltac - -let shortest_qualid_of_ltac kn = - let tab = !nametab in - let sp = RfMap.find kn tab.tab_ltac_rev in - RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac - -let push_constructor vis sp kn = - let tab = !nametab in - let tab_cstr = KnTab.push vis sp kn tab.tab_cstr in - let tab_cstr_rev = KNmap.add kn sp tab.tab_cstr_rev in - nametab := { tab with tab_cstr; tab_cstr_rev } - -let locate_constructor qid = - let tab = !nametab in - KnTab.locate qid tab.tab_cstr - -let locate_extended_all_constructor qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_cstr - -let shortest_qualid_of_constructor kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_cstr_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr - -let push_type vis sp kn = - let tab = !nametab in - let tab_type = KnTab.push vis sp kn tab.tab_type in - let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in - nametab := { tab with tab_type; tab_type_rev } - -let locate_type qid = - let tab = !nametab in - KnTab.locate qid tab.tab_type - -let locate_extended_all_type qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_type - -let shortest_qualid_of_type ?loc kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_type_rev in - KnTab.shortest_qualid ?loc Id.Set.empty sp tab.tab_type - -let push_projection vis sp kn = - let tab = !nametab in - let tab_proj = KnTab.push vis sp kn tab.tab_proj in - let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in - nametab := { tab with tab_proj; tab_proj_rev } - -let locate_projection qid = - let tab = !nametab in - KnTab.locate qid tab.tab_proj - -let locate_extended_all_projection qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_proj - -let shortest_qualid_of_projection kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_proj_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj - -type 'a or_glb_tacexpr = -| GlbVal of 'a -| GlbTacexpr of glb_tacexpr - -type environment = { - env_ist : valexpr Id.Map.t; -} - -type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr - -type ('a, 'b) ml_object = { - ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; - ml_subst : Mod_subst.substitution -> 'b -> 'b; - ml_interp : environment -> 'b -> valexpr Proofview.tactic; - ml_print : Environ.env -> 'b -> Pp.t; -} - -module MLTypeObj = -struct - type ('a, 'b) t = ('a, 'b) ml_object -end - -module MLType = Tac2dyn.ArgMap(MLTypeObj) - -let ml_object_table = ref MLType.empty - -let define_ml_object t tpe = - ml_object_table := MLType.add t (MLType.Pack tpe) !ml_object_table - -let interp_ml_object t = - try - let MLType.Pack ans = MLType.find t !ml_object_table in - ans - with Not_found -> - CErrors.anomaly Pp.(str "Unknown object type " ++ str (Tac2dyn.Arg.repr t)) - -(** Absolute paths *) - -let coq_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) - -let std_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) - -let ltac1_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Ltac1"; "Ltac2"])) - -(** Generic arguments *) - -let wit_ltac2 = Genarg.make0 "ltac2:value" -let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" -let () = Geninterp.register_val0 wit_ltac2 None -let () = Geninterp.register_val0 wit_ltac2_quotation None - -let is_constructor qid = - let (_, id) = repr_qualid qid in - let id = Id.to_string id in - assert (String.length id > 0); - match id with - | "true" | "false" -> true (* built-in constructors *) - | _ -> - match id.[0] with - | 'A'..'Z' -> true - | _ -> false diff --git a/src/tac2env.mli b/src/tac2env.mli deleted file mode 100644 index c7e87c5432..0000000000 --- a/src/tac2env.mli +++ /dev/null @@ -1,146 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* global_data -> unit -val interp_global : ltac_constant -> global_data - -(** {5 Toplevel definition of types} *) - -val define_type : type_constant -> glb_quant_typedef -> unit -val interp_type : type_constant -> glb_quant_typedef - -(** {5 Toplevel definition of algebraic constructors} *) - -type constructor_data = { - cdata_prms : int; - (** Type parameters *) - cdata_type : type_constant; - (** Inductive definition to which the constructor pertains *) - cdata_args : int glb_typexpr list; - (** Types of the constructor arguments *) - cdata_indx : int option; - (** Index of the constructor in the ADT. Numbering is duplicated between - argumentless and argument-using constructors, e.g. in type ['a option] - [None] and [Some] have both index 0. This field is empty whenever the - constructor is a member of an open type. *) -} - -val define_constructor : ltac_constructor -> constructor_data -> unit -val interp_constructor : ltac_constructor -> constructor_data - -(** {5 Toplevel definition of projections} *) - -type projection_data = { - pdata_prms : int; - (** Type parameters *) - pdata_type : type_constant; - (** Record definition to which the projection pertains *) - pdata_ptyp : int glb_typexpr; - (** Type of the projection *) - pdata_mutb : bool; - (** Whether the field is mutable *) - pdata_indx : int; - (** Index of the projection *) -} - -val define_projection : ltac_projection -> projection_data -> unit -val interp_projection : ltac_projection -> projection_data - -(** {5 Toplevel definition of aliases} *) - -val define_alias : ltac_constant -> raw_tacexpr -> unit -val interp_alias : ltac_constant -> raw_tacexpr - -(** {5 Name management} *) - -val push_ltac : visibility -> full_path -> tacref -> unit -val locate_ltac : qualid -> tacref -val locate_extended_all_ltac : qualid -> tacref list -val shortest_qualid_of_ltac : tacref -> qualid - -val push_constructor : visibility -> full_path -> ltac_constructor -> unit -val locate_constructor : qualid -> ltac_constructor -val locate_extended_all_constructor : qualid -> ltac_constructor list -val shortest_qualid_of_constructor : ltac_constructor -> qualid - -val push_type : visibility -> full_path -> type_constant -> unit -val locate_type : qualid -> type_constant -val locate_extended_all_type : qualid -> type_constant list -val shortest_qualid_of_type : ?loc:Loc.t -> type_constant -> qualid - -val push_projection : visibility -> full_path -> ltac_projection -> unit -val locate_projection : qualid -> ltac_projection -val locate_extended_all_projection : qualid -> ltac_projection list -val shortest_qualid_of_projection : ltac_projection -> qualid - -(** {5 Toplevel definitions of ML tactics} *) - -(** This state is not part of the summary, contrarily to the ones above. It is - intended to be used from ML plugins to register ML-side functions. *) - -val define_primitive : ml_tactic_name -> closure -> unit -val interp_primitive : ml_tactic_name -> closure - -(** {5 ML primitive types} *) - -type 'a or_glb_tacexpr = -| GlbVal of 'a -| GlbTacexpr of glb_tacexpr - -type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr - -type environment = { - env_ist : valexpr Id.Map.t; -} - -type ('a, 'b) ml_object = { - ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; - ml_subst : Mod_subst.substitution -> 'b -> 'b; - ml_interp : environment -> 'b -> valexpr Proofview.tactic; - ml_print : Environ.env -> 'b -> Pp.t; -} - -val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit -val interp_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object - -(** {5 Absolute paths} *) - -val coq_prefix : ModPath.t -(** Path where primitive datatypes are defined in Ltac2 plugin. *) - -val std_prefix : ModPath.t -(** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) - -val ltac1_prefix : ModPath.t -(** Path where the Ltac1 legacy FFI is defined. *) - -(** {5 Generic arguments} *) - -val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type -val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type - -(** {5 Helper functions} *) - -val is_constructor : qualid -> bool diff --git a/src/tac2expr.mli b/src/tac2expr.mli deleted file mode 100644 index 1069d0bfa3..0000000000 --- a/src/tac2expr.mli +++ /dev/null @@ -1,190 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_tacexpr_r - -and raw_tacexpr = raw_tacexpr_r CAst.t - -and raw_taccase = raw_patexpr * raw_tacexpr - -and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list - -type case_info = type_constant or_tuple - -type 'a open_match = { - opn_match : 'a; - opn_branch : (Name.t * Name.t array * 'a) KNmap.t; - (** Invariant: should not be empty *) - opn_default : Name.t * 'a; -} - -type glb_tacexpr = -| GTacAtm of atom -| GTacVar of Id.t -| GTacRef of ltac_constant -| GTacFun of Name.t list * glb_tacexpr -| GTacApp of glb_tacexpr * glb_tacexpr list -| GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr -| GTacCst of case_info * int * glb_tacexpr list -| GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array -| GTacPrj of type_constant * glb_tacexpr * int -| GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr -| GTacOpn of ltac_constructor * glb_tacexpr list -| GTacWth of glb_tacexpr open_match -| GTacExt : (_, 'a) Tac2dyn.Arg.tag * 'a -> glb_tacexpr -| GTacPrm of ml_tactic_name * glb_tacexpr list - -(** {5 Parsing & Printing} *) - -type exp_level = -| E5 -| E4 -| E3 -| E2 -| E1 -| E0 - -type sexpr = -| SexprStr of string CAst.t -| SexprInt of int CAst.t -| SexprRec of Loc.t * Id.t option CAst.t * sexpr list - -(** {5 Toplevel statements} *) - -type strexpr = -| StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list - (** Term definition *) -| StrTyp of rec_flag * (qualid * redef_flag * raw_quant_typedef) list - (** Type definition *) -| StrPrm of Names.lident * raw_typexpr * ml_tactic_name - (** External definition *) -| StrSyn of sexpr list * int option * raw_tacexpr - (** Syntactic extensions *) -| StrMut of qualid * raw_tacexpr - (** Redefinition of mutable globals *) -| StrRun of raw_tacexpr - (** Toplevel evaluation of an expression *) - -(** {5 Dynamic semantics} *) - -(** Values are represented in a way similar to OCaml, i.e. they constrast - immediate integers (integers, constructors without arguments) and structured - blocks (tuples, arrays, constructors with arguments), as well as a few other - base cases, namely closures, strings, named constructors, and dynamic type - coming from the Coq implementation. *) - -type tag = int - -type frame = -| FrLtac of ltac_constant -| FrAnon of glb_tacexpr -| FrPrim of ml_tactic_name -| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame - -type backtrace = frame list diff --git a/src/tac2extffi.ml b/src/tac2extffi.ml deleted file mode 100644 index 315c970f9e..0000000000 --- a/src/tac2extffi.ml +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false) f - -(** More ML representations *) - -let to_qhyp v = match Value.to_block v with -| (0, [| i |]) -> AnonHyp (Value.to_int i) -| (1, [| id |]) -> NamedHyp (Value.to_ident id) -| _ -> assert false - -let qhyp = make_to_repr to_qhyp - -let to_bindings = function -| ValInt 0 -> NoBindings -| ValBlk (0, [| vl |]) -> - ImplicitBindings (Value.to_list Value.to_constr vl) -| ValBlk (1, [| vl |]) -> - ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) -| _ -> assert false - -let bindings = make_to_repr to_bindings - -let to_constr_with_bindings v = match Value.to_tuple v with -| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) -| _ -> assert false - -let constr_with_bindings = make_to_repr to_constr_with_bindings diff --git a/src/tac2extffi.mli b/src/tac2extffi.mli deleted file mode 100644 index f5251c3d0d..0000000000 --- a/src/tac2extffi.mli +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a Proofview.tactic) arity0 -| AddAty : ('a, 'b) arity0 -> ('a, 'a -> 'b) arity0 - -type valexpr = -| ValInt of int - (** Immediate integers *) -| ValBlk of tag * valexpr array - (** Structured blocks *) -| ValStr of Bytes.t - (** Strings *) -| ValCls of closure - (** Closures *) -| ValOpn of KerName.t * valexpr array - (** Open constructors *) -| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr - (** Arbitrary data *) - -and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure - -let arity_one = OneAty -let arity_suc a = AddAty a - -type 'a arity = (valexpr, 'a) arity0 - -let mk_closure arity f = MLTactic (arity, f) - -module Valexpr = -struct - -type t = valexpr - -let is_int = function -| ValInt _ -> true -| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false - -let tag v = match v with -| ValBlk (n, _) -> n -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> - CErrors.anomaly (Pp.str "Unexpected value shape") - -let field v n = match v with -| ValBlk (_, v) -> v.(n) -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> - CErrors.anomaly (Pp.str "Unexpected value shape") - -let set_field v n w = match v with -| ValBlk (_, v) -> v.(n) <- w -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> - CErrors.anomaly (Pp.str "Unexpected value shape") - -let make_block tag v = ValBlk (tag, v) -let make_int n = ValInt n - -end - -type 'a repr = { - r_of : 'a -> valexpr; - r_to : valexpr -> 'a; - r_id : bool; -} - -let repr_of r x = r.r_of x -let repr_to r x = r.r_to x - -let make_repr r_of r_to = { r_of; r_to; r_id = false; } - -(** Dynamic tags *) - -let val_exn = Val.create "exn" -let val_constr = Val.create "constr" -let val_ident = Val.create "ident" -let val_pattern = Val.create "pattern" -let val_pp = Val.create "pp" -let val_sort = Val.create "sort" -let val_cast = Val.create "cast" -let val_inductive = Val.create "inductive" -let val_constant = Val.create "constant" -let val_constructor = Val.create "constructor" -let val_projection = Val.create "projection" -let val_case = Val.create "case" -let val_univ = Val.create "universe" -let val_free : Names.Id.Set.t Val.tag = Val.create "free" -let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" - -let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = -match Val.eq tag tag' with -| None -> assert false -| Some Refl -> v - -(** Exception *) - -exception LtacError of KerName.t * valexpr array - -(** Conversion functions *) - -let valexpr = { - r_of = (fun obj -> obj); - r_to = (fun obj -> obj); - r_id = true; -} - -let of_unit () = ValInt 0 - -let to_unit = function -| ValInt 0 -> () -| _ -> assert false - -let unit = { - r_of = of_unit; - r_to = to_unit; - r_id = false; -} - -let of_int n = ValInt n -let to_int = function -| ValInt n -> n -| _ -> assert false - -let int = { - r_of = of_int; - r_to = to_int; - r_id = false; -} - -let of_bool b = if b then ValInt 0 else ValInt 1 - -let to_bool = function -| ValInt 0 -> true -| ValInt 1 -> false -| _ -> assert false - -let bool = { - r_of = of_bool; - r_to = to_bool; - r_id = false; -} - -let of_char n = ValInt (Char.code n) -let to_char = function -| ValInt n -> Char.chr n -| _ -> assert false - -let char = { - r_of = of_char; - r_to = to_char; - r_id = false; -} - -let of_string s = ValStr s -let to_string = function -| ValStr s -> s -| _ -> assert false - -let string = { - r_of = of_string; - r_to = to_string; - r_id = false; -} - -let rec of_list f = function -| [] -> ValInt 0 -| x :: l -> ValBlk (0, [| f x; of_list f l |]) - -let rec to_list f = function -| ValInt 0 -> [] -| ValBlk (0, [|v; vl|]) -> f v :: to_list f vl -| _ -> assert false - -let list r = { - r_of = (fun l -> of_list r.r_of l); - r_to = (fun l -> to_list r.r_to l); - r_id = false; -} - -let of_closure cls = ValCls cls - -let to_closure = function -| ValCls cls -> cls -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false - -let closure = { - r_of = of_closure; - r_to = to_closure; - r_id = false; -} - -let of_ext tag c = - ValExt (tag, c) - -let to_ext tag = function -| ValExt (tag', e) -> extract_val tag tag' e -| _ -> assert false - -let repr_ext tag = { - r_of = (fun e -> of_ext tag e); - r_to = (fun e -> to_ext tag e); - r_id = false; -} - -let of_constr c = of_ext val_constr c -let to_constr c = to_ext val_constr c -let constr = repr_ext val_constr - -let of_ident c = of_ext val_ident c -let to_ident c = to_ext val_ident c -let ident = repr_ext val_ident - -let of_pattern c = of_ext val_pattern c -let to_pattern c = to_ext val_pattern c -let pattern = repr_ext val_pattern - -let internal_err = - let open Names in - let coq_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) - in - KerName.make coq_prefix (Label.of_id (Id.of_string "Internal")) - -(** FIXME: handle backtrace in Ltac2 exceptions *) -let of_exn c = match fst c with -| LtacError (kn, c) -> ValOpn (kn, c) -| _ -> ValOpn (internal_err, [|of_ext val_exn c|]) - -let to_exn c = match c with -| ValOpn (kn, c) -> - if Names.KerName.equal kn internal_err then - to_ext val_exn c.(0) - else - (LtacError (kn, c), Exninfo.null) -| _ -> assert false - -let exn = { - r_of = of_exn; - r_to = to_exn; - r_id = false; -} - -let of_option f = function -| None -> ValInt 0 -| Some c -> ValBlk (0, [|f c|]) - -let to_option f = function -| ValInt 0 -> None -| ValBlk (0, [|c|]) -> Some (f c) -| _ -> assert false - -let option r = { - r_of = (fun l -> of_option r.r_of l); - r_to = (fun l -> to_option r.r_to l); - r_id = false; -} - -let of_pp c = of_ext val_pp c -let to_pp c = to_ext val_pp c -let pp = repr_ext val_pp - -let of_tuple cl = ValBlk (0, cl) -let to_tuple = function -| ValBlk (0, cl) -> cl -| _ -> assert false - -let of_pair f g (x, y) = ValBlk (0, [|f x; g y|]) -let to_pair f g = function -| ValBlk (0, [|x; y|]) -> (f x, g y) -| _ -> assert false -let pair r0 r1 = { - r_of = (fun p -> of_pair r0.r_of r1.r_of p); - r_to = (fun p -> to_pair r0.r_to r1.r_to p); - r_id = false; -} - -let of_array f vl = ValBlk (0, Array.map f vl) -let to_array f = function -| ValBlk (0, vl) -> Array.map f vl -| _ -> assert false -let array r = { - r_of = (fun l -> of_array r.r_of l); - r_to = (fun l -> to_array r.r_to l); - r_id = false; -} - -let of_block (n, args) = ValBlk (n, args) -let to_block = function -| ValBlk (n, args) -> (n, args) -| _ -> assert false - -let block = { - r_of = of_block; - r_to = to_block; - r_id = false; -} - -let of_open (kn, args) = ValOpn (kn, args) - -let to_open = function -| ValOpn (kn, args) -> (kn, args) -| _ -> assert false - -let open_ = { - r_of = of_open; - r_to = to_open; - r_id = false; -} - -let of_constant c = of_ext val_constant c -let to_constant c = to_ext val_constant c -let constant = repr_ext val_constant - -let of_reference = function -| VarRef id -> ValBlk (0, [| of_ident id |]) -| ConstRef cst -> ValBlk (1, [| of_constant cst |]) -| IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) -| ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) - -let to_reference = function -| ValBlk (0, [| id |]) -> VarRef (to_ident id) -| ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) -| ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) -| ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) -| _ -> assert false - -let reference = { - r_of = of_reference; - r_to = to_reference; - r_id = false; -} - -type ('a, 'b) fun1 = closure - -let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure -let to_fun1 r0 r1 f = to_closure f - -let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = - fun arity f args -> match args, arity with - | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) - (* A few hardcoded cases for efficiency *) - | [a0], OneAty -> f a0 - | [a0; a1], AddAty OneAty -> f a0 a1 - | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 - | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 - (* Generic cases *) - | a :: args, OneAty -> - f a >>= fun f -> - let MLTactic (arity, f) = to_closure f in - apply arity f args - | a :: args, AddAty arity -> - apply arity (f a) args - -let apply (MLTactic (arity, f)) args = apply arity f args - -type n_closure = -| NClosure : 'a arity * (valexpr list -> 'a) -> n_closure - -let rec abstract n f = - if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) - else - let NClosure (arity, fe) = abstract (n - 1) f in - NClosure (AddAty arity, fun accu v -> fe (v :: accu)) - -let abstract n f = - let () = assert (n > 0) in - let NClosure (arity, f) = abstract n f in - MLTactic (arity, f []) - -let app_fun1 cls r0 r1 x = - apply cls [r0.r_of x] >>= fun v -> Proofview.tclUNIT (r1.r_to v) diff --git a/src/tac2ffi.mli b/src/tac2ffi.mli deleted file mode 100644 index bfc93d99e6..0000000000 --- a/src/tac2ffi.mli +++ /dev/null @@ -1,189 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* valexpr - (** Arbitrary data *) - -type 'a arity - -val arity_one : (valexpr -> valexpr Proofview.tactic) arity -val arity_suc : 'a arity -> (valexpr -> 'a) arity - -val mk_closure : 'v arity -> 'v -> closure - -module Valexpr : -sig - type t = valexpr - val is_int : t -> bool - val tag : t -> int - val field : t -> int -> t - val set_field : t -> int -> t -> unit - val make_block : int -> t array -> t - val make_int : int -> t -end - -(** {5 Ltac2 FFI} *) - -type 'a repr - -val repr_of : 'a repr -> 'a -> valexpr -val repr_to : 'a repr -> valexpr -> 'a - -val make_repr : ('a -> valexpr) -> (valexpr -> 'a) -> 'a repr - -(** These functions allow to convert back and forth between OCaml and Ltac2 - data representation. The [to_*] functions raise an anomaly whenever the data - has not expected shape. *) - -val of_unit : unit -> valexpr -val to_unit : valexpr -> unit -val unit : unit repr - -val of_int : int -> valexpr -val to_int : valexpr -> int -val int : int repr - -val of_bool : bool -> valexpr -val to_bool : valexpr -> bool -val bool : bool repr - -val of_char : char -> valexpr -val to_char : valexpr -> char -val char : char repr - -val of_string : Bytes.t -> valexpr -val to_string : valexpr -> Bytes.t -val string : Bytes.t repr - -val of_list : ('a -> valexpr) -> 'a list -> valexpr -val to_list : (valexpr -> 'a) -> valexpr -> 'a list -val list : 'a repr -> 'a list repr - -val of_constr : EConstr.t -> valexpr -val to_constr : valexpr -> EConstr.t -val constr : EConstr.t repr - -val of_exn : Exninfo.iexn -> valexpr -val to_exn : valexpr -> Exninfo.iexn -val exn : Exninfo.iexn repr - -val of_ident : Id.t -> valexpr -val to_ident : valexpr -> Id.t -val ident : Id.t repr - -val of_closure : closure -> valexpr -val to_closure : valexpr -> closure -val closure : closure repr - -val of_block : (int * valexpr array) -> valexpr -val to_block : valexpr -> (int * valexpr array) -val block : (int * valexpr array) repr - -val of_array : ('a -> valexpr) -> 'a array -> valexpr -val to_array : (valexpr -> 'a) -> valexpr -> 'a array -val array : 'a repr -> 'a array repr - -val of_tuple : valexpr array -> valexpr -val to_tuple : valexpr -> valexpr array - -val of_pair : ('a -> valexpr) -> ('b -> valexpr) -> 'a * 'b -> valexpr -val to_pair : (valexpr -> 'a) -> (valexpr -> 'b) -> valexpr -> 'a * 'b -val pair : 'a repr -> 'b repr -> ('a * 'b) repr - -val of_option : ('a -> valexpr) -> 'a option -> valexpr -val to_option : (valexpr -> 'a) -> valexpr -> 'a option -val option : 'a repr -> 'a option repr - -val of_pattern : Pattern.constr_pattern -> valexpr -val to_pattern : valexpr -> Pattern.constr_pattern -val pattern : Pattern.constr_pattern repr - -val of_pp : Pp.t -> valexpr -val to_pp : valexpr -> Pp.t -val pp : Pp.t repr - -val of_constant : Constant.t -> valexpr -val to_constant : valexpr -> Constant.t -val constant : Constant.t repr - -val of_reference : GlobRef.t -> valexpr -val to_reference : valexpr -> GlobRef.t -val reference : GlobRef.t repr - -val of_ext : 'a Val.tag -> 'a -> valexpr -val to_ext : 'a Val.tag -> valexpr -> 'a -val repr_ext : 'a Val.tag -> 'a repr - -val of_open : KerName.t * valexpr array -> valexpr -val to_open : valexpr -> KerName.t * valexpr array -val open_ : (KerName.t * valexpr array) repr - -type ('a, 'b) fun1 - -val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic - -val to_fun1 : 'a repr -> 'b repr -> valexpr -> ('a, 'b) fun1 -val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr - -val valexpr : valexpr repr - -(** {5 Dynamic tags} *) - -val val_constr : EConstr.t Val.tag -val val_ident : Id.t Val.tag -val val_pattern : Pattern.constr_pattern Val.tag -val val_pp : Pp.t Val.tag -val val_sort : ESorts.t Val.tag -val val_cast : Constr.cast_kind Val.tag -val val_inductive : inductive Val.tag -val val_constant : Constant.t Val.tag -val val_constructor : constructor Val.tag -val val_projection : Projection.t Val.tag -val val_case : Constr.case_info Val.tag -val val_univ : Univ.Level.t Val.tag -val val_free : Id.Set.t Val.tag -val val_ltac1 : Geninterp.Val.t Val.tag - -val val_exn : Exninfo.iexn Tac2dyn.Val.tag -(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] - should be put into a value with tag [val_exn]. *) - -(** Closures *) - -val apply : closure -> valexpr list -> valexpr Proofview.tactic -(** Given a closure, apply it to some arguments. Handling of argument mismatches - is done automatically, i.e. in case of over or under-application. *) - -val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> closure -(** Turn a fixed-arity function into a closure. The inner function is guaranteed - to be applied to a list whose size is the integer argument. *) - -(** Exception *) - -exception LtacError of KerName.t * valexpr array -(** Ltac2-defined exceptions seen from OCaml side *) diff --git a/src/tac2intern.ml b/src/tac2intern.ml deleted file mode 100644 index de99fb167f..0000000000 --- a/src/tac2intern.ml +++ /dev/null @@ -1,1545 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* elt -> bool -val create : unit -> 'a t -val fresh : 'a t -> elt -val find : elt -> 'a t -> (elt * 'a option) -val union : elt -> elt -> 'a t -> unit -val set : elt -> 'a -> 'a t -> unit -module Map : -sig - type key = elt - type +'a t - val empty : 'a t - val add : key -> 'a -> 'a t -> 'a t - val mem : key -> 'a t -> bool - val find : key -> 'a t -> 'a - val exists : (key -> 'a -> bool) -> 'a t -> bool -end -end -= -struct -type elt = int -let equal = Int.equal -module Map = Int.Map - -type 'a node = -| Canon of int * 'a option -| Equiv of elt - -type 'a t = { - mutable uf_data : 'a node array; - mutable uf_size : int; -} - -let resize p = - if Int.equal (Array.length p.uf_data) p.uf_size then begin - let nsize = 2 * p.uf_size + 1 in - let v = Array.make nsize (Equiv 0) in - Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); - p.uf_data <- v; - end - -let create () = { uf_data = [||]; uf_size = 0 } - -let fresh p = - resize p; - let n = p.uf_size in - p.uf_data.(n) <- (Canon (1, None)); - p.uf_size <- n + 1; - n - -let rec lookup n p = - let node = Array.get p.uf_data n in - match node with - | Canon (size, v) -> n, size, v - | Equiv y -> - let ((z, _, _) as res) = lookup y p in - if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); - res - -let find n p = - let (x, _, v) = lookup n p in (x, v) - -let union x y p = - let ((x, size1, _) as xcan) = lookup x p in - let ((y, size2, _) as ycan) = lookup y p in - let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in - let x, _, xnode = xcan in - let y, _, ynode = ycan in - assert (Option.is_empty xnode); - assert (Option.is_empty ynode); - p.uf_data.(x) <- Equiv y; - p.uf_data.(y) <- Canon (size1 + size2, None) - -let set x v p = - let (x, s, v') = lookup x p in - assert (Option.is_empty v'); - p.uf_data.(x) <- Canon (s, Some v) - -end - -type mix_var = -| GVar of UF.elt -| LVar of int - -type mix_type_scheme = int * mix_var glb_typexpr - -type environment = { - env_var : mix_type_scheme Id.Map.t; - (** Type schemes of bound variables *) - env_cst : UF.elt glb_typexpr UF.t; - (** Unification state *) - env_als : UF.elt Id.Map.t ref; - (** Map user-facing type variables to unification variables *) - env_opn : bool; - (** Accept unbound type variables *) - env_rec : (KerName.t * int) Id.Map.t; - (** Recursive type definitions *) - env_str : bool; - (** True iff in strict mode *) -} - -let empty_env () = { - env_var = Id.Map.empty; - env_cst = UF.create (); - env_als = ref Id.Map.empty; - env_opn = true; - env_rec = Id.Map.empty; - env_str = true; -} - -let env_name env = - (* Generate names according to a provided environment *) - let mk num = - let base = num mod 26 in - let rem = num / 26 in - let name = String.make 1 (Char.chr (97 + base)) in - let suff = if Int.equal rem 0 then "" else string_of_int rem in - let name = name ^ suff in - name - in - let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in - let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in - let vars = ref vars in - let rec fresh n = - let name = mk n in - if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) - else name - in - fun n -> - if UF.Map.mem n !vars then UF.Map.find n !vars - else - let ans = fresh 0 in - let () = vars := UF.Map.add n ans !vars in - ans - -let ltac2_env : environment Genintern.Store.field = - Genintern.Store.field () - -let drop_ltac2_env store = - Genintern.Store.remove store ltac2_env - -let fresh_id env = UF.fresh env.env_cst - -let get_alias {loc;v=id} env = - try Id.Map.find id env.env_als.contents - with Not_found -> - if env.env_opn then - let n = fresh_id env in - let () = env.env_als := Id.Map.add id n env.env_als.contents in - n - else user_err ?loc (str "Unbound type parameter " ++ Id.print id) - -let push_name id t env = match id with -| Anonymous -> env -| Name id -> { env with env_var = Id.Map.add id t env.env_var } - -let error_nargs_mismatch ?loc kn nargs nfound = - let cstr = Tac2env.shortest_qualid_of_constructor kn in - user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ - int nargs ++ str " arguments, but is applied to " ++ int nfound ++ - str " arguments") - -let error_nparams_mismatch ?loc nargs nfound = - user_err ?loc (str "Type expects " ++ int nargs ++ - str " arguments, but is applied to " ++ int nfound ++ - str " arguments") - -let rec subst_type subst (t : 'a glb_typexpr) = match t with -| GTypVar id -> subst id -| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) -| GTypRef (qid, args) -> - GTypRef (qid, List.map (fun t -> subst_type subst t) args) - -let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t with -| CTypVar (Name id) -> GTypVar (get_alias (CAst.make ?loc id) env) -| CTypVar Anonymous -> GTypVar (fresh_id env) -| CTypRef (rel, args) -> - let (kn, nparams) = match rel with - | RelId qid -> - let id = qualid_basename qid in - if qualid_is_ident qid && Id.Map.mem id env.env_rec then - let (kn, n) = Id.Map.find id env.env_rec in - (Other kn, n) - else - let kn = - try Tac2env.locate_type qid - with Not_found -> - user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) - in - let (nparams, _) = Tac2env.interp_type kn in - (Other kn, nparams) - | AbsKn (Other kn) -> - let (nparams, _) = Tac2env.interp_type kn in - (Other kn, nparams) - | AbsKn (Tuple n) -> - (Tuple n, n) - in - let nargs = List.length args in - let () = - if not (Int.equal nparams nargs) then - let qid = match rel with - | RelId lid -> lid - | AbsKn (Other kn) -> shortest_qualid_of_type ?loc kn - | AbsKn (Tuple _) -> assert false - in - user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ - strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ - applied to " ++ int nargs ++ strbrk "argument(s)") - in - GTypRef (kn, List.map (fun t -> intern_type env t) args) -| CTypArrow (t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) - -let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = - let (n, t) = t in - let subst = Array.init n (fun _ -> fresh_id env) in - let substf i = GTypVar subst.(i) in - subst_type substf t - -let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = - let (n, t) = t in - let subst = Array.init n (fun _ -> fresh_id env) in - let substf = function - | LVar i -> GTypVar subst.(i) - | GVar n -> GTypVar n - in - subst_type substf t - -let fresh_reftype env (kn : KerName.t or_tuple) = - let n = match kn with - | Other kn -> fst (Tac2env.interp_type kn) - | Tuple n -> n - in - let subst = Array.init n (fun _ -> fresh_id env) in - let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in - (subst, t) - -(** First-order unification algorithm *) -let is_unfoldable kn = match snd (Tac2env.interp_type kn) with -| GTydDef (Some _) -> true -| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false - -let unfold env kn args = - let (nparams, def) = Tac2env.interp_type kn in - let def = match def with - | GTydDef (Some t) -> t - | _ -> assert false - in - let args = Array.of_list args in - let subst n = args.(n) in - subst_type subst def - -(** View function, allows to ensure head normal forms *) -let rec kind env t = match t with -| GTypVar id -> - let (id, v) = UF.find id env.env_cst in - begin match v with - | None -> GTypVar id - | Some t -> kind env t - end -| GTypRef (Other kn, tl) -> - if is_unfoldable kn then kind env (unfold env kn tl) else t -| GTypArrow _ | GTypRef (Tuple _, _) -> t - -(** Normalize unification variables without unfolding type aliases *) -let rec nf env t = match t with -| GTypVar id -> - let (id, v) = UF.find id env.env_cst in - begin match v with - | None -> GTypVar id - | Some t -> nf env t - end -| GTypRef (kn, tl) -> - let tl = List.map (fun t -> nf env t) tl in - GTypRef (kn, tl) -| GTypArrow (t, u) -> - let t = nf env t in - let u = nf env u in - GTypArrow (t, u) - -let pr_glbtype env t = - let t = nf env t in - let name = env_name env in - pr_glbtype name t - -exception Occur - -let rec occur_check env id t = match kind env t with -| GTypVar id' -> if UF.equal id id' then raise Occur -| GTypArrow (t1, t2) -> - let () = occur_check env id t1 in - occur_check env id t2 -| GTypRef (kn, tl) -> - List.iter (fun t -> occur_check env id t) tl - -exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr - -let unify_var env id t = match kind env t with -| GTypVar id' -> - if not (UF.equal id id') then UF.union id id' env.env_cst -| GTypArrow _ | GTypRef _ -> - try - let () = occur_check env id t in - UF.set id t env.env_cst - with Occur -> raise (CannotUnify (GTypVar id, t)) - -let eq_or_tuple eq t1 t2 = match t1, t2 with -| Tuple n1, Tuple n2 -> Int.equal n1 n2 -| Other o1, Other o2 -> eq o1 o2 -| _ -> false - -let rec unify0 env t1 t2 = match kind env t1, kind env t2 with -| GTypVar id, t | t, GTypVar id -> - unify_var env id t -| GTypArrow (t1, u1), GTypArrow (t2, u2) -> - let () = unify0 env t1 t2 in - unify0 env u1 u2 -| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> - if eq_or_tuple KerName.equal kn1 kn2 then - List.iter2 (fun t1 t2 -> unify0 env t1 t2) tl1 tl2 - else raise (CannotUnify (t1, t2)) -| _ -> raise (CannotUnify (t1, t2)) - -let unify ?loc env t1 t2 = - try unify0 env t1 t2 - with CannotUnify (u1, u2) -> - user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env t1 ++ - spc () ++ str "but an expression was expected of type" ++ spc () ++ pr_glbtype env t2) - -let unify_arrow ?loc env ft args = - let ft0 = ft in - let rec iter ft args is_fun = match kind env ft, args with - | t, [] -> t - | GTypArrow (t1, ft), (loc, t2) :: args -> - let () = unify ?loc env t2 t1 in - iter ft args true - | GTypVar id, (_, t) :: args -> - let ft = GTypVar (fresh_id env) in - let () = unify_var env id (GTypArrow (t, ft)) in - iter ft args true - | GTypRef _, _ :: _ -> - if is_fun then - user_err ?loc (str "This function has type" ++ spc () ++ pr_glbtype env ft0 ++ - spc () ++ str "and is applied to too many arguments") - else - user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env ft0 ++ - spc () ++ str "and is not a function") - in - iter ft args false - -(** Term typing *) - -let is_pure_constructor kn = - match snd (Tac2env.interp_type kn) with - | GTydAlg _ | GTydOpn -> true - | GTydRec fields -> - let is_pure (_, mut, _) = not mut in - List.for_all is_pure fields - | GTydDef _ -> assert false (** Type definitions have no constructors *) - -let rec is_value = function -| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true -| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false -| GTacCst (Tuple _, _, el) -> List.for_all is_value el -| GTacCst (_, _, []) -> true -| GTacOpn (_, el) -> List.for_all is_value el -| GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el -| GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ -| GTacWth _ -> false - -let is_rec_rhs = function -| GTacFun _ -> true -| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ -| GTacSet _ | GTacExt _ | GTacPrm _ | GTacCst _ -| GTacCse _ | GTacOpn _ | GTacWth _ -> false - -let rec fv_type f t accu = match t with -| GTypVar id -> f id accu -| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) -| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl - -let fv_env env = - let rec f id accu = match UF.find id env.env_cst with - | id, None -> UF.Map.add id () accu - | _, Some t -> fv_type f t accu - in - let fold_var id (_, t) accu = - let fmix id accu = match id with - | LVar _ -> accu - | GVar id -> f id accu - in - fv_type fmix t accu - in - let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in - let fold_als _ id accu = f id accu in - Id.Map.fold fold_als !(env.env_als) fv_var - -let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = - let fv = fv_env env in - let count = ref 0 in - let vars = ref UF.Map.empty in - let rec subst id = - let (id, t) = UF.find id env.env_cst in - match t with - | None -> - if UF.Map.mem id fv then GTypVar (GVar id) - else - begin try UF.Map.find id !vars - with Not_found -> - let n = !count in - let var = GTypVar (LVar n) in - let () = incr count in - let () = vars := UF.Map.add id var !vars in - var - end - | Some t -> subst_type subst t - in - let t = subst_type subst t in - (!count, t) - -let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = - let subst id = GTypVar (GVar id) in - (0, subst_type subst t) - -let warn_not_unit = - CWarnings.create ~name:"not-unit" ~category:"ltac" - (fun () -> strbrk "The following expression should have type unit.") - -let warn_redundant_clause = - CWarnings.create ~name:"redundant-clause" ~category:"ltac" - (fun () -> strbrk "The following clause is redundant.") - -let check_elt_unit loc env t = - let maybe_unit = match kind env t with - | GTypVar _ -> true - | GTypArrow _ -> false - | GTypRef (Tuple 0, []) -> true - | GTypRef _ -> false - in - if not maybe_unit then warn_not_unit ?loc () - -let check_elt_empty loc env t = match kind env t with -| GTypVar _ -> - user_err ?loc (str "Cannot infer an empty type for this expression") -| GTypArrow _ | GTypRef (Tuple _, _) -> - user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") -| GTypRef (Other kn, _) -> - let def = Tac2env.interp_type kn in - match def with - | _, GTydAlg { galg_constructors = [] } -> kn - | _ -> - user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") - -let check_unit ?loc t = - let env = empty_env () in - (* Should not matter, t should be closed. *) - let t = fresh_type_scheme env t in - let maybe_unit = match kind env t with - | GTypVar _ -> true - | GTypArrow _ -> false - | GTypRef (Tuple 0, []) -> true - | GTypRef _ -> false - in - if not maybe_unit then warn_not_unit ?loc () - -let check_redundant_clause = function -| [] -> () -| (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () - -let get_variable0 mem var = match var with -| RelId qid -> - let id = qualid_basename qid in - if qualid_is_ident qid && mem id then ArgVar CAst.(make ?loc:qid.CAst.loc id) - else - let kn = - try Tac2env.locate_ltac qid - with Not_found -> - CErrors.user_err ?loc:qid.CAst.loc (str "Unbound value " ++ pr_qualid qid) - in - ArgArg kn -| AbsKn kn -> ArgArg kn - -let get_variable env var = - let mem id = Id.Map.mem id env.env_var in - get_variable0 mem var - -let get_constructor env var = match var with -| RelId qid -> - let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in - begin match c with - | Some knc -> Other knc - | None -> - CErrors.user_err ?loc:qid.CAst.loc (str "Unbound constructor " ++ pr_qualid qid) - end -| AbsKn knc -> knc - -let get_projection var = match var with -| RelId qid -> - let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") - in - Tac2env.interp_projection kn -| AbsKn kn -> - Tac2env.interp_projection kn - -let intern_atm env = function -| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (Other t_int, [])) -| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (Other t_string, [])) - -let invalid_pattern ?loc kn kn' = - let pr t = match t with - | Other kn' -> str "type " ++ pr_typref kn' - | Tuple n -> str "tuple of size " ++ int n - in - user_err ?loc (str "Invalid pattern, expected a pattern for " ++ - pr kn ++ str ", found a pattern for " ++ pr kn') (** FIXME *) - -(** Pattern view *) - -type glb_patexpr = -| GPatVar of Name.t -| GPatRef of ltac_constructor or_tuple * glb_patexpr list - -let rec intern_patexpr env {loc;v=pat} = match pat with -| CPatVar na -> GPatVar na -| CPatRef (qid, pl) -> - let kn = get_constructor env qid in - GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) -| CPatCnv (pat, ty) -> - user_err ?loc (str "Pattern not handled yet") - -type pattern_kind = -| PKind_empty -| PKind_variant of type_constant or_tuple -| PKind_open of type_constant -| PKind_any - -let get_pattern_kind env pl = match pl with -| [] -> PKind_empty -| p :: pl -> - let rec get_kind (p, _) pl = match intern_patexpr env p with - | GPatVar _ -> - begin match pl with - | [] -> PKind_any - | p :: pl -> get_kind p pl - end - | GPatRef (Other kn, pl) -> - let data = Tac2env.interp_constructor kn in - if Option.is_empty data.cdata_indx then PKind_open data.cdata_type - else PKind_variant (Other data.cdata_type) - | GPatRef (Tuple _, tp) -> PKind_variant (Tuple (List.length tp)) - in - get_kind p pl - -(** Internalization *) - -(** Used to generate a fresh tactic variable for pattern-expansion *) -let fresh_var avoid = - let bad id = - Id.Set.mem id avoid || - (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) - in - Namegen.next_ident_away_from (Id.of_string "p") bad - -let add_name accu = function -| Name id -> Id.Set.add id accu -| Anonymous -> accu - -let rec ids_of_pattern accu {v=pat} = match pat with -| CPatVar Anonymous -> accu -| CPatVar (Name id) -> Id.Set.add id accu -| CPatRef (_, pl) -> - List.fold_left ids_of_pattern accu pl -| CPatCnv (pat, _) -> ids_of_pattern accu pat - -let loc_of_relid = function -| RelId {loc} -> loc -| AbsKn _ -> None - -let extract_pattern_type ({loc;v=p} as pat) = match p with -| CPatCnv (pat, ty) -> pat, Some ty -| CPatVar _ | CPatRef _ -> pat, None - -(** Expand pattern: [p => t] becomes [x => match x with p => t end] *) -let expand_pattern avoid bnd = - let fold (avoid, bnd) (pat, t) = - let na, expand = match pat.v with - | CPatVar na -> - (* Don't expand variable patterns *) - na, None - | _ -> - let id = fresh_var avoid in - let qid = RelId (qualid_of_ident ?loc:pat.loc id) in - Name id, Some qid - in - let avoid = ids_of_pattern avoid pat in - let avoid = add_name avoid na in - (avoid, (na, pat, expand) :: bnd) - in - let (_, bnd) = List.fold_left fold (avoid, []) bnd in - let fold e (na, pat, expand) = match expand with - | None -> e - | Some qid -> - let loc = loc_of_relid qid in - CAst.make ?loc @@ CTacCse (CAst.make ?loc @@ CTacRef qid, [pat, e]) - in - let expand e = List.fold_left fold e bnd in - let nas = List.rev_map (fun (na, _, _) -> na) bnd in - (nas, expand) - -let is_alias env qid = match get_variable env qid with -| ArgArg (TacAlias _) -> true -| ArgVar _ | (ArgArg (TacConstant _)) -> false - -let rec intern_rec env {loc;v=e} = match e with -| CTacAtm atm -> intern_atm env atm -| CTacRef qid -> - begin match get_variable env qid with - | ArgVar {CAst.v=id} -> - let sch = Id.Map.find id env.env_var in - (GTacVar id, fresh_mix_type_scheme env sch) - | ArgArg (TacConstant kn) -> - let { Tac2env.gdata_type = sch } = - try Tac2env.interp_global kn - with Not_found -> - CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) - in - (GTacRef kn, fresh_type_scheme env sch) - | ArgArg (TacAlias kn) -> - let e = - try Tac2env.interp_alias kn - with Not_found -> - CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) - in - intern_rec env e - end -| CTacCst qid -> - let kn = get_constructor env qid in - intern_constructor env loc kn [] -| CTacFun (bnd, e) -> - let bnd = List.map extract_pattern_type bnd in - let map (_, t) = match t with - | None -> GTypVar (fresh_id env) - | Some t -> intern_type env t - in - let tl = List.map map bnd in - let (nas, exp) = expand_pattern (Id.Map.domain env.env_var) bnd in - let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env nas tl in - let (e, t) = intern_rec env (exp e) in - let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in - (GTacFun (nas, e), t) -| CTacApp ({loc;v=CTacCst qid}, args) -> - let kn = get_constructor env qid in - intern_constructor env loc kn args -| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> - let kn = match get_variable env qid with - | ArgArg (TacAlias kn) -> kn - | ArgVar _ | (ArgArg (TacConstant _)) -> assert false - in - let e = Tac2env.interp_alias kn in - let map arg = - (* Thunk alias arguments *) - let loc = arg.loc in - let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in - let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in - CAst.make ?loc @@ CTacFun ([var], arg) - in - let args = List.map map args in - intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) -| CTacApp (f, args) -> - let loc = f.loc in - let (f, ft) = intern_rec env f in - let fold arg (args, t) = - let loc = arg.loc in - let (arg, argt) = intern_rec env arg in - (arg :: args, (loc, argt) :: t) - in - let (args, t) = List.fold_right fold args ([], []) in - let ret = unify_arrow ?loc env ft t in - (GTacApp (f, args), ret) -| CTacLet (is_rec, el, e) -> - let map (pat, e) = - let (pat, ty) = extract_pattern_type pat in - (pat, ty, e) - in - let el = List.map map el in - let fold accu (pat, _, e) = - let ids = ids_of_pattern Id.Set.empty pat in - let common = Id.Set.inter ids accu in - if Id.Set.is_empty common then Id.Set.union ids accu - else - let id = Id.Set.choose common in - user_err ?loc:pat.loc (str "Variable " ++ Id.print id ++ str " is bound several \ - times in this matching") - in - let ids = List.fold_left fold Id.Set.empty el in - if is_rec then intern_let_rec env loc ids el e - else intern_let env loc ids el e -| CTacCnv (e, tc) -> - let (e, t) = intern_rec env e in - let tc = intern_type env tc in - let () = unify ?loc env t tc in - (e, tc) -| CTacSeq (e1, e2) -> - let loc1 = e1.loc in - let (e1, t1) = intern_rec env e1 in - let (e2, t2) = intern_rec env e2 in - let () = check_elt_unit loc1 env t1 in - (GTacLet (false, [Anonymous, e1], e2), t2) -| CTacCse (e, pl) -> - intern_case env loc e pl -| CTacRec fs -> - intern_record env loc fs -| CTacPrj (e, proj) -> - let pinfo = get_projection proj in - let loc = e.loc in - let (e, t) = intern_rec env e in - let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in - let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (Other pinfo.pdata_type, params) in - let () = unify ?loc env t exp in - let substf i = GTypVar subst.(i) in - let ret = subst_type substf pinfo.pdata_ptyp in - (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) -| CTacSet (e, proj, r) -> - let pinfo = get_projection proj in - let () = - if not pinfo.pdata_mutb then - let loc = match proj with - | RelId {CAst.loc} -> loc - | AbsKn _ -> None - in - user_err ?loc (str "Field is not mutable") - in - let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in - let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (Other pinfo.pdata_type, params) in - let e = intern_rec_with_constraint env e exp in - let substf i = GTypVar subst.(i) in - let ret = subst_type substf pinfo.pdata_ptyp in - let r = intern_rec_with_constraint env r ret in - (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) -| CTacExt (tag, arg) -> - let open Genintern in - let self ist e = - let env = match Store.get ist.extra ltac2_env with - | None -> empty_env () - | Some env -> env - in - intern_rec env e - in - let obj = interp_ml_object tag in - (* External objects do not have access to the named context because this is - not stable by dynamic semantics. *) - let genv = Global.env_of_context Environ.empty_named_context_val in - let ist = empty_glob_sign genv in - let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let arg, tpe = - if env.env_str then - let arg () = obj.ml_intern self ist arg in - Flags.with_option Ltac_plugin.Tacintern.strict_check arg () - else - obj.ml_intern self ist arg - in - let e = match arg with - | GlbVal arg -> GTacExt (tag, arg) - | GlbTacexpr e -> e - in - (e, tpe) - -and intern_rec_with_constraint env e exp = - let (er, t) = intern_rec env e in - let () = unify ?loc:e.loc env t exp in - er - -and intern_let env loc ids el e = - let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in - let fold (pat, t, e) (avoid, accu) = - let nas, exp = expand_pattern avoid [pat, t] in - let na = match nas with [x] -> x | _ -> assert false in - let avoid = List.fold_left add_name avoid nas in - (avoid, (na, exp, t, e) :: accu) - in - let (_, el) = List.fold_right fold el (avoid, []) in - let fold (na, exp, tc, e) (body, el, p) = - let (e, t) = match tc with - | None -> intern_rec env e - | Some tc -> - let tc = intern_type env tc in - (intern_rec_with_constraint env e tc, tc) - in - let t = if is_value e then abstract_var env t else monomorphic t in - (exp body, (na, e) :: el, (na, t) :: p) - in - let (e, el, p) = List.fold_right fold el (e, [], []) in - let env = List.fold_left (fun accu (na, t) -> push_name na t accu) env p in - let (e, t) = intern_rec env e in - (GTacLet (false, el, e), t) - -and intern_let_rec env loc ids el e = - let map env (pat, t, e) = - let na = match pat.v with - | CPatVar na -> na - | CPatRef _ | CPatCnv _ -> - user_err ?loc:pat.loc (str "This kind of pattern is forbidden in let-rec bindings") - in - let id = fresh_id env in - let env = push_name na (monomorphic (GTypVar id)) env in - (env, (loc, na, t, e, id)) - in - let (env, el) = List.fold_left_map map env el in - let fold (loc, na, tc, e, id) (el, tl) = - let loc_e = e.loc in - let (e, t) = intern_rec env e in - let () = - if not (is_rec_rhs e) then - user_err ?loc:loc_e (str "This kind of expression is not allowed as \ - right-hand side of a recursive binding") - in - let () = unify ?loc env t (GTypVar id) in - let () = match tc with - | None -> () - | Some tc -> - let tc = intern_type env tc in - unify ?loc env t tc - in - ((na, e) :: el, t :: tl) - in - let (el, tl) = List.fold_right fold el ([], []) in - let (e, t) = intern_rec env e in - (GTacLet (true, el, e), t) - -(** For now, patterns recognized by the pattern-matching compiling are limited - to depth-one where leaves are either variables or catch-all *) -and intern_case env loc e pl = - let (e', t) = intern_rec env e in - let todo ?loc () = user_err ?loc (str "Pattern not handled yet") in - match get_pattern_kind env pl with - | PKind_any -> - let (pat, b) = List.hd pl in - let na = match intern_patexpr env pat with - | GPatVar na -> na - | _ -> assert false - in - let () = check_redundant_clause (List.tl pl) in - let env = push_name na (monomorphic t) env in - let (b, tb) = intern_rec env b in - (GTacLet (false, [na, e'], b), tb) - | PKind_empty -> - let kn = check_elt_empty loc env t in - let r = fresh_id env in - (GTacCse (e', Other kn, [||], [||]), GTypVar r) - | PKind_variant kn -> - let subst, tc = fresh_reftype env kn in - let () = unify ?loc:e.loc env t tc in - let (nconst, nnonconst, arities) = match kn with - | Tuple 0 -> 1, 0, [0] - | Tuple n -> 0, 1, [n] - | Other kn -> - let (_, def) = Tac2env.interp_type kn in - let galg = match def with | GTydAlg c -> c | _ -> assert false in - let arities = List.map (fun (_, args) -> List.length args) galg.galg_constructors in - galg.galg_nconst, galg.galg_nnonconst, arities - in - let const = Array.make nconst None in - let nonconst = Array.make nnonconst None in - let ret = GTypVar (fresh_id env) in - let rec intern_branch = function - | [] -> () - | (pat, br) :: rem -> - let tbr = match pat.v with - | CPatVar (Name _) -> - let loc = pat.loc in - todo ?loc () - | CPatVar Anonymous -> - let () = check_redundant_clause rem in - let (br', brT) = intern_rec env br in - (* Fill all remaining branches *) - let fill (ncst, narg) arity = - if Int.equal arity 0 then - let () = - if Option.is_empty const.(ncst) then const.(ncst) <- Some br' - in - (succ ncst, narg) - else - let () = - if Option.is_empty nonconst.(narg) then - let ids = Array.make arity Anonymous in - nonconst.(narg) <- Some (ids, br') - in - (ncst, succ narg) - in - let _ = List.fold_left fill (0, 0) arities in - brT - | CPatRef (qid, args) -> - let loc = pat.loc in - let knc = get_constructor env qid in - let kn', index, arity = match knc with - | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) - | Other knc -> - let data = Tac2env.interp_constructor knc in - let index = Option.get data.cdata_indx in - Other data.cdata_type, index, data.cdata_args - in - let () = - if not (eq_or_tuple KerName.equal kn kn') then - invalid_pattern ?loc kn kn' - in - let get_id pat = match pat with - | {v=CPatVar na} -> na - | {loc} -> todo ?loc () - in - let ids = List.map get_id args in - let nids = List.length ids in - let nargs = List.length arity in - let () = match knc with - | Tuple n -> assert (n == nids) - | Other knc -> - if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids - in - let fold env id tpe = - (* Instantiate all arguments *) - let subst n = GTypVar subst.(n) in - let tpe = subst_type subst tpe in - push_name id (monomorphic tpe) env - in - let nenv = List.fold_left2 fold env ids arity in - let (br', brT) = intern_rec nenv br in - let () = - if List.is_empty args then - if Option.is_empty const.(index) then const.(index) <- Some br' - else warn_redundant_clause ?loc () - else - let ids = Array.of_list ids in - if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') - else warn_redundant_clause ?loc () - in - brT - | CPatCnv _ -> - user_err ?loc (str "Pattern not handled yet") - in - let () = unify ?loc:br.loc env tbr ret in - intern_branch rem - in - let () = intern_branch pl in - let map n is_const = function - | None -> - let kn = match kn with Other kn -> kn | _ -> assert false in - let cstr = pr_internal_constructor kn n is_const in - user_err ?loc (str "Unhandled match case for constructor " ++ cstr) - | Some x -> x - in - let const = Array.mapi (fun i o -> map i true o) const in - let nonconst = Array.mapi (fun i o -> map i false o) nonconst in - let ce = GTacCse (e', kn, const, nonconst) in - (ce, ret) - | PKind_open kn -> - let subst, tc = fresh_reftype env (Other kn) in - let () = unify ?loc:e.loc env t tc in - let ret = GTypVar (fresh_id env) in - let rec intern_branch map = function - | [] -> - user_err ?loc (str "Missing default case") - | (pat, br) :: rem -> - match intern_patexpr env pat with - | GPatVar na -> - let () = check_redundant_clause rem in - let nenv = push_name na (monomorphic tc) env in - let br' = intern_rec_with_constraint nenv br ret in - let def = (na, br') in - (map, def) - | GPatRef (knc, args) -> - let get = function - | GPatVar na -> na - | GPatRef _ -> - user_err ?loc (str "TODO: Unhandled match case") (* FIXME *) - in - let loc = pat.loc in - let knc = match knc with - | Other knc -> knc - | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) - in - let ids = List.map get args in - let data = Tac2env.interp_constructor knc in - let () = - if not (KerName.equal kn data.cdata_type) then - invalid_pattern ?loc (Other kn) (Other data.cdata_type) - in - let nids = List.length ids in - let nargs = List.length data.cdata_args in - let () = - if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids - in - let fold env id tpe = - (* Instantiate all arguments *) - let subst n = GTypVar subst.(n) in - let tpe = subst_type subst tpe in - push_name id (monomorphic tpe) env - in - let nenv = List.fold_left2 fold env ids data.cdata_args in - let br' = intern_rec_with_constraint nenv br ret in - let map = - if KNmap.mem knc map then - let () = warn_redundant_clause ?loc () in - map - else - KNmap.add knc (Anonymous, Array.of_list ids, br') map - in - intern_branch map rem - in - let (map, def) = intern_branch KNmap.empty pl in - (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) - -and intern_constructor env loc kn args = match kn with -| Other kn -> - let cstr = interp_constructor kn in - let nargs = List.length cstr.cdata_args in - if Int.equal nargs (List.length args) then - let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in - let substf i = GTypVar subst.(i) in - let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in - let targs = List.init cstr.cdata_prms (fun i -> GTypVar subst.(i)) in - let ans = GTypRef (Other cstr.cdata_type, targs) in - let map arg tpe = intern_rec_with_constraint env arg tpe in - let args = List.map2 map args types in - match cstr.cdata_indx with - | Some idx -> - (GTacCst (Other cstr.cdata_type, idx, args), ans) - | None -> - (GTacOpn (kn, args), ans) - else - error_nargs_mismatch ?loc kn nargs (List.length args) -| Tuple n -> - assert (Int.equal n (List.length args)); - let types = List.init n (fun i -> GTypVar (fresh_id env)) in - let map arg tpe = intern_rec_with_constraint env arg tpe in - let args = List.map2 map args types in - let ans = GTypRef (Tuple n, types) in - GTacCst (Tuple n, 0, args), ans - -and intern_record env loc fs = - let map (proj, e) = - let loc = match proj with - | RelId {CAst.loc} -> loc - | AbsKn _ -> None - in - let proj = get_projection proj in - (loc, proj, e) - in - let fs = List.map map fs in - let kn = match fs with - | [] -> user_err ?loc (str "Cannot infer the corresponding record type") - | (_, proj, _) :: _ -> proj.pdata_type - in - let params, typdef = match Tac2env.interp_type kn with - | n, GTydRec def -> n, def - | _ -> assert false - in - let subst = Array.init params (fun _ -> fresh_id env) in - (* Set the answer [args] imperatively *) - let args = Array.make (List.length typdef) None in - let iter (loc, pinfo, e) = - if KerName.equal kn pinfo.pdata_type then - let index = pinfo.pdata_indx in - match args.(index) with - | None -> - let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in - let e = intern_rec_with_constraint env e exp in - args.(index) <- Some e - | Some _ -> - let (name, _, _) = List.nth typdef pinfo.pdata_indx in - user_err ?loc (str "Field " ++ Id.print name ++ str " is defined \ - several times") - else - user_err ?loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ - pertain to record definition " ++ pr_typref pinfo.pdata_type) - in - let () = List.iter iter fs in - let () = match Array.findi (fun _ o -> Option.is_empty o) args with - | None -> () - | Some i -> - let (field, _, _) = List.nth typdef i in - user_err ?loc (str "Field " ++ Id.print field ++ str " is undefined") - in - let args = Array.map_to_list Option.get args in - let tparam = List.init params (fun i -> GTypVar subst.(i)) in - (GTacCst (Other kn, 0, args), GTypRef (Other kn, tparam)) - -let normalize env (count, vars) (t : UF.elt glb_typexpr) = - let get_var id = - try UF.Map.find id !vars - with Not_found -> - let () = assert env.env_opn in - let n = GTypVar !count in - let () = incr count in - let () = vars := UF.Map.add id n !vars in - n - in - let rec subst id = match UF.find id env.env_cst with - | id, None -> get_var id - | _, Some t -> subst_type subst t - in - subst_type subst t - -let intern ~strict e = - let env = empty_env () in - let env = if strict then env else { env with env_str = false } in - let (e, t) = intern_rec env e in - let count = ref 0 in - let vars = ref UF.Map.empty in - let t = normalize env (count, vars) t in - (e, (!count, t)) - -let intern_typedef self (ids, t) : glb_quant_typedef = - let env = { (empty_env ()) with env_rec = self } in - (* Initialize type parameters *) - let map id = get_alias id env in - let ids = List.map map ids in - let count = ref (List.length ids) in - let vars = ref UF.Map.empty in - let iter n id = vars := UF.Map.add id (GTypVar n) !vars in - let () = List.iteri iter ids in - (* Do not accept unbound type variables *) - let env = { env with env_opn = false } in - let intern t = - let t = intern_type env t in - normalize env (count, vars) t - in - let count = !count in - match t with - | CTydDef None -> (count, GTydDef None) - | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) - | CTydAlg constrs -> - let map (c, t) = (c, List.map intern t) in - let constrs = List.map map constrs in - let getn (const, nonconst) (c, args) = match args with - | [] -> (succ const, nonconst) - | _ :: _ -> (const, succ nonconst) - in - let nconst, nnonconst = List.fold_left getn (0, 0) constrs in - let galg = { - galg_constructors = constrs; - galg_nconst = nconst; - galg_nnonconst = nnonconst; - } in - (count, GTydAlg galg) - | CTydRec fields -> - let map (c, mut, t) = (c, mut, intern t) in - let fields = List.map map fields in - (count, GTydRec fields) - | CTydOpn -> (count, GTydOpn) - -let intern_open_type t = - let env = empty_env () in - let t = intern_type env t in - let count = ref 0 in - let vars = ref UF.Map.empty in - let t = normalize env (count, vars) t in - (!count, t) - -(** Subtyping *) - -let check_subtype t1 t2 = - let env = empty_env () in - let t1 = fresh_type_scheme env t1 in - (* We build a substitution mimicking rigid variable by using dummy tuples *) - let rigid i = GTypRef (Tuple (i + 1), []) in - let (n, t2) = t2 in - let subst = Array.init n rigid in - let substf i = subst.(i) in - let t2 = subst_type substf t2 in - try unify0 env t1 t2; true with CannotUnify _ -> false - -(** Globalization *) - -let get_projection0 var = match var with -| RelId qid -> - let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") - in - kn -| AbsKn kn -> kn - -let rec globalize ids ({loc;v=er} as e) = match er with -| CTacAtm _ -> e -| CTacRef ref -> - let mem id = Id.Set.mem id ids in - begin match get_variable0 mem ref with - | ArgVar _ -> e - | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) - end -| CTacCst qid -> - let knc = get_constructor () qid in - CAst.make ?loc @@ CTacCst (AbsKn knc) -| CTacFun (bnd, e) -> - let fold (pats, accu) pat = - let accu = ids_of_pattern accu pat in - let pat = globalize_pattern ids pat in - (pat :: pats, accu) - in - let bnd, ids = List.fold_left fold ([], ids) bnd in - let bnd = List.rev bnd in - let e = globalize ids e in - CAst.make ?loc @@ CTacFun (bnd, e) -| CTacApp (e, el) -> - let e = globalize ids e in - let el = List.map (fun e -> globalize ids e) el in - CAst.make ?loc @@ CTacApp (e, el) -| CTacLet (isrec, bnd, e) -> - let fold accu (pat, _) = ids_of_pattern accu pat in - let ext = List.fold_left fold Id.Set.empty bnd in - let eids = Id.Set.union ext ids in - let e = globalize eids e in - let map (qid, e) = - let ids = if isrec then eids else ids in - let qid = globalize_pattern ids qid in - (qid, globalize ids e) - in - let bnd = List.map map bnd in - CAst.make ?loc @@ CTacLet (isrec, bnd, e) -| CTacCnv (e, t) -> - let e = globalize ids e in - CAst.make ?loc @@ CTacCnv (e, t) -| CTacSeq (e1, e2) -> - let e1 = globalize ids e1 in - let e2 = globalize ids e2 in - CAst.make ?loc @@ CTacSeq (e1, e2) -| CTacCse (e, bl) -> - let e = globalize ids e in - let bl = List.map (fun b -> globalize_case ids b) bl in - CAst.make ?loc @@ CTacCse (e, bl) -| CTacRec r -> - let map (p, e) = - let p = get_projection0 p in - let e = globalize ids e in - (AbsKn p, e) - in - CAst.make ?loc @@ CTacRec (List.map map r) -| CTacPrj (e, p) -> - let e = globalize ids e in - let p = get_projection0 p in - CAst.make ?loc @@ CTacPrj (e, AbsKn p) -| CTacSet (e, p, e') -> - let e = globalize ids e in - let p = get_projection0 p in - let e' = globalize ids e' in - CAst.make ?loc @@ CTacSet (e, AbsKn p, e') -| CTacExt (tag, arg) -> - let arg = str (Tac2dyn.Arg.repr tag) in - CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) - -and globalize_case ids (p, e) = - (globalize_pattern ids p, globalize ids e) - -and globalize_pattern ids ({loc;v=pr} as p) = match pr with -| CPatVar _ -> p -| CPatRef (cst, pl) -> - let knc = get_constructor () cst in - let cst = AbsKn knc in - let pl = List.map (fun p -> globalize_pattern ids p) pl in - CAst.make ?loc @@ CPatRef (cst, pl) -| CPatCnv (pat, ty) -> - let pat = globalize_pattern ids pat in - CAst.make ?loc @@ CPatCnv (pat, ty) - -(** Kernel substitution *) - -open Mod_subst - -let subst_or_tuple f subst o = match o with -| Tuple _ -> o -| Other v -> - let v' = f subst v in - if v' == v then o else Other v' - -let rec subst_type subst t = match t with -| GTypVar _ -> t -| GTypArrow (t1, t2) -> - let t1' = subst_type subst t1 in - let t2' = subst_type subst t2 in - if t1' == t1 && t2' == t2 then t - else GTypArrow (t1', t2') -| GTypRef (kn, tl) -> - let kn' = subst_or_tuple subst_kn subst kn in - let tl' = List.Smart.map (fun t -> subst_type subst t) tl in - if kn' == kn && tl' == tl then t else GTypRef (kn', tl') - -let rec subst_expr subst e = match e with -| GTacAtm _ | GTacVar _ | GTacPrm _ -> e -| GTacRef kn -> GTacRef (subst_kn subst kn) -| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) -| GTacApp (f, args) -> - GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) -| GTacLet (r, bs, e) -> - let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in - GTacLet (r, bs, subst_expr subst e) -| GTacCst (t, n, el) as e0 -> - let t' = subst_or_tuple subst_kn subst t in - let el' = List.Smart.map (fun e -> subst_expr subst e) el in - if t' == t && el' == el then e0 else GTacCst (t', n, el') -| GTacCse (e, ci, cse0, cse1) -> - let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in - let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in - let ci' = subst_or_tuple subst_kn subst ci in - GTacCse (subst_expr subst e, ci', cse0', cse1') -| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> - let e' = subst_expr subst e in - let def' = subst_expr subst def in - let fold kn (self, vars, p) accu = - let kn' = subst_kn subst kn in - let p' = subst_expr subst p in - if kn' == kn && p' == p then accu - else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) - in - let br' = KNmap.fold fold br br in - if e' == e && br' == br && def' == def then e0 - else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } -| GTacPrj (kn, e, p) as e0 -> - let kn' = subst_kn subst kn in - let e' = subst_expr subst e in - if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) -| GTacSet (kn, e, p, r) as e0 -> - let kn' = subst_kn subst kn in - let e' = subst_expr subst e in - let r' = subst_expr subst r in - if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') -| GTacExt (tag, arg) -> - let tpe = interp_ml_object tag in - let arg' = tpe.ml_subst subst arg in - if arg' == arg then e else GTacExt (tag, arg') -| GTacOpn (kn, el) as e0 -> - let kn' = subst_kn subst kn in - let el' = List.Smart.map (fun e -> subst_expr subst e) el in - if kn' == kn && el' == el then e0 else GTacOpn (kn', el') - -let subst_typedef subst e = match e with -| GTydDef t -> - let t' = Option.Smart.map (fun t -> subst_type subst t) t in - if t' == t then e else GTydDef t' -| GTydAlg galg -> - let map (c, tl as p) = - let tl' = List.Smart.map (fun t -> subst_type subst t) tl in - if tl' == tl then p else (c, tl') - in - let constrs' = List.Smart.map map galg.galg_constructors in - if constrs' == galg.galg_constructors then e - else GTydAlg { galg with galg_constructors = constrs' } -| GTydRec fields -> - let map (c, mut, t as p) = - let t' = subst_type subst t in - if t' == t then p else (c, mut, t') - in - let fields' = List.Smart.map map fields in - if fields' == fields then e else GTydRec fields' -| GTydOpn -> GTydOpn - -let subst_quant_typedef subst (prm, def as qdef) = - let def' = subst_typedef subst def in - if def' == def then qdef else (prm, def') - -let subst_type_scheme subst (prm, t as sch) = - let t' = subst_type subst t in - if t' == t then sch else (prm, t') - -let subst_or_relid subst ref = match ref with -| RelId _ -> ref -| AbsKn kn -> - let kn' = subst_or_tuple subst_kn subst kn in - if kn' == kn then ref else AbsKn kn' - -let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with -| CTypVar _ -> t -| CTypArrow (t1, t2) -> - let t1' = subst_rawtype subst t1 in - let t2' = subst_rawtype subst t2 in - if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') -| CTypRef (ref, tl) -> - let ref' = subst_or_relid subst ref in - let tl' = List.Smart.map (fun t -> subst_rawtype subst t) tl in - if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') - -let subst_tacref subst ref = match ref with -| RelId _ -> ref -| AbsKn (TacConstant kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacConstant kn') -| AbsKn (TacAlias kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacAlias kn') - -let subst_projection subst prj = match prj with -| RelId _ -> prj -| AbsKn kn -> - let kn' = subst_kn subst kn in - if kn' == kn then prj else AbsKn kn' - -let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with -| CPatVar _ -> p -| CPatRef (c, pl) -> - let pl' = List.Smart.map (fun p -> subst_rawpattern subst p) pl in - let c' = subst_or_relid subst c in - if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') -| CPatCnv (pat, ty) -> - let pat' = subst_rawpattern subst pat in - let ty' = subst_rawtype subst ty in - if pat' == pat && ty' == ty then p else CAst.make ?loc @@ CPatCnv (pat', ty') - -(** Used for notations *) -let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with -| CTacAtm _ -> t -| CTacRef ref -> - let ref' = subst_tacref subst ref in - if ref' == ref then t else CAst.make ?loc @@ CTacRef ref' -| CTacCst ref -> - let ref' = subst_or_relid subst ref in - if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' -| CTacFun (bnd, e) -> - let map pat = subst_rawpattern subst pat in - let bnd' = List.Smart.map map bnd in - let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') -| CTacApp (e, el) -> - let e' = subst_rawexpr subst e in - let el' = List.Smart.map (fun e -> subst_rawexpr subst e) el in - if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') -| CTacLet (isrec, bnd, e) -> - let map (na, e as p) = - let na' = subst_rawpattern subst na in - let e' = subst_rawexpr subst e in - if na' == na && e' == e then p else (na', e') - in - let bnd' = List.Smart.map map bnd in - let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') -| CTacCnv (e, c) -> - let e' = subst_rawexpr subst e in - let c' = subst_rawtype subst c in - if c' == c && e' == e then t else CAst.make ?loc @@ CTacCnv (e', c') -| CTacSeq (e1, e2) -> - let e1' = subst_rawexpr subst e1 in - let e2' = subst_rawexpr subst e2 in - if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') -| CTacCse (e, bl) -> - let map (p, e as x) = - let p' = subst_rawpattern subst p in - let e' = subst_rawexpr subst e in - if p' == p && e' == e then x else (p', e') - in - let e' = subst_rawexpr subst e in - let bl' = List.Smart.map map bl in - if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') -| CTacRec el -> - let map (prj, e as p) = - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then p else (prj', e') - in - let el' = List.Smart.map map el in - if el' == el then t else CAst.make ?loc @@ CTacRec el' -| CTacPrj (e, prj) -> - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then t else CAst.make ?loc @@ CTacPrj (e', prj') -| CTacSet (e, prj, r) -> - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - let r' = subst_rawexpr subst r in - if prj' == prj && e' == e && r' == r then t else CAst.make ?loc @@ CTacSet (e', prj', r') -| CTacExt _ -> assert false (** Should not be generated by globalization *) - -(** Registering *) - -let () = - let open Genintern in - let intern ist tac = - let env = match Genintern.Store.get ist.extra ltac2_env with - | None -> - (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) - let env = empty_env () in - if !Ltac_plugin.Tacintern.strict_check then env - else { env with env_str = false } - | Some env -> env - in - let loc = tac.loc in - let (tac, t) = intern_rec env tac in - let () = check_elt_unit loc env t in - (ist, tac) - in - Genintern.register_intern0 wit_ltac2 intern -let () = Genintern.register_subst0 wit_ltac2 subst_expr - -let () = - let open Genintern in - let intern ist (loc, id) = - let env = match Genintern.Store.get ist.extra ltac2_env with - | None -> - (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) - let env = empty_env () in - if !Ltac_plugin.Tacintern.strict_check then env - else { env with env_str = false } - | Some env -> env - in - let t = - try Id.Map.find id env.env_var - with Not_found -> - CErrors.user_err ?loc (str "Unbound value " ++ Id.print id) - in - let t = fresh_mix_type_scheme env t in - let () = unify ?loc env t (GTypRef (Other t_constr, [])) in - (ist, id) - in - Genintern.register_intern0 wit_ltac2_quotation intern - -let () = Genintern.register_subst0 wit_ltac2_quotation (fun _ id -> id) diff --git a/src/tac2intern.mli b/src/tac2intern.mli deleted file mode 100644 index d646b5cda5..0000000000 --- a/src/tac2intern.mli +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_tacexpr -> glb_tacexpr * type_scheme -val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef -val intern_open_type : raw_typexpr -> type_scheme - -(** Check that a term is a value. Only values are safe to marshall between - processes. *) -val is_value : glb_tacexpr -> bool -val check_unit : ?loc:Loc.t -> type_scheme -> unit - -val check_subtype : type_scheme -> type_scheme -> bool -(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] - also have type [t2]. *) - -val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr -val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr -val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef -val subst_type_scheme : substitution -> type_scheme -> type_scheme - -val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr - -(** {5 Notations} *) - -val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr -(** Replaces all qualified identifiers by their corresponding kernel name. The - set represents bound variables in the context. *) - -(** Errors *) - -val error_nargs_mismatch : ?loc:Loc.t -> ltac_constructor -> int -> int -> 'a -val error_nparams_mismatch : ?loc:Loc.t -> int -> int -> 'a - -(** Misc *) - -val drop_ltac2_env : Genintern.Store.t -> Genintern.Store.t diff --git a/src/tac2interp.ml b/src/tac2interp.ml deleted file mode 100644 index b0f8083aeb..0000000000 --- a/src/tac2interp.ml +++ /dev/null @@ -1,227 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* >= fun sigma -> - match Evd.Store.get (Evd.get_extra_data sigma) backtrace with - | None -> Proofview.tclUNIT [] - | Some bt -> Proofview.tclUNIT bt - -let set_backtrace bt = - Proofview.tclEVARMAP >>= fun sigma -> - let store = Evd.get_extra_data sigma in - let store = Evd.Store.set store backtrace bt in - let sigma = Evd.set_extra_data store sigma in - Proofview.Unsafe.tclEVARS sigma - -let with_frame frame tac = - if !print_ltac2_backtrace then - get_backtrace >>= fun bt -> - set_backtrace (frame :: bt) >>= fun () -> - tac >>= fun ans -> - set_backtrace bt >>= fun () -> - Proofview.tclUNIT ans - else tac - -type environment = Tac2env.environment = { - env_ist : valexpr Id.Map.t; -} - -let empty_environment = { - env_ist = Id.Map.empty; -} - -type closure = { - mutable clos_env : valexpr Id.Map.t; - (** Mutable so that we can implement recursive functions imperatively *) - clos_var : Name.t list; - (** Bound variables *) - clos_exp : glb_tacexpr; - (** Body *) - clos_ref : ltac_constant option; - (** Global constant from which the closure originates *) -} - -let push_name ist id v = match id with -| Anonymous -> ist -| Name id -> { env_ist = Id.Map.add id v ist.env_ist } - -let get_var ist id = - try Id.Map.find id ist.env_ist with Not_found -> - anomaly (str "Unbound variable " ++ Id.print id) - -let get_ref ist kn = - try - let data = Tac2env.interp_global kn in - data.Tac2env.gdata_expr - with Not_found -> - anomaly (str "Unbound reference" ++ KerName.print kn) - -let return = Proofview.tclUNIT - -let rec interp (ist : environment) = function -| GTacAtm (AtmInt n) -> return (Tac2ffi.of_int n) -| GTacAtm (AtmStr s) -> return (Tac2ffi.of_string (Bytes.of_string s)) -| GTacVar id -> return (get_var ist id) -| GTacRef kn -> - let data = get_ref ist kn in - return (eval_pure (Some kn) data) -| GTacFun (ids, e) -> - let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - let f = interp_app cls in - return (Tac2ffi.of_closure f) -| GTacApp (f, args) -> - interp ist f >>= fun f -> - Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - Tac2ffi.apply (Tac2ffi.to_closure f) args -| GTacLet (false, el, e) -> - let fold accu (na, e) = - interp ist e >>= fun e -> - return (push_name accu na e) - in - Proofview.Monad.List.fold_left fold ist el >>= fun ist -> - interp ist e -| GTacLet (true, el, e) -> - let map (na, e) = match e with - | GTacFun (ids, e) -> - let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - let f = Tac2ffi.of_closure (interp_app cls) in - na, cls, f - | _ -> anomaly (str "Ill-formed recursive function") - in - let fixs = List.map map el in - let fold accu (na, _, cls) = match na with - | Anonymous -> accu - | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } - in - let ist = List.fold_left fold ist fixs in - (* Hack to make a cycle imperatively in the environment *) - let iter (_, e, _) = e.clos_env <- ist.env_ist in - let () = List.iter iter fixs in - interp ist e -| GTacCst (_, n, []) -> return (Valexpr.make_int n) -| GTacCst (_, n, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (Valexpr.make_block n (Array.of_list el)) -| GTacCse (e, _, cse0, cse1) -> - interp ist e >>= fun e -> interp_case ist e cse0 cse1 -| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> - interp ist e >>= fun e -> interp_with ist e cse def -| GTacPrj (_, e, p) -> - interp ist e >>= fun e -> interp_proj ist e p -| GTacSet (_, e, p, r) -> - interp ist e >>= fun e -> - interp ist r >>= fun r -> - interp_set ist e p r -| GTacOpn (kn, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (Tac2ffi.of_open (kn, Array.of_list el)) -| GTacPrm (ml, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) -| GTacExt (tag, e) -> - let tpe = Tac2env.interp_ml_object tag in - with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) - -and interp_app f = - let ans = fun args -> - let { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } = f in - let frame = match kn with - | None -> FrAnon e - | Some kn -> FrLtac kn - in - let ist = { env_ist = ist } in - let ist = List.fold_left2 push_name ist ids args in - with_frame frame (interp ist e) - in - Tac2ffi.abstract (List.length f.clos_var) ans - -and interp_case ist e cse0 cse1 = - if Valexpr.is_int e then - interp ist cse0.(Tac2ffi.to_int e) - else - let (n, args) = Tac2ffi.to_block e in - let (ids, e) = cse1.(n) in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist e - -and interp_with ist e cse def = - let (kn, args) = Tac2ffi.to_open e in - let br = try Some (KNmap.find kn cse) with Not_found -> None in - begin match br with - | None -> - let (self, def) = def in - let ist = push_name ist self e in - interp ist def - | Some (self, ids, p) -> - let ist = push_name ist self e in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist p - end - -and interp_proj ist e p = - return (Valexpr.field e p) - -and interp_set ist e p r = - let () = Valexpr.set_field e p r in - return (Valexpr.make_int 0) - -and eval_pure kn = function -| GTacAtm (AtmInt n) -> Valexpr.make_int n -| GTacRef kn -> - let { Tac2env.gdata_expr = e } = - try Tac2env.interp_global kn - with Not_found -> assert false - in - eval_pure (Some kn) e -| GTacFun (na, e) -> - let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in - let f = interp_app cls in - Tac2ffi.of_closure f -| GTacCst (_, n, []) -> Valexpr.make_int n -| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) -| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) -| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ -| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> - anomaly (Pp.str "Term is not a syntactical value") - -and eval_unnamed e = eval_pure None e - - -(** Cross-boundary hacks. *) - -open Geninterp - -let val_env : environment Val.typ = Val.create "ltac2:env" -let env_ref = Id.of_string_soft "@@ltac2_env@@" - -let extract_env (Val.Dyn (tag, v)) : environment = -match Val.eq tag val_env with -| None -> assert false -| Some Refl -> v - -let get_env ist = - try extract_env (Id.Map.find env_ref ist) - with Not_found -> empty_environment - -let set_env env ist = - Id.Map.add env_ref (Val.Dyn (val_env, env)) ist diff --git a/src/tac2interp.mli b/src/tac2interp.mli deleted file mode 100644 index 21fdcd03af..0000000000 --- a/src/tac2interp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glb_tacexpr -> valexpr Proofview.tactic - -(* val interp_app : closure -> ml_tactic *) - -(** {5 Cross-boundary encodings} *) - -val get_env : Ltac_pretype.unbound_ltac_var_map -> environment -val set_env : environment -> Ltac_pretype.unbound_ltac_var_map -> Ltac_pretype.unbound_ltac_var_map - -(** {5 Exceptions} *) - -exception LtacError of KerName.t * valexpr array -(** Ltac2-defined exceptions seen from OCaml side *) - -(** {5 Backtrace} *) - -val get_backtrace : backtrace Proofview.tactic - -val with_frame : frame -> 'a Proofview.tactic -> 'a Proofview.tactic - -val print_ltac2_backtrace : bool ref diff --git a/src/tac2match.ml b/src/tac2match.ml deleted file mode 100644 index c9e549d47e..0000000000 --- a/src/tac2match.ml +++ /dev/null @@ -1,232 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* None - | None, Some c | Some c, None -> Some c - | Some c1, Some c2 -> - if equal_instances env sigma c1 c2 then Some c1 - else raise Not_coherent_metas - in - Id.Map.merge merge s1 s2 - -let matching_error = - CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") - -let imatching_error = (matching_error, Exninfo.null) - -(** A functor is introduced to share the environment and the - evar_map. They do not change and it would be a pity to introduce - closures everywhere just for the occasional calls to - {!equal_instances}. *) -module type StaticEnvironment = sig - val env : Environ.env - val sigma : Evd.evar_map -end -module PatternMatching (E:StaticEnvironment) = struct - - - (** {6 The pattern-matching monad } *) - - - (** To focus on the algorithmic portion of pattern-matching, the - bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) - (* spiwack: as we don't benefit from the various stream optimisations - of Haskell, it may be costly to give the monad in direct style such as - here. We may want to use some continuation passing style. *) - type 'a tac = 'a Proofview.tactic - type 'a m = { stream : 'r. ('a -> result -> 'r tac) -> result -> 'r tac } - - (** The empty substitution. *) - let empty_subst = Id.Map.empty - - (** Composes two substitutions using {!verify_metas_coherence}. It - must be a monoid with neutral element {!empty_subst}. Raises - [Not_coherent_metas] when composition cannot be achieved. *) - let subst_prod s1 s2 = - if is_empty_subst s1 then s2 - else if is_empty_subst s2 then s1 - else verify_metas_coherence E.env E.sigma s1 s2 - - (** Merge two writers (and ignore the first value component). *) - let merge m1 m2 = - try Some { - subst = subst_prod m1.subst m2.subst; - } - with Not_coherent_metas -> None - - (** Monadic [return]: returns a single success with empty substitutions. *) - let return (type a) (lhs:a) : a m = - { stream = fun k ctx -> k lhs ctx } - - (** Monadic bind: each success of [x] is replaced by the successes - of [f x]. The substitutions of [x] and [f x] are composed, - dropping the apparent successes when the substitutions are not - coherent. *) - let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = - { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } - - (** A variant of [(>>=)] when the first argument returns [unit]. *) - let (<*>) (type a) (m:unit m) (y:a m) : a m = - { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } - - (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } - - let run (m : 'a m) = - let ctx = { - subst = empty_subst ; - } in - let eval x ctx = Proofview.tclUNIT (x, ctx) in - m.stream eval ctx - - (** Chooses in a list, in the same order as the list *) - let rec pick (l:'a list) (e, info) : 'a m = match l with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | x :: l -> - { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } - - let pick l = pick l imatching_error - - let put_subst subst : unit m = - let s = { subst } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } - - (** {6 Pattern-matching} *) - - let pattern_match_term pat term = - match pat with - | MatchPattern p -> - begin - try - put_subst (Constr_matching.matches E.env E.sigma p term) <*> - return None - with Constr_matching.PatternMatchingFailure -> fail - end - | MatchContext p -> - - let rec map s (e, info) = - { stream = fun k ctx -> match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO ~info e - | IStream.Cons ({ Constr_matching.m_sub = (_, subst); m_ctx }, s) -> - let nctx = { subst } in - match merge ctx nctx with - | None -> (map s (e, info)).stream k ctx - | Some nctx -> Proofview.tclOR (k (Some (Lazy.force m_ctx)) nctx) (fun e -> (map s e).stream k ctx) - } - in - map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error - - let hyp_match_type pat hyps = - pick hyps >>= fun decl -> - let id = NamedDecl.get_id decl in - pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> - return (id, ctx) - - let _hyp_match_body_and_type bodypat typepat hyps = - pick hyps >>= function - | LocalDef (id,body,hyp) -> - pattern_match_term bodypat body >>= fun ctx_body -> - pattern_match_term typepat hyp >>= fun ctx_typ -> - return (id, ctx_body, ctx_typ) - | LocalAssum (id,hyp) -> fail - - let hyp_match pat hyps = - match pat with - | typepat -> - hyp_match_type typepat hyps -(* | Def ((_,hypname),bodypat,typepat) -> *) -(* hyp_match_body_and_type hypname bodypat typepat hyps *) - - (** [hyp_pattern_list_match pats hyps lhs], matches the list of - patterns [pats] against the hypotheses in [hyps], and eventually - returns [lhs]. *) - let rec hyp_pattern_list_match pats hyps accu = - match pats with - | pat::pats -> - hyp_match pat hyps >>= fun (matched_hyp, hyp_ctx) -> - let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in - let hyps = CList.remove_first select_matched_hyp hyps in - hyp_pattern_list_match pats hyps ((matched_hyp, hyp_ctx) :: accu) - | [] -> return accu - - let rule_match_goal hyps concl = function - | (hyppats,conclpat) -> - (* the rules are applied from the topmost one (in the concrete - syntax) to the bottommost. *) - let hyppats = List.rev hyppats in - pattern_match_term conclpat concl >>= fun ctx_concl -> - hyp_pattern_list_match hyppats hyps [] >>= fun hyps -> - return (hyps, ctx_concl) - -end - -let match_goal env sigma concl ~rev rule = - let open Proofview.Notations in - let hyps = EConstr.named_context env in - let hyps = if rev then List.rev hyps else hyps in - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.rule_match_goal hyps concl rule) >>= fun ((hyps, ctx_concl), subst) -> - Proofview.tclUNIT (hyps, ctx_concl, subst.subst) diff --git a/src/tac2match.mli b/src/tac2match.mli deleted file mode 100644 index c82c40d238..0000000000 --- a/src/tac2match.mli +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Evd.evar_map -> - constr -> - rev:bool -> - match_rule -> - ((Id.t * context option) list * (* List of hypotheses matching: name + context *) - context option * (* Context for conclusion *) - Ltac_pretype.patvar_map (* Pattern variable substitution *)) Proofview.tactic diff --git a/src/tac2print.ml b/src/tac2print.ml deleted file mode 100644 index f4cb290265..0000000000 --- a/src/tac2print.ml +++ /dev/null @@ -1,488 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* str "'" ++ str (pr n) - | GTypRef (Other kn, []) -> pr_typref kn - | GTypRef (Other kn, [t]) -> - let paren = match lvl with - | T5_r | T5_l | T2 | T1 -> fun x -> x - | T0 -> paren - in - paren (pr_glbtype T1 t ++ spc () ++ pr_typref kn) - | GTypRef (Other kn, tl) -> - let paren = match lvl with - | T5_r | T5_l | T2 | T1 -> fun x -> x - | T0 -> paren - in - paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) - | GTypArrow (t1, t2) -> - let paren = match lvl with - | T5_r -> fun x -> x - | T5_l | T2 | T1 | T0 -> paren - in - paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) - | GTypRef (Tuple 0, []) -> - Libnames.pr_qualid (Tac2env.shortest_qualid_of_type t_unit) - | GTypRef (Tuple _, tl) -> - let paren = match lvl with - | T5_r | T5_l -> fun x -> x - | T2 | T1 | T0 -> paren - in - paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) - in - hov 0 (pr_glbtype lvl c) - -let pr_glbtype pr c = pr_glbtype_gen pr T5_r c - -let int_name () = - let vars = ref Int.Map.empty in - fun n -> - if Int.Map.mem n !vars then Int.Map.find n !vars - else - let num = Int.Map.cardinal !vars in - let base = num mod 26 in - let rem = num / 26 in - let name = String.make 1 (Char.chr (97 + base)) in - let suff = if Int.equal rem 0 then "" else string_of_int rem in - let name = name ^ suff in - let () = vars := Int.Map.add n name !vars in - name - -(** Term printing *) - -let pr_constructor kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_constructor kn) - -let pr_projection kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) - -type exp_level = Tac2expr.exp_level = -| E5 -| E4 -| E3 -| E2 -| E1 -| E0 - -let pr_atom = function -| AtmInt n -> Pp.int n -| AtmStr s -> qstring s - -let pr_name = function -| Name id -> Id.print id -| Anonymous -> str "_" - -let find_constructor n empty def = - let rec find n = function - | [] -> assert false - | (id, []) as ans :: rem -> - if empty then - if Int.equal n 0 then ans - else find (pred n) rem - else find n rem - | (id, _ :: _) as ans :: rem -> - if not empty then - if Int.equal n 0 then ans - else find (pred n) rem - else find n rem - in - find n def - -let pr_internal_constructor tpe n is_const = - let data = match Tac2env.interp_type tpe with - | (_, GTydAlg data) -> data - | _ -> assert false - in - let (id, _) = find_constructor n is_const data.galg_constructors in - let kn = change_kn_label tpe id in - pr_constructor kn - -let order_branches cbr nbr def = - let rec order cidx nidx def = match def with - | [] -> [] - | (id, []) :: rem -> - let ans = order (succ cidx) nidx rem in - (id, [], cbr.(cidx)) :: ans - | (id, _ :: _) :: rem -> - let ans = order cidx (succ nidx) rem in - let (vars, e) = nbr.(nidx) in - (id, Array.to_list vars, e) :: ans - in - order 0 0 def - -let pr_glbexpr_gen lvl c = - let rec pr_glbexpr lvl = function - | GTacAtm atm -> pr_atom atm - | GTacVar id -> Id.print id - | GTacRef gr -> - let qid = shortest_qualid_of_ltac (TacConstant gr) in - Libnames.pr_qualid qid - | GTacFun (nas, c) -> - let nas = pr_sequence pr_name nas in - let paren = match lvl with - | E0 | E1 | E2 | E3 | E4 -> paren - | E5 -> fun x -> x - in - paren (hov 0 (hov 2 (str "fun" ++ spc () ++ nas) ++ spc () ++ str "=>" ++ spc () ++ - pr_glbexpr E5 c)) - | GTacApp (c, cl) -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - paren (hov 2 (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) - | GTacLet (mut, bnd, e) -> - let paren = match lvl with - | E0 | E1 | E2 | E3 | E4 -> paren - | E5 -> fun x -> x - in - let mut = if mut then str "rec" ++ spc () else mt () in - let pr_bnd (na, e) = - pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () - in - let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in - paren (hv 0 (hov 2 (str "let" ++ spc () ++ mut ++ bnd ++ str "in") ++ spc () ++ pr_glbexpr E5 e)) - | GTacCst (Tuple 0, _, _) -> str "()" - | GTacCst (Tuple _, _, cl) -> - let paren = match lvl with - | E0 | E1 -> paren - | E2 | E3 | E4 | E5 -> fun x -> x - in - paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) - | GTacCst (Other tpe, n, cl) -> - pr_applied_constructor lvl tpe n cl - | GTacCse (e, info, cst_br, ncst_br) -> - let e = pr_glbexpr E5 e in - let br = match info with - | Other kn -> - let def = match Tac2env.interp_type kn with - | _, GTydAlg { galg_constructors = def } -> def - | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false - in - let br = order_branches cst_br ncst_br def in - let pr_branch (cstr, vars, p) = - let cstr = change_kn_label kn cstr in - let cstr = pr_constructor cstr in - let vars = match vars with - | [] -> mt () - | _ -> spc () ++ pr_sequence pr_name vars - in - hov 4 (str "|" ++ spc () ++ hov 0 (cstr ++ vars ++ spc () ++ str "=>") ++ spc () ++ - hov 2 (pr_glbexpr E5 p)) ++ spc () - in - prlist pr_branch br - | Tuple n -> - let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in - let p = pr_glbexpr E5 p in - let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in - hov 4 (str "|" ++ spc () ++ hov 0 (paren vars ++ spc () ++ str "=>") ++ spc () ++ p) - in - v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ spc () ++ str "end") - | GTacWth wth -> - let e = pr_glbexpr E5 wth.opn_match in - let pr_pattern c self vars p = - let self = match self with - | Anonymous -> mt () - | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id - in - hov 4 (str "|" ++ spc () ++ hov 0 (c ++ vars ++ self ++ spc () ++ str "=>") ++ spc () ++ - hov 2 (pr_glbexpr E5 p)) ++ spc () - in - let pr_branch (cstr, (self, vars, p)) = - let cstr = pr_constructor cstr in - let vars = match Array.to_list vars with - | [] -> mt () - | vars -> spc () ++ pr_sequence pr_name vars - in - pr_pattern cstr self vars p - in - let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in - let (def_as, def_p) = wth.opn_default in - let def = pr_pattern (str "_") def_as (mt ()) def_p in - let br = br ++ def in - v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ str "end") - | GTacPrj (kn, e, n) -> - let def = match Tac2env.interp_type kn with - | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false - in - let (proj, _, _) = List.nth def n in - let proj = change_kn_label kn proj in - let proj = pr_projection proj in - let e = pr_glbexpr E0 e in - hov 0 (e ++ str "." ++ paren proj) - | GTacSet (kn, e, n, r) -> - let def = match Tac2env.interp_type kn with - | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false - in - let (proj, _, _) = List.nth def n in - let proj = change_kn_label kn proj in - let proj = pr_projection proj in - let e = pr_glbexpr E0 e in - let r = pr_glbexpr E1 r in - hov 0 (e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r) - | GTacOpn (kn, cl) -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let c = pr_constructor kn in - paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) - | GTacExt (tag, arg) -> - let tpe = interp_ml_object tag in - hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) - | GTacPrm (prm, args) -> - let args = match args with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args - in - hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ - qstring prm.mltac_tactic ++ args) - and pr_applied_constructor lvl tpe n cl = - let _, data = Tac2env.interp_type tpe in - if KerName.equal tpe t_list then - let rec factorize accu = function - | GTacCst (_, 0, []) -> accu, None - | GTacCst (_, 0, [e; l]) -> factorize (e :: accu) l - | e -> accu, Some e - in - let l, e = factorize [] (GTacCst (Other tpe, n, cl)) in - match e with - | None -> - let pr e = pr_glbexpr E4 e in - hov 2 (str "[" ++ prlist_with_sep pr_semicolon pr (List.rev l) ++ str "]") - | Some e -> - let paren = match lvl with - | E0 | E1 | E2 -> paren - | E3 | E4 | E5 -> fun x -> x - in - let pr e = pr_glbexpr E1 e in - let pr_cons () = spc () ++ str "::" ++ spc () in - paren (hov 2 (prlist_with_sep pr_cons pr (List.rev (e :: l)))) - else match data with - | GTydAlg def -> - let paren = match lvl with - | E0 -> - if List.is_empty cl then fun x -> x else paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let cstr = pr_internal_constructor tpe n (List.is_empty cl) in - let cl = match cl with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl - in - paren (hov 2 (cstr ++ cl)) - | GTydRec def -> - let args = List.combine def cl in - let pr_arg ((id, _, _), arg) = - let kn = change_kn_label tpe id in - pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg - in - let args = prlist_with_sep pr_semicolon pr_arg args in - hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") - | (GTydDef _ | GTydOpn) -> assert false - in - hov 0 (pr_glbexpr lvl c) - - - -let pr_glbexpr c = - pr_glbexpr_gen E5 c - -(** Toplevel printers *) - -let rec subst_type subst (t : 'a glb_typexpr) = match t with -| GTypVar id -> subst.(id) -| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) -| GTypRef (qid, args) -> - GTypRef (qid, List.map (fun t -> subst_type subst t) args) - -let unfold kn args = - let (nparams, def) = Tac2env.interp_type kn in - match def with - | GTydDef (Some def) -> - let args = Array.of_list args in - Some (subst_type args def) - | _ -> None - -let rec kind t = match t with -| GTypVar id -> GTypVar id -| GTypRef (Other kn, tl) -> - begin match unfold kn tl with - | None -> t - | Some t -> kind t - end -| GTypArrow _ | GTypRef (Tuple _, _) -> t - -type val_printer = - { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } - -let printers = ref KNmap.empty - -let register_val_printer kn pr = - printers := KNmap.add kn pr !printers - -open Tac2ffi - -let rec pr_valexpr env sigma v t = match kind t with -| GTypVar _ -> str "" -| GTypRef (Other kn, params) -> - let pr = try Some (KNmap.find kn !printers) with Not_found -> None in - begin match pr with - | Some pr -> pr.val_printer env sigma v params - | None -> - let n, repr = Tac2env.interp_type kn in - if KerName.equal kn t_list then - pr_val_list env sigma (to_list (fun v -> repr_to valexpr v) v) (List.hd params) - else match repr with - | GTydDef None -> str "" - | GTydDef (Some _) -> - (* Shouldn't happen thanks to kind *) - assert false - | GTydAlg alg -> - if Valexpr.is_int v then - pr_internal_constructor kn (Tac2ffi.to_int v) true - else - let (n, args) = Tac2ffi.to_block v in - let (id, tpe) = find_constructor n false alg.galg_constructors in - let knc = change_kn_label kn id in - let args = pr_constrargs env sigma params args tpe in - hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - | GTydRec rcd -> - let (_, args) = Tac2ffi.to_block v in - pr_record env sigma params args rcd - | GTydOpn -> - begin match Tac2ffi.to_open v with - | (knc, [||]) -> pr_constructor knc - | (knc, args) -> - let data = Tac2env.interp_constructor knc in - let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in - hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - end - end -| GTypArrow _ -> str "" -| GTypRef (Tuple 0, []) -> str "()" -| GTypRef (Tuple _, tl) -> - let blk = Array.to_list (snd (to_block v)) in - if List.length blk == List.length tl then - let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in - hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") - else - str "" - -and pr_constrargs env sigma params args tpe = - let subst = Array.of_list params in - let tpe = List.map (fun t -> subst_type subst t) tpe in - let args = Array.to_list args in - let args = List.combine args tpe in - prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args - -and pr_record env sigma params args rcd = - let subst = Array.of_list params in - let map (id, _, tpe) = (id, subst_type subst tpe) in - let rcd = List.map map rcd in - let args = Array.to_list args in - let fields = List.combine rcd args in - let pr_field ((id, t), arg) = - Id.print id ++ spc () ++ str ":=" ++ spc () ++ pr_valexpr env sigma arg t - in - str "{" ++ spc () ++ prlist_with_sep pr_semicolon pr_field fields ++ spc () ++ str "}" - -and pr_val_list env sigma args tpe = - let pr v = pr_valexpr env sigma v tpe in - str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" - -let register_init n f = - let kn = KerName.make Tac2env.coq_prefix (Label.make n) in - register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } - -let () = register_init "int" begin fun _ _ n -> - let n = to_int n in - Pp.int n -end - -let () = register_init "string" begin fun _ _ s -> - let s = to_string s in - Pp.quote (str (Bytes.to_string s)) -end - -let () = register_init "ident" begin fun _ _ id -> - let id = to_ident id in - str "@" ++ Id.print id -end - -let () = register_init "constr" begin fun env sigma c -> - let c = to_constr c in - let c = try Printer.pr_leconstr_env env sigma c with _ -> str "..." in - str "constr:(" ++ c ++ str ")" -end - -let () = register_init "pattern" begin fun env sigma c -> - let c = to_pattern c in - let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in - str "pattern:(" ++ c ++ str ")" -end - -let () = register_init "message" begin fun _ _ pp -> - str "message:(" ++ to_pp pp ++ str ")" -end - -let () = register_init "err" begin fun _ _ e -> - let e = to_ext val_exn e in - let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in - str "err:(" ++ CErrors.print_no_report e ++ str ")" -end - -let () = - let kn = KerName.make Tac2env.coq_prefix (Label.make "array") in - let val_printer env sigma v arg = match arg with - | [arg] -> - let (_, v) = to_block v in - str "[|" ++ spc () ++ - prvect_with_sep pr_semicolon (fun a -> pr_valexpr env sigma a arg) v ++ - spc () ++ str "|]" - | _ -> assert false - in - register_val_printer kn { val_printer } diff --git a/src/tac2print.mli b/src/tac2print.mli deleted file mode 100644 index 9b9db2937d..0000000000 --- a/src/tac2print.mli +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.t -val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> Pp.t -val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t - -(** {5 Printing expressions} *) - -val pr_constructor : ltac_constructor -> Pp.t -val pr_internal_constructor : type_constant -> int -> bool -> Pp.t -val pr_projection : ltac_projection -> Pp.t -val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t -val pr_glbexpr : glb_tacexpr -> Pp.t - -(** {5 Printing values}*) - -type val_printer = - { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } - -val register_val_printer : type_constant -> val_printer -> unit - -val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp.t - -(** {5 Utilities} *) - -val int_name : unit -> (int -> string) -(** Create a function that give names to integers. The names are generated on - the fly, in the order they are encountered. *) diff --git a/src/tac2qexpr.mli b/src/tac2qexpr.mli deleted file mode 100644 index 400ab1a092..0000000000 --- a/src/tac2qexpr.mli +++ /dev/null @@ -1,173 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0)) -| [e] -> e -| el -> - let len = List.length el in - CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) - -let of_int {loc;v=n} = - CAst.make ?loc @@ CTacAtm (AtmInt n) - -let of_option ?loc f opt = match opt with -| None -> constructor ?loc (coq_core "None") [] -| Some e -> constructor ?loc (coq_core "Some") [f e] - -let inj_wit ?loc wit x = - CAst.make ?loc @@ CTacExt (wit, x) - -let of_variable {loc;v=id} = - let qid = Libnames.qualid_of_ident ?loc id in - if Tac2env.is_constructor qid then - CErrors.user_err ?loc (str "Invalid identifier") - else CAst.make ?loc @@ CTacRef (RelId qid) - -let of_anti f = function -| QExpr x -> f x -| QAnti id -> of_variable id - -let of_ident {loc;v=id} = inj_wit ?loc wit_ident id - -let of_constr c = - let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc wit_constr c - -let of_open_constr c = - let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc wit_open_constr c - -let of_bool ?loc b = - let c = if b then coq_core "true" else coq_core "false" in - constructor ?loc c [] - -let rec of_list ?loc f = function -| [] -> constructor (coq_core "[]") [] -| e :: l -> - constructor ?loc (coq_core "::") [f e; of_list ?loc f l] - -let of_qhyp {loc;v=h} = match h with -| QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] -| QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] - -let of_bindings {loc;v=b} = match b with -| QNoBindings -> - std_constructor ?loc "NoBindings" [] -| QImplicitBindings tl -> - std_constructor ?loc "ImplicitBindings" [of_list ?loc of_open_constr tl] -| QExplicitBindings tl -> - let map e = of_pair (fun q -> of_anti of_qhyp q) of_open_constr e in - std_constructor ?loc "ExplicitBindings" [of_list ?loc map tl] - -let of_constr_with_bindings c = of_pair of_open_constr of_bindings c - -let rec of_intro_pattern {loc;v=pat} = match pat with -| QIntroForthcoming b -> - std_constructor ?loc "IntroForthcoming" [of_bool b] -| QIntroNaming iname -> - std_constructor ?loc "IntroNaming" [of_intro_pattern_naming iname] -| QIntroAction iact -> - std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] - -and of_intro_pattern_naming {loc;v=pat} = match pat with -| QIntroIdentifier id -> - std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] -| QIntroFresh id -> - std_constructor ?loc "IntroFresh" [of_anti of_ident id] -| QIntroAnonymous -> - std_constructor ?loc "IntroAnonymous" [] - -and of_intro_pattern_action {loc;v=pat} = match pat with -| QIntroWildcard -> - std_constructor ?loc "IntroWildcard" [] -| QIntroOrAndPattern pat -> - std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern pat] -| QIntroInjection il -> - std_constructor ?loc "IntroInjection" [of_intro_patterns il] -| QIntroRewrite b -> - std_constructor ?loc "IntroRewrite" [of_bool ?loc b] - -and of_or_and_intro_pattern {loc;v=pat} = match pat with -| QIntroOrPattern ill -> - std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] -| QIntroAndPattern il -> - std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] - -and of_intro_patterns {loc;v=l} = - of_list ?loc of_intro_pattern l - -let of_hyp_location_flag ?loc = function -| Locus.InHyp -> std_constructor ?loc "InHyp" [] -| Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] -| Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] - -let of_occurrences {loc;v=occ} = match occ with -| QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] -| QAllOccurrencesBut occs -> - let map occ = of_anti of_int occ in - let occs = of_list ?loc map occs in - std_constructor ?loc "AllOccurrencesBut" [occs] -| QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] -| QOnlyOccurrences occs -> - let map occ = of_anti of_int occ in - let occs = of_list ?loc map occs in - std_constructor ?loc "OnlyOccurrences" [occs] - -let of_hyp_location ?loc ((occs, id), flag) = - of_tuple ?loc [ - of_anti of_ident id; - of_occurrences occs; - of_hyp_location_flag ?loc flag; - ] - -let of_clause {loc;v=cl} = - let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in - let concl = of_occurrences cl.q_concl_occs in - CAst.make ?loc @@ CTacRec ([ - std_proj "on_hyps", hyps; - std_proj "on_concl", concl; - ]) - -let of_destruction_arg {loc;v=arg} = match arg with -| QElimOnConstr c -> - let arg = thunk (of_constr_with_bindings c) in - std_constructor ?loc "ElimOnConstr" [arg] -| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] -| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] - -let of_induction_clause {loc;v=cl} = - let arg = of_destruction_arg cl.indcl_arg in - let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in - let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in - let in_ = of_option ?loc of_clause cl.indcl_in in - CAst.make ?loc @@ CTacRec ([ - std_proj "indcl_arg", arg; - std_proj "indcl_eqn", eqn; - std_proj "indcl_as", as_; - std_proj "indcl_in", in_; - ]) - -let check_pattern_id ?loc id = - if Tac2env.is_constructor (Libnames.qualid_of_ident id) then - CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) - -let pattern_vars pat = - let rec aux () accu pat = match pat.CAst.v with - | Constrexpr.CPatVar id - | Constrexpr.CEvar (id, []) -> - let () = check_pattern_id ?loc:pat.CAst.loc id in - Id.Set.add id accu - | _ -> - Constrexpr_ops.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat - in - aux () Id.Set.empty pat - -let abstract_vars loc vars tac = - let get_name = function Name id -> Some id | Anonymous -> None in - let def = try Some (List.find_map get_name vars) with Not_found -> None in - let na, tac = match def with - | None -> (Anonymous, tac) - | Some id0 -> - (* Trick: in order not to shadow a variable nor to choose an arbitrary - name, we reuse one which is going to be shadowed by the matched - variables anyways. *) - let build_bindings (n, accu) na = match na with - | Anonymous -> (n + 1, accu) - | Name _ -> - let get = global_ref ?loc (kername array_prefix "get") in - let args = [of_variable CAst.(make ?loc id0); of_int CAst.(make ?loc n)] in - let e = CAst.make ?loc @@ CTacApp (get, args) in - let accu = (CAst.make ?loc @@ CPatVar na, e) :: accu in - (n + 1, accu) - in - let (_, bnd) = List.fold_left build_bindings (0, []) vars in - let tac = CAst.make ?loc @@ CTacLet (false, bnd, tac) in - (Name id0, tac) - in - CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], tac) - -let of_pattern p = - inj_wit ?loc:p.CAst.loc wit_pattern p - -let of_conversion {loc;v=c} = match c with -| QConvert c -> - let pat = of_option ?loc of_pattern None in - let c = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar Anonymous], of_constr c) in - of_tuple ?loc [pat; c] -| QConvertWith (pat, c) -> - let vars = pattern_vars pat in - let pat = of_option ?loc of_pattern (Some pat) in - let c = of_constr c in - (* Order is critical here *) - let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in - let c = abstract_vars loc vars c in - of_tuple [pat; c] - -let of_repeat {loc;v=r} = match r with -| QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] -| QUpTo n -> std_constructor ?loc "UpTo" [of_int n] -| QRepeatStar -> std_constructor ?loc "RepeatStar" [] -| QRepeatPlus -> std_constructor ?loc "RepeatPlus" [] - -let of_orient loc b = - if b then std_constructor ?loc "LTR" [] - else std_constructor ?loc "RTL" [] - -let of_rewriting {loc;v=rew} = - let orient = - let {loc;v=orient} = rew.rew_orient in - of_option ?loc (fun b -> of_orient loc b) orient - in - let repeat = of_repeat rew.rew_repeat in - let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in - CAst.make ?loc @@ CTacRec ([ - std_proj "rew_orient", orient; - std_proj "rew_repeat", repeat; - std_proj "rew_equatn", equatn; - ]) - -let of_hyp ?loc id = - let hyp = global_ref ?loc (control_core "hyp") in - CAst.make ?loc @@ CTacApp (hyp, [of_ident id]) - -let of_exact_hyp ?loc id = - let refine = global_ref ?loc (control_core "refine") in - CAst.make ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) - -let of_exact_var ?loc id = - let refine = global_ref ?loc (control_core "refine") in - CAst.make ?loc @@ CTacApp (refine, [thunk (of_variable id)]) - -let of_dispatch tacs = - let loc = tacs.loc in - let default = function - | Some e -> thunk e - | None -> thunk (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0))) - in - let map e = of_pair default (fun l -> of_list ?loc default l) (CAst.make ?loc e) in - of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs - -let make_red_flag l = - let open Genredexpr in - let rec add_flag red = function - | [] -> red - | {v=flag} :: lf -> - let red = match flag with - | QBeta -> { red with rBeta = true } - | QMatch -> { red with rMatch = true } - | QFix -> { red with rFix = true } - | QCofix -> { red with rCofix = true } - | QZeta -> { red with rZeta = true } - | QConst {loc;v=l} -> - if red.rDelta then - CErrors.user_err ?loc Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); - { red with rConst = red.rConst @ l } - | QDeltaBut {loc;v=l} -> - if red.rConst <> [] && not red.rDelta then - CErrors.user_err ?loc Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); - { red with rConst = red.rConst @ l; rDelta = true } - | QIota -> - { red with rMatch = true; rFix = true; rCofix = true } - in - add_flag red lf - in - add_flag - {rBeta = false; rMatch = false; rFix = false; rCofix = false; - rZeta = false; rDelta = false; rConst = []} - l - -let of_reference r = - let of_ref ref = - inj_wit ?loc:ref.loc wit_reference ref - in - of_anti of_ref r - -let of_strategy_flag {loc;v=flag} = - let open Genredexpr in - let flag = make_red_flag flag in - CAst.make ?loc @@ CTacRec ([ - std_proj "rBeta", of_bool ?loc flag.rBeta; - std_proj "rMatch", of_bool ?loc flag.rMatch; - std_proj "rFix", of_bool ?loc flag.rFix; - std_proj "rCofix", of_bool ?loc flag.rCofix; - std_proj "rZeta", of_bool ?loc flag.rZeta; - std_proj "rDelta", of_bool ?loc flag.rDelta; - std_proj "rConst", of_list ?loc of_reference flag.rConst; - ]) - -let of_hintdb {loc;v=hdb} = match hdb with -| QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None -| QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) - -let extract_name ?loc oid = match oid with -| None -> Anonymous -| Some id -> - let () = check_pattern_id ?loc id in - Name id - -(** For every branch in the matching, generate a corresponding term of type - [(match_kind * pattern * (context -> constr array -> 'a))] - where the function binds the names from the pattern to the contents of the - constr array. *) -let of_constr_matching {loc;v=m} = - let map {loc;v=({loc=ploc;v=pat}, tac)} = - let (knd, pat, na) = match pat with - | QConstrMatchPattern pat -> - let knd = constructor ?loc (pattern_core "MatchPattern") [] in - (knd, pat, Anonymous) - | QConstrMatchContext (id, pat) -> - let na = extract_name ?loc id in - let knd = constructor ?loc (pattern_core "MatchContext") [] in - (knd, pat, na) - in - let vars = pattern_vars pat in - (* Order of elements is crucial here! *) - let vars = Id.Set.elements vars in - let vars = List.map (fun id -> Name id) vars in - let e = abstract_vars loc vars tac in - let e = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], e) in - let pat = inj_wit ?loc:ploc wit_pattern pat in - of_tuple [knd; pat; e] - in - of_list ?loc map m - -(** From the patterns and the body of the branch, generate: - - a goal pattern: (constr_match list * constr_match) - - a branch function (ident array -> context array -> constr array -> context -> 'a) -*) -let of_goal_matching {loc;v=gm} = - let mk_pat {loc;v=p} = match p with - | QConstrMatchPattern pat -> - let knd = constructor ?loc (pattern_core "MatchPattern") [] in - (Anonymous, pat, knd) - | QConstrMatchContext (id, pat) -> - let na = extract_name ?loc id in - let knd = constructor ?loc (pattern_core "MatchContext") [] in - (na, pat, knd) - in - let mk_gpat {loc;v=p} = - let concl_pat = p.q_goal_match_concl in - let hyps_pats = p.q_goal_match_hyps in - let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in - let vars = pattern_vars concl_pat in - let map accu (na, pat) = - let (ctx, pat, knd) = mk_pat pat in - let vars = pattern_vars pat in - (Id.Set.union vars accu, (na, ctx, pat, knd)) - in - let (vars, hyps_pats) = List.fold_left_map map vars hyps_pats in - let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in - let concl = of_tuple [concl_knd; of_pattern concl_pat] in - let r = of_tuple [of_list ?loc map hyps_pats; concl] in - let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in - let map (_, na, _, _) = na in - let hctx = List.map map hyps_pats in - (* Order of elements is crucial here! *) - let vars = Id.Set.elements vars in - let subst = List.map (fun id -> Name id) vars in - (r, hyps, hctx, subst, concl_ctx) - in - let map {loc;v=(pat, tac)} = - let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in - let tac = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar cctx], tac) in - let tac = abstract_vars loc subst tac in - let tac = abstract_vars loc hctx tac in - let tac = abstract_vars loc hyps tac in - of_tuple ?loc [pat; tac] - in - of_list ?loc map gm - -let of_move_location {loc;v=mv} = match mv with -| QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] -| QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] -| QMoveFirst -> std_constructor ?loc "MoveFirst" [] -| QMoveLast -> std_constructor ?loc "MoveLast" [] - -let of_pose p = - of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p - -let of_assertion {loc;v=ast} = match ast with -| QAssertType (ipat, c, tac) -> - let ipat = of_option of_intro_pattern ipat in - let c = of_constr c in - let tac = of_option thunk tac in - std_constructor ?loc "AssertType" [ipat; c; tac] -| QAssertValue (id, c) -> - let id = of_anti of_ident id in - let c = of_constr c in - std_constructor ?loc "AssertValue" [id; c] diff --git a/src/tac2quote.mli b/src/tac2quote.mli deleted file mode 100644 index 1b03dad8ec..0000000000 --- a/src/tac2quote.mli +++ /dev/null @@ -1,102 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ltac_constructor -> raw_tacexpr list -> raw_tacexpr - -val thunk : raw_tacexpr -> raw_tacexpr - -val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr - -val of_int : int CAst.t -> raw_tacexpr - -val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) CAst.t -> raw_tacexpr - -val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr - -val of_variable : Id.t CAst.t -> raw_tacexpr - -val of_ident : Id.t CAst.t -> raw_tacexpr - -val of_constr : Constrexpr.constr_expr -> raw_tacexpr - -val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr - -val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr - -val of_bindings : bindings -> raw_tacexpr - -val of_intro_pattern : intro_pattern -> raw_tacexpr - -val of_intro_patterns : intro_pattern list CAst.t -> raw_tacexpr - -val of_clause : clause -> raw_tacexpr - -val of_destruction_arg : destruction_arg -> raw_tacexpr - -val of_induction_clause : induction_clause -> raw_tacexpr - -val of_conversion : conversion -> raw_tacexpr - -val of_rewriting : rewriting -> raw_tacexpr - -val of_occurrences : occurrences -> raw_tacexpr - -val of_hintdb : hintdb -> raw_tacexpr - -val of_move_location : move_location -> raw_tacexpr - -val of_reference : reference or_anti -> raw_tacexpr - -val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr -(** id ↦ 'Control.hyp @id' *) - -val of_exact_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr -(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) - -val of_exact_var : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr -(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) - -val of_dispatch : dispatch -> raw_tacexpr - -val of_strategy_flag : strategy_flag -> raw_tacexpr - -val of_pose : pose -> raw_tacexpr - -val of_assertion : assertion -> raw_tacexpr - -val of_constr_matching : constr_matching -> raw_tacexpr - -val of_goal_matching : goal_matching -> raw_tacexpr - -(** {5 Generic arguments} *) - -val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag - -val wit_ident : (Id.t, Id.t) Arg.tag - -val wit_reference : (reference, GlobRef.t) Arg.tag - -val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag - -val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag - -val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag -(** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) - -val wit_ltac1val : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag -(** Ltac1 AST quotation, seen as a value-returning expression, with type Ltac1.t. *) diff --git a/src/tac2stdlib.ml b/src/tac2stdlib.ml deleted file mode 100644 index ffef2c05fd..0000000000 --- a/src/tac2stdlib.ml +++ /dev/null @@ -1,578 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false) f - -let return x = Proofview.tclUNIT x -let v_unit = Value.of_unit () -let thaw r f = Tac2ffi.app_fun1 f unit r () -let uthaw r f = Tac2ffi.app_fun1 (to_fun1 unit r f) unit r () -let thunk r = fun1 unit r - -let to_name c = match Value.to_option Value.to_ident c with -| None -> Anonymous -| Some id -> Name id - -let name = make_to_repr to_name - -let to_occurrences = function -| ValInt 0 -> AllOccurrences -| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list Value.to_int vl) -| ValInt 1 -> NoOccurrences -| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) -| _ -> assert false - -let occurrences = make_to_repr to_occurrences - -let to_hyp_location_flag v = match Value.to_int v with -| 0 -> InHyp -| 1 -> InHypTypeOnly -| 2 -> InHypValueOnly -| _ -> assert false - -let to_clause v = match Value.to_tuple v with -| [| hyps; concl |] -> - let cast v = match Value.to_tuple v with - | [| hyp; occ; flag |] -> - (Value.to_ident hyp, to_occurrences occ, to_hyp_location_flag flag) - | _ -> assert false - in - let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in - { onhyps = hyps; concl_occs = to_occurrences concl; } -| _ -> assert false - -let clause = make_to_repr to_clause - -let to_red_flag v = match Value.to_tuple v with -| [| beta; iota; fix; cofix; zeta; delta; const |] -> - { - rBeta = Value.to_bool beta; - rMatch = Value.to_bool iota; - rFix = Value.to_bool fix; - rCofix = Value.to_bool cofix; - rZeta = Value.to_bool zeta; - rDelta = Value.to_bool delta; - rConst = Value.to_list Value.to_reference const; - } -| _ -> assert false - -let red_flags = make_to_repr to_red_flag - -let pattern_with_occs = pair pattern occurrences - -let constr_with_occs = pair constr occurrences - -let reference_with_occs = pair reference occurrences - -let rec to_intro_pattern v = match Value.to_block v with -| (0, [| b |]) -> IntroForthcoming (Value.to_bool b) -| (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) -| (2, [| act |]) -> IntroAction (to_intro_pattern_action act) -| _ -> assert false - -and to_intro_pattern_naming = function -| ValBlk (0, [| id |]) -> IntroIdentifier (Value.to_ident id) -| ValBlk (1, [| id |]) -> IntroFresh (Value.to_ident id) -| ValInt 0 -> IntroAnonymous -| _ -> assert false - -and to_intro_pattern_action = function -| ValInt 0 -> IntroWildcard -| ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) -| ValBlk (1, [| inj |]) -> - let map ipat = to_intro_pattern ipat in - IntroInjection (Value.to_list map inj) -| ValBlk (2, [| c; ipat |]) -> - let c = Value.to_fun1 Value.unit Value.constr c in - IntroApplyOn (c, to_intro_pattern ipat) -| ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) -| _ -> assert false - -and to_or_and_intro_pattern v = match Value.to_block v with -| (0, [| ill |]) -> - IntroOrPattern (Value.to_list to_intro_patterns ill) -| (1, [| il |]) -> - IntroAndPattern (to_intro_patterns il) -| _ -> assert false - -and to_intro_patterns il = - Value.to_list to_intro_pattern il - -let intro_pattern = make_to_repr to_intro_pattern - -let intro_patterns = make_to_repr to_intro_patterns - -let to_destruction_arg v = match Value.to_block v with -| (0, [| c |]) -> - let c = uthaw constr_with_bindings c in - ElimOnConstr c -| (1, [| id |]) -> ElimOnIdent (Value.to_ident id) -| (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) -| _ -> assert false - -let destruction_arg = make_to_repr to_destruction_arg - -let to_induction_clause v = match Value.to_tuple v with -| [| arg; eqn; as_; in_ |] -> - let arg = to_destruction_arg arg in - let eqn = Value.to_option to_intro_pattern_naming eqn in - let as_ = Value.to_option to_or_and_intro_pattern as_ in - let in_ = Value.to_option to_clause in_ in - (arg, eqn, as_, in_) -| _ -> - assert false - -let induction_clause = make_to_repr to_induction_clause - -let to_assertion v = match Value.to_block v with -| (0, [| ipat; t; tac |]) -> - let to_tac t = Value.to_fun1 Value.unit Value.unit t in - let ipat = Value.to_option to_intro_pattern ipat in - let t = Value.to_constr t in - let tac = Value.to_option to_tac tac in - AssertType (ipat, t, tac) -| (1, [| id; c |]) -> - AssertValue (Value.to_ident id, Value.to_constr c) -| _ -> assert false - -let assertion = make_to_repr to_assertion - -let to_multi = function -| ValBlk (0, [| n |]) -> Precisely (Value.to_int n) -| ValBlk (1, [| n |]) -> UpTo (Value.to_int n) -| ValInt 0 -> RepeatStar -| ValInt 1 -> RepeatPlus -| _ -> assert false - -let to_rewriting v = match Value.to_tuple v with -| [| orient; repeat; c |] -> - let orient = Value.to_option Value.to_bool orient in - let repeat = to_multi repeat in - let c = uthaw constr_with_bindings c in - (orient, repeat, c) -| _ -> assert false - -let rewriting = make_to_repr to_rewriting - -let to_debug v = match Value.to_int v with -| 0 -> Hints.Off -| 1 -> Hints.Info -| 2 -> Hints.Debug -| _ -> assert false - -let debug = make_to_repr to_debug - -let to_strategy v = match Value.to_int v with -| 0 -> Class_tactics.Bfs -| 1 -> Class_tactics.Dfs -| _ -> assert false - -let strategy = make_to_repr to_strategy - -let to_inversion_kind v = match Value.to_int v with -| 0 -> Inv.SimpleInversion -| 1 -> Inv.FullInversion -| 2 -> Inv.FullInversionClear -| _ -> assert false - -let inversion_kind = make_to_repr to_inversion_kind - -let to_move_location = function -| ValInt 0 -> Logic.MoveFirst -| ValInt 1 -> Logic.MoveLast -| ValBlk (0, [|id|]) -> Logic.MoveAfter (Value.to_ident id) -| ValBlk (1, [|id|]) -> Logic.MoveBefore (Value.to_ident id) -| _ -> assert false - -let move_location = make_to_repr to_move_location - -let to_generalize_arg v = match Value.to_tuple v with -| [| c; occs; na |] -> - (Value.to_constr c, to_occurrences occs, to_name na) -| _ -> assert false - -let generalize_arg = make_to_repr to_generalize_arg - -(** Standard tactics sharing their implementation with Ltac1 *) - -let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } - -let lift tac = tac <*> return v_unit - -let define_prim0 name tac = - let tac _ = lift tac in - Tac2env.define_primitive (pname name) (mk_closure arity_one tac) - -let define_prim1 name r0 f = - let tac x = lift (f (Value.repr_to r0 x)) in - Tac2env.define_primitive (pname name) (mk_closure arity_one tac) - -let define_prim2 name r0 r1 f = - let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) - -let define_prim3 name r0 r1 r2 f = - let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) - -let define_prim4 name r0 r1 r2 r3 f = - let tac x y z u = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) - -let define_prim5 name r0 r1 r2 r3 r4 f = - let tac x y z u v = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u) (Value.repr_to r4 v)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) - -(** Tactics from Tacexpr *) - -let () = define_prim2 "tac_intros" bool intro_patterns begin fun ev ipat -> - Tac2tactics.intros_patterns ev ipat -end - -let () = define_prim4 "tac_apply" bool bool (list (thunk constr_with_bindings)) (option (pair ident (option intro_pattern))) begin fun adv ev cb ipat -> - Tac2tactics.apply adv ev cb ipat -end - -let () = define_prim3 "tac_elim" bool constr_with_bindings (option constr_with_bindings) begin fun ev c copt -> - Tac2tactics.elim ev c copt -end - -let () = define_prim2 "tac_case" bool constr_with_bindings begin fun ev c -> - Tac2tactics.general_case_analysis ev c -end - -let () = define_prim1 "tac_generalize" (list generalize_arg) begin fun cl -> - Tac2tactics.generalize cl -end - -let () = define_prim1 "tac_assert" assertion begin fun ast -> - Tac2tactics.assert_ ast -end - -let () = define_prim3 "tac_enough" constr (option (option (thunk unit))) (option intro_pattern) begin fun c tac ipat -> - let tac = Option.map (fun o -> Option.map (fun f -> thaw unit f) o) tac in - Tac2tactics.forward false tac ipat c -end - -let () = define_prim2 "tac_pose" name constr begin fun na c -> - Tactics.letin_tac None na c None Locusops.nowhere -end - -let () = define_prim3 "tac_set" bool (thunk (pair name constr)) clause begin fun ev p cl -> - Proofview.tclEVARMAP >>= fun sigma -> - thaw (pair name constr) p >>= fun (na, c) -> - Tac2tactics.letin_pat_tac ev None na (sigma, c) cl -end - -let () = define_prim5 "tac_remember" bool name (thunk constr) (option intro_pattern) clause begin fun ev na c eqpat cl -> - let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in - match eqpat with - | IntroNaming eqpat -> - Proofview.tclEVARMAP >>= fun sigma -> - thaw constr c >>= fun c -> - Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl - | _ -> - Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") -end - -let () = define_prim3 "tac_destruct" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> - Tac2tactics.induction_destruct false ev ic using -end - -let () = define_prim3 "tac_induction" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> - Tac2tactics.induction_destruct true ev ic using -end - -let () = define_prim1 "tac_red" clause begin fun cl -> - Tac2tactics.reduce (Red false) cl -end - -let () = define_prim1 "tac_hnf" clause begin fun cl -> - Tac2tactics.reduce Hnf cl -end - -let () = define_prim3 "tac_simpl" red_flags (option pattern_with_occs) clause begin fun flags where cl -> - Tac2tactics.simpl flags where cl -end - -let () = define_prim2 "tac_cbv" red_flags clause begin fun flags cl -> - Tac2tactics.cbv flags cl -end - -let () = define_prim2 "tac_cbn" red_flags clause begin fun flags cl -> - Tac2tactics.cbn flags cl -end - -let () = define_prim2 "tac_lazy" red_flags clause begin fun flags cl -> - Tac2tactics.lazy_ flags cl -end - -let () = define_prim2 "tac_unfold" (list reference_with_occs) clause begin fun refs cl -> - Tac2tactics.unfold refs cl -end - -let () = define_prim2 "tac_fold" (list constr) clause begin fun args cl -> - Tac2tactics.reduce (Fold args) cl -end - -let () = define_prim2 "tac_pattern" (list constr_with_occs) clause begin fun where cl -> - Tac2tactics.pattern where cl -end - -let () = define_prim2 "tac_vm" (option pattern_with_occs) clause begin fun where cl -> - Tac2tactics.vm where cl -end - -let () = define_prim2 "tac_native" (option pattern_with_occs) clause begin fun where cl -> - Tac2tactics.native where cl -end - -(** Reduction functions *) - -let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) - -let define_red1 name r0 f = - let tac x = lift (f (Value.repr_to r0 x)) in - Tac2env.define_primitive (pname name) (mk_closure arity_one tac) - -let define_red2 name r0 r1 f = - let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) - -let define_red3 name r0 r1 r2 f = - let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) - -let () = define_red1 "eval_red" constr begin fun c -> - Tac2tactics.eval_red c -end - -let () = define_red1 "eval_hnf" constr begin fun c -> - Tac2tactics.eval_hnf c -end - -let () = define_red3 "eval_simpl" red_flags (option pattern_with_occs) constr begin fun flags where c -> - Tac2tactics.eval_simpl flags where c -end - -let () = define_red2 "eval_cbv" red_flags constr begin fun flags c -> - Tac2tactics.eval_cbv flags c -end - -let () = define_red2 "eval_cbn" red_flags constr begin fun flags c -> - Tac2tactics.eval_cbn flags c -end - -let () = define_red2 "eval_lazy" red_flags constr begin fun flags c -> - Tac2tactics.eval_lazy flags c -end - -let () = define_red2 "eval_unfold" (list reference_with_occs) constr begin fun refs c -> - Tac2tactics.eval_unfold refs c -end - -let () = define_red2 "eval_fold" (list constr) constr begin fun args c -> - Tac2tactics.eval_fold args c -end - -let () = define_red2 "eval_pattern" (list constr_with_occs) constr begin fun where c -> - Tac2tactics.eval_pattern where c -end - -let () = define_red2 "eval_vm" (option pattern_with_occs) constr begin fun where c -> - Tac2tactics.eval_vm where c -end - -let () = define_red2 "eval_native" (option pattern_with_occs) constr begin fun where c -> - Tac2tactics.eval_native where c -end - -let () = define_prim3 "tac_change" (option pattern) (fun1 (array constr) constr) clause begin fun pat c cl -> - Tac2tactics.change pat c cl -end - -let () = define_prim4 "tac_rewrite" bool (list rewriting) clause (option (thunk unit)) begin fun ev rw cl by -> - Tac2tactics.rewrite ev rw cl by -end - -let () = define_prim4 "tac_inversion" inversion_kind destruction_arg (option intro_pattern) (option (list ident)) begin fun knd arg pat ids -> - Tac2tactics.inversion knd arg pat ids -end - -(** Tactics from coretactics *) - -let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity - -let () = define_prim2 "tac_move" ident move_location begin fun id mv -> - Tactics.move_hyp id mv -end - -let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> - let mv = Option.default Logic.MoveLast mv in - Tactics.intro_move id mv -end - -(* - -TACTIC EXTEND exact - [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] -END - -*) - -let () = define_prim0 "tac_assumption" Tactics.assumption - -let () = define_prim1 "tac_transitivity" constr begin fun c -> - Tactics.intros_transitivity (Some c) -end - -let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) - -let () = define_prim1 "tac_cut" constr begin fun c -> - Tactics.cut c -end - -let () = define_prim2 "tac_left" bool bindings begin fun ev bnd -> - Tac2tactics.left_with_bindings ev bnd -end -let () = define_prim2 "tac_right" bool bindings begin fun ev bnd -> - Tac2tactics.right_with_bindings ev bnd -end - -let () = define_prim1 "tac_introsuntil" qhyp begin fun h -> - Tactics.intros_until h -end - -let () = define_prim1 "tac_exactnocheck" constr begin fun c -> - Tactics.exact_no_check c -end - -let () = define_prim1 "tac_vmcastnocheck" constr begin fun c -> - Tactics.vm_cast_no_check c -end - -let () = define_prim1 "tac_nativecastnocheck" constr begin fun c -> - Tactics.native_cast_no_check c -end - -let () = define_prim1 "tac_constructor" bool begin fun ev -> - Tactics.any_constructor ev None -end - -let () = define_prim3 "tac_constructorn" bool int bindings begin fun ev n bnd -> - Tac2tactics.constructor_tac ev None n bnd -end - -let () = define_prim2 "tac_specialize" constr_with_bindings (option intro_pattern) begin fun c ipat -> - Tac2tactics.specialize c ipat -end - -let () = define_prim1 "tac_symmetry" clause begin fun cl -> - Tac2tactics.symmetry cl -end - -let () = define_prim2 "tac_split" bool bindings begin fun ev bnd -> - Tac2tactics.split_with_bindings ev bnd -end - -let () = define_prim1 "tac_rename" (list (pair ident ident)) begin fun ids -> - Tactics.rename_hyp ids -end - -let () = define_prim1 "tac_revert" (list ident) begin fun ids -> - Tactics.revert ids -end - -let () = define_prim0 "tac_admit" Proofview.give_up - -let () = define_prim2 "tac_fix" ident int begin fun ident n -> - Tactics.fix ident n -end - -let () = define_prim1 "tac_cofix" ident begin fun ident -> - Tactics.cofix ident -end - -let () = define_prim1 "tac_clear" (list ident) begin fun ids -> - Tactics.clear ids -end - -let () = define_prim1 "tac_keep" (list ident) begin fun ids -> - Tactics.keep ids -end - -let () = define_prim1 "tac_clearbody" (list ident) begin fun ids -> - Tactics.clear_body ids -end - -(** Tactics from extratactics *) - -let () = define_prim2 "tac_discriminate" bool (option destruction_arg) begin fun ev arg -> - Tac2tactics.discriminate ev arg -end - -let () = define_prim3 "tac_injection" bool (option intro_patterns) (option destruction_arg) begin fun ev ipat arg -> - Tac2tactics.injection ev ipat arg -end - -let () = define_prim1 "tac_absurd" constr begin fun c -> - Contradiction.absurd c -end - -let () = define_prim1 "tac_contradiction" (option constr_with_bindings) begin fun c -> - Tac2tactics.contradiction c -end - -let () = define_prim4 "tac_autorewrite" bool (option (thunk unit)) (list ident) clause begin fun all by ids cl -> - Tac2tactics.autorewrite ~all by ids cl -end - -let () = define_prim1 "tac_subst" (list ident) begin fun ids -> - Equality.subst ids -end - -let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) - -(** Auto *) - -let () = define_prim3 "tac_trivial" debug (list (thunk constr)) (option (list ident)) begin fun dbg lems dbs -> - Tac2tactics.trivial dbg lems dbs -end - -let () = define_prim5 "tac_eauto" debug (option int) (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n p lems dbs -> - Tac2tactics.eauto dbg n p lems dbs -end - -let () = define_prim4 "tac_auto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> - Tac2tactics.auto dbg n lems dbs -end - -let () = define_prim4 "tac_newauto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> - Tac2tactics.new_auto dbg n lems dbs -end - -let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> - Tac2tactics.typeclasses_eauto str n dbs -end - -(** Firstorder *) - -let () = define_prim3 "tac_firstorder" (option (thunk unit)) (list reference) (list ident) begin fun tac refs ids -> - Tac2tactics.firstorder tac refs ids -end diff --git a/src/tac2stdlib.mli b/src/tac2stdlib.mli deleted file mode 100644 index 927b57074d..0000000000 --- a/src/tac2stdlib.mli +++ /dev/null @@ -1,9 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tactypes.ImplicitBindings l -| ExplicitBindings l -> - let l = List.map CAst.make l in - Tactypes.ExplicitBindings l -| NoBindings -> Tactypes.NoBindings - -let mk_with_bindings (x, b) = (x, mk_bindings b) - -let rec mk_intro_pattern = function -| IntroForthcoming b -> CAst.make @@ Tactypes.IntroForthcoming b -| IntroNaming ipat -> CAst.make @@ Tactypes.IntroNaming (mk_intro_pattern_naming ipat) -| IntroAction ipat -> CAst.make @@ Tactypes.IntroAction (mk_intro_pattern_action ipat) - -and mk_intro_pattern_naming = function -| IntroIdentifier id -> Namegen.IntroIdentifier id -| IntroFresh id -> Namegen.IntroFresh id -| IntroAnonymous -> Namegen.IntroAnonymous - -and mk_intro_pattern_action = function -| IntroWildcard -> Tactypes.IntroWildcard -| IntroOrAndPattern ipat -> Tactypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) -| IntroInjection ipats -> Tactypes.IntroInjection (List.map mk_intro_pattern ipats) -| IntroApplyOn (c, ipat) -> - let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in - Tactypes.IntroApplyOn (c, mk_intro_pattern ipat) -| IntroRewrite b -> Tactypes.IntroRewrite b - -and mk_or_and_intro_pattern = function -| IntroOrPattern ipatss -> - Tactypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) -| IntroAndPattern ipats -> - Tactypes.IntroAndPattern (List.map mk_intro_pattern ipats) - -let mk_intro_patterns ipat = List.map mk_intro_pattern ipat - -let mk_occurrences f = function -| AllOccurrences -> Locus.AllOccurrences -| AllOccurrencesBut l -> Locus.AllOccurrencesBut (List.map f l) -| NoOccurrences -> Locus.NoOccurrences -| OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) - -let mk_occurrences_expr occ = - mk_occurrences (fun i -> Locus.ArgArg i) occ - -let mk_hyp_location (id, occs, h) = - ((mk_occurrences_expr occs, id), h) - -let mk_clause cl = { - Locus.onhyps = Option.map (fun l -> List.map mk_hyp_location l) cl.onhyps; - Locus.concl_occs = mk_occurrences_expr cl.concl_occs; -} - -let intros_patterns ev ipat = - let ipat = mk_intro_patterns ipat in - Tactics.intros_patterns ev ipat - -let apply adv ev cb cl = - let map c = - let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in - None, CAst.make (delayed_of_tactic c) - in - let cb = List.map map cb in - match cl with - | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb - | Some (id, cl) -> - let cl = Option.map mk_intro_pattern cl in - Tactics.apply_delayed_in adv ev id cb cl - -let mk_destruction_arg = function -| ElimOnConstr c -> - let c = c >>= fun c -> return (mk_with_bindings c) in - Tactics.ElimOnConstr (delayed_of_tactic c) -| ElimOnIdent id -> Tactics.ElimOnIdent CAst.(make id) -| ElimOnAnonHyp n -> Tactics.ElimOnAnonHyp n - -let mk_induction_clause (arg, eqn, as_, occ) = - let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in - let as_ = Option.map (fun ipat -> CAst.make @@ mk_or_and_intro_pattern ipat) as_ in - let occ = Option.map mk_clause occ in - ((None, mk_destruction_arg arg), (eqn, as_), occ) - -let induction_destruct isrec ev (ic : induction_clause list) using = - let ic = List.map mk_induction_clause ic in - let using = Option.map mk_with_bindings using in - Tactics.induction_destruct isrec ev (ic, using) - -let elim ev c copt = - let c = mk_with_bindings c in - let copt = Option.map mk_with_bindings copt in - Tactics.elim ev None c copt - -let generalize pl = - let mk_occ occs = mk_occurrences (fun i -> i) occs in - let pl = List.map (fun (c, occs, na) -> (mk_occ occs, c), na) pl in - Tactics.new_generalize_gen pl - -let general_case_analysis ev c = - let c = mk_with_bindings c in - Tactics.general_case_analysis ev None c - -let constructor_tac ev n i bnd = - let bnd = mk_bindings bnd in - Tactics.constructor_tac ev n i bnd - -let left_with_bindings ev bnd = - let bnd = mk_bindings bnd in - Tactics.left_with_bindings ev bnd - -let right_with_bindings ev bnd = - let bnd = mk_bindings bnd in - Tactics.right_with_bindings ev bnd - -let split_with_bindings ev bnd = - let bnd = mk_bindings bnd in - Tactics.split_with_bindings ev [bnd] - -let specialize c pat = - let c = mk_with_bindings c in - let pat = Option.map mk_intro_pattern pat in - Tactics.specialize c pat - -let change pat c cl = - let open Tac2ffi in - Proofview.Goal.enter begin fun gl -> - let c subst env sigma = - let subst = Array.map_of_list snd (Id.Map.bindings subst) in - delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma - in - let cl = mk_clause cl in - Tactics.change pat c cl - end - -let rewrite ev rw cl by = - let map_rw (orient, repeat, c) = - let c = c >>= fun c -> return (mk_with_bindings c) in - (Option.default true orient, repeat, None, delayed_of_tactic c) - in - let rw = List.map map_rw rw in - let cl = mk_clause cl in - let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE (thaw Tac2ffi.unit tac), Equality.Naive) by in - Equality.general_multi_rewrite ev rw cl by - -let symmetry cl = - let cl = mk_clause cl in - Tactics.intros_symmetry cl - -let forward fst tac ipat c = - let ipat = Option.map mk_intro_pattern ipat in - Tactics.forward fst tac ipat c - -let assert_ = function -| AssertValue (id, c) -> - let ipat = CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id) in - Tactics.forward true None (Some ipat) c -| AssertType (ipat, c, tac) -> - let ipat = Option.map mk_intro_pattern ipat in - let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in - Tactics.forward true (Some tac) ipat c - -let letin_pat_tac ev ipat na c cl = - let ipat = Option.map (fun (b, ipat) -> (b, CAst.make @@ mk_intro_pattern_naming ipat)) ipat in - let cl = mk_clause cl in - Tactics.letin_pat_tac ev ipat na c cl - -(** Ltac interface treats differently global references than other term - arguments in reduction expressions. In Ltac1, this is done at parsing time. - Instead, we parse indifferently any pattern and dispatch when the tactic is - called. *) -let map_pattern_with_occs (pat, occ) = match pat with -| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) -| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) -| _ -> (mk_occurrences_expr occ, Inr pat) - -let get_evaluable_reference = function -| VarRef id -> Proofview.tclUNIT (EvalVarRef id) -| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) -| r -> - Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ - Nametab.pr_global_env Id.Set.empty r ++ spc () ++ - str "to an evaluable reference.") - -let reduce r cl = - let cl = mk_clause cl in - Tactics.reduce r cl - -let simpl flags where cl = - let where = Option.map map_pattern_with_occs where in - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Simpl (flags, where)) cl - -let cbv flags cl = - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Cbv flags) cl - -let cbn flags cl = - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Cbn flags) cl - -let lazy_ flags cl = - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Lazy flags) cl - -let unfold occs cl = - let cl = mk_clause cl in - let map (gr, occ) = - let occ = mk_occurrences_expr occ in - get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) - in - Proofview.Monad.List.map map occs >>= fun occs -> - Tactics.reduce (Unfold occs) cl - -let pattern where cl = - let where = List.map (fun (c, occ) -> (mk_occurrences_expr occ, c)) where in - let cl = mk_clause cl in - Tactics.reduce (Pattern where) cl - -let vm where cl = - let where = Option.map map_pattern_with_occs where in - let cl = mk_clause cl in - Tactics.reduce (CbvVm where) cl - -let native where cl = - let where = Option.map map_pattern_with_occs where in - let cl = mk_clause cl in - Tactics.reduce (CbvNative where) cl - -let eval_fun red c = - Tac2core.pf_apply begin fun env sigma -> - let (redfun, _) = Redexpr.reduction_of_red_expr env red in - let (sigma, ans) = redfun env sigma c in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT ans - end - -let eval_red c = - eval_fun (Red false) c - -let eval_hnf c = - eval_fun Hnf c - -let eval_simpl flags where c = - let where = Option.map map_pattern_with_occs where in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Simpl (flags, where)) c - -let eval_cbv flags c = - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Cbv flags) c - -let eval_cbn flags c = - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Cbn flags) c - -let eval_lazy flags c = - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Lazy flags) c - -let eval_unfold occs c = - let map (gr, occ) = - let occ = mk_occurrences_expr occ in - get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) - in - Proofview.Monad.List.map map occs >>= fun occs -> - eval_fun (Unfold occs) c - -let eval_fold cl c = - eval_fun (Fold cl) c - -let eval_pattern where c = - let where = List.map (fun (pat, occ) -> (mk_occurrences_expr occ, pat)) where in - eval_fun (Pattern where) c - -let eval_vm where c = - let where = Option.map map_pattern_with_occs where in - eval_fun (CbvVm where) c - -let eval_native where c = - let where = Option.map map_pattern_with_occs where in - eval_fun (CbvNative where) c - -let on_destruction_arg tac ev arg = - Proofview.Goal.enter begin fun gl -> - match arg with - | None -> tac ev None - | Some (clear, arg) -> - let arg = match arg with - | ElimOnConstr c -> - let env = Proofview.Goal.env gl in - Proofview.tclEVARMAP >>= fun sigma -> - c >>= fun (c, lbind) -> - let lbind = mk_bindings lbind in - Proofview.tclEVARMAP >>= fun sigma' -> - let flags = tactic_infer_flags ev in - let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in - Proofview.tclUNIT (Some sigma', Tactics.ElimOnConstr (c, lbind)) - | ElimOnIdent id -> Proofview.tclUNIT (None, Tactics.ElimOnIdent CAst.(make id)) - | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Tactics.ElimOnAnonHyp n) - in - arg >>= fun (sigma', arg) -> - let arg = Some (clear, arg) in - match sigma' with - | None -> tac ev arg - | Some sigma' -> - Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' - end - -let discriminate ev arg = - let arg = Option.map (fun arg -> None, arg) arg in - on_destruction_arg Equality.discr_tac ev arg - -let injection ev ipat arg = - let arg = Option.map (fun arg -> None, arg) arg in - let ipat = Option.map mk_intro_patterns ipat in - let tac ev arg = Equality.injClause None ipat ev arg in - on_destruction_arg tac ev arg - -let autorewrite ~all by ids cl = - let conds = if all then Some Equality.AllMatches else None in - let ids = List.map Id.to_string ids in - let cl = mk_clause cl in - match by with - | None -> Autorewrite.auto_multi_rewrite ?conds ids cl - | Some by -> - let by = thaw Tac2ffi.unit by in - Autorewrite.auto_multi_rewrite_with ?conds by ids cl - -(** Auto *) - -let trivial debug lems dbs = - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in - Auto.h_trivial ~debug lems dbs - -let auto debug n lems dbs = - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in - Auto.h_auto ~debug n lems dbs - -let new_auto debug n lems dbs = - let make_depth n = snd (Eauto.make_dimension n None) in - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - match dbs with - | None -> Auto.new_full_auto ~debug (make_depth n) lems - | Some dbs -> - let dbs = List.map Id.to_string dbs in - Auto.new_auto ~debug (make_depth n) lems dbs - -let eauto debug n p lems dbs = - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in - Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs - -let typeclasses_eauto strategy depth dbs = - let only_classes, dbs = match dbs with - | None -> - true, [Class_tactics.typeclasses_db] - | Some dbs -> - let dbs = List.map Id.to_string dbs in - false, dbs - in - Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs - -(** Inversion *) - -let inversion knd arg pat ids = - let ids = match ids with - | None -> [] - | Some l -> l - in - begin match pat with - | None -> Proofview.tclUNIT None - | Some (IntroAction (IntroOrAndPattern p)) -> - Proofview.tclUNIT (Some (CAst.make @@ mk_or_and_intro_pattern p)) - | Some _ -> - Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") - end >>= fun pat -> - let inversion _ arg = - begin match arg with - | None -> assert false - | Some (_, Tactics.ElimOnAnonHyp n) -> - Inv.inv_clause knd pat ids (AnonHyp n) - | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> - Inv.inv_clause knd pat ids (NamedHyp id) - | Some (_, Tactics.ElimOnConstr c) -> - let open Tactypes in - let anon = CAst.make @@ IntroNaming Namegen.IntroAnonymous in - Tactics.specialize c (Some anon) >>= fun () -> - Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) - end - in - on_destruction_arg inversion true (Some (None, arg)) - -let contradiction c = - let c = Option.map mk_with_bindings c in - Contradiction.contradiction c - -(** Firstorder *) - -let firstorder tac refs ids = - let open Ground_plugin in - let ids = List.map Id.to_string ids in - let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in - G_ground.gen_ground_tac true tac refs ids diff --git a/src/tac2tactics.mli b/src/tac2tactics.mli deleted file mode 100644 index 026673acbf..0000000000 --- a/src/tac2tactics.mli +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* intro_pattern list -> unit tactic - -val apply : advanced_flag -> evars_flag -> - constr_with_bindings thunk list -> - (Id.t * intro_pattern option) option -> unit tactic - -val induction_destruct : rec_flag -> evars_flag -> - induction_clause list -> constr_with_bindings option -> unit tactic - -val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> - unit tactic - -val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic - -val generalize : (constr * occurrences * Name.t) list -> unit tactic - -val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic - -val left_with_bindings : evars_flag -> bindings -> unit tactic -val right_with_bindings : evars_flag -> bindings -> unit tactic -val split_with_bindings : evars_flag -> bindings -> unit tactic - -val specialize : constr_with_bindings -> intro_pattern option -> unit tactic - -val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic - -val rewrite : - evars_flag -> rewriting list -> clause -> unit thunk option -> unit tactic - -val symmetry : clause -> unit tactic - -val forward : bool -> unit tactic option option -> - intro_pattern option -> constr -> unit tactic - -val assert_ : assertion -> unit tactic - -val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> - Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic - -val reduce : Redexpr.red_expr -> clause -> unit tactic - -val simpl : GlobRef.t glob_red_flag -> - (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic - -val cbv : GlobRef.t glob_red_flag -> clause -> unit tactic - -val cbn : GlobRef.t glob_red_flag -> clause -> unit tactic - -val lazy_ : GlobRef.t glob_red_flag -> clause -> unit tactic - -val unfold : (GlobRef.t * occurrences) list -> clause -> unit tactic - -val pattern : (constr * occurrences) list -> clause -> unit tactic - -val vm : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic - -val native : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic - -val eval_red : constr -> constr tactic - -val eval_hnf : constr -> constr tactic - -val eval_simpl : GlobRef.t glob_red_flag -> - (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic - -val eval_cbv : GlobRef.t glob_red_flag -> constr -> constr tactic - -val eval_cbn : GlobRef.t glob_red_flag -> constr -> constr tactic - -val eval_lazy : GlobRef.t glob_red_flag -> constr -> constr tactic - -val eval_unfold : (GlobRef.t * occurrences) list -> constr -> constr tactic - -val eval_fold : constr list -> constr -> constr tactic - -val eval_pattern : (EConstr.t * occurrences) list -> constr -> constr tactic - -val eval_vm : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic - -val eval_native : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic - -val discriminate : evars_flag -> destruction_arg option -> unit tactic - -val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic - -val autorewrite : all:bool -> unit thunk option -> Id.t list -> clause -> unit tactic - -val trivial : Hints.debug -> constr thunk list -> Id.t list option -> - unit Proofview.tactic - -val auto : Hints.debug -> int option -> constr thunk list -> - Id.t list option -> unit Proofview.tactic - -val new_auto : Hints.debug -> int option -> constr thunk list -> - Id.t list option -> unit Proofview.tactic - -val eauto : Hints.debug -> int option -> int option -> constr thunk list -> - Id.t list option -> unit Proofview.tactic - -val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> - Id.t list option -> unit Proofview.tactic - -val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic - -val contradiction : constr_with_bindings option -> unit tactic - -val firstorder : unit thunk option -> GlobRef.t list -> Id.t list -> unit tactic diff --git a/src/tac2types.mli b/src/tac2types.mli deleted file mode 100644 index fa31153a27..0000000000 --- a/src/tac2types.mli +++ /dev/null @@ -1,92 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* $@ - if [ $$? = 0 ]; then \ - echo " $<... OK"; \ - else \ - echo " $<... FAIL!"; \ - fi; \ - -clean: - rm -f *.log diff --git a/tests/compat.v b/tests/compat.v deleted file mode 100644 index 489fa638e4..0000000000 --- a/tests/compat.v +++ /dev/null @@ -1,58 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Notations. - -(** Test calls to Ltac1 from Ltac2 *) - -Ltac2 foo () := ltac1:(discriminate). - -Goal true = false -> False. -Proof. -foo (). -Qed. - -Goal true = false -> false = true. -Proof. -intros H; ltac1:(match goal with [ H : ?P |- _ ] => rewrite H end); reflexivity. -Qed. - -Goal true = false -> false = true. -Proof. -intros H; ltac1:(rewrite H); reflexivity. -Abort. - -(** Variables do not cross the compatibility layer boundary. *) -Fail Ltac2 bar nay := ltac1:(discriminate nay). - -Fail Ltac2 pose1 (v : constr) := - ltac1:(pose $v). - -(** Test calls to Ltac2 from Ltac1 *) - -Set Default Proof Mode "Classic". - -Ltac foo := ltac2:(foo ()). - -Goal true = false -> False. -Proof. -ltac2:(foo ()). -Qed. - -Goal true = false -> False. -Proof. -foo. -Qed. - -(** Variables do not cross the compatibility layer boundary. *) -Fail Ltac bar x := ltac2:(foo x). - -Ltac mytac tac := idtac "wow". - -Goal True. -Proof. -(** Fails because quotation is evaluated eagerly *) -Fail mytac ltac2:(fail). -(** One has to thunk thanks to the idtac trick *) -let t := idtac; ltac2:(fail) in mytac t. -constructor. -Qed. diff --git a/tests/errors.v b/tests/errors.v deleted file mode 100644 index c677f6af5d..0000000000 --- a/tests/errors.v +++ /dev/null @@ -1,12 +0,0 @@ -Require Import Ltac2.Ltac2. - -Goal True. -Proof. -let x := Control.plus - (fun () => let _ := constr:(nat -> 0) in 0) - (fun e => match e with Not_found => 1 | _ => 2 end) in -match Int.equal x 2 with -| true => () -| false => Control.throw (Tactic_failure None) -end. -Abort. diff --git a/tests/example1.v b/tests/example1.v deleted file mode 100644 index 023791050f..0000000000 --- a/tests/example1.v +++ /dev/null @@ -1,27 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Control. - -(** Alternative implementation of the hyp primitive *) -Ltac2 get_hyp_by_name x := - let h := hyps () in - let rec find x l := match l with - | [] => zero Not_found - | p :: l => - match p with - | (id, _, t) => - match Ident.equal x id with - | true => t - | false => find x l - end - end - end in - find x h. - -Print Ltac2 get_hyp_by_name. - -Goal forall n m, n + m = 0 -> n = 0. -Proof. -refine (fun () => '(fun n m H => _)). -let t := get_hyp_by_name @H in Message.print (Message.of_constr t). -Abort. diff --git a/tests/example2.v b/tests/example2.v deleted file mode 100644 index c953d25061..0000000000 --- a/tests/example2.v +++ /dev/null @@ -1,281 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Notations. - -Set Default Goal Selector "all". - -Goal exists n, n = 0. -Proof. -split with (x := 0). -reflexivity. -Qed. - -Goal exists n, n = 0. -Proof. -split with 0. -split. -Qed. - -Goal exists n, n = 0. -Proof. -let myvar := Std.NamedHyp @x in split with ($myvar := 0). -split. -Qed. - -Goal (forall n : nat, n = 0 -> False) -> True. -Proof. -intros H. -eelim &H. -split. -Qed. - -Goal (forall n : nat, n = 0 -> False) -> True. -Proof. -intros H. -elim &H with 0. -split. -Qed. - -Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. -Proof. -intros P H. -Fail apply &H. -apply &H with (m := 0). -split. -Qed. - -Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> (0 = 1) -> P 0. -Proof. -intros P H e. -apply &H with (m := 1) in e. -exact e. -Qed. - -Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. -Proof. -intros P H. -eapply &H. -split. -Qed. - -Goal exists n, n = 0. -Proof. -Fail constructor 1. -constructor 1 with (x := 0). -split. -Qed. - -Goal exists n, n = 0. -Proof. -econstructor 1. -split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -induction &n as [|n] using nat_rect; split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -let n := @X in -let q := Std.NamedHyp @P in -induction &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -destruct &n as [|n] using nat_rect; split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -let n := @X in -let q := Std.NamedHyp @P in -destruct &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. -Qed. - -Goal forall b1 b2, andb b1 b2 = andb b2 b1. -Proof. -intros b1 b2. -destruct &b1 as [|], &b2 as [|]; split. -Qed. - -Goal forall n m, n = 0 -> n + m = m. -Proof. -intros n m Hn. -rewrite &Hn; split. -Qed. - -Goal forall n m p, n = m -> p = m -> 0 = n -> p = 0. -Proof. -intros n m p He He' Hn. -rewrite &He, <- &He' in Hn. -rewrite &Hn. -split. -Qed. - -Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. -Proof. -intros n m He He' He''. -rewrite <- &He by assumption. -Control.refine (fun () => &He''). -Qed. - -Goal forall n (r := if true then n else 0), r = n. -Proof. -intros n r. -hnf in r. -split. -Qed. - -Goal 1 = 0 -> 0 = 0. -Proof. -intros H. -pattern 0 at 1. -let occ := 2 in pattern 1 at 1, 0 at $occ in H. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -vm_compute. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -native_compute. -reflexivity. -Qed. - -Goal 1 + 1 = 2 - 0 -> True. -Proof. -intros H. -vm_compute plus in H. -reflexivity. -Qed. - -Goal 1 = 0 -> True /\ True. -Proof. -intros H. -split; fold (1 + 0) (1 + 0) in H. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -cbv [ Nat.add ]. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -let x := reference:(Nat.add) in -cbn beta iota delta [ $x ]. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -simpl beta. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -lazy. -reflexivity. -Qed. - -Goal let x := 1 + 1 - 1 in x = x. -Proof. -intros x. -unfold &x at 1. -let x := reference:(Nat.sub) in unfold Nat.add, $x in x. -reflexivity. -Qed. - -Goal exists x y : nat, x = y. -Proof. -exists 0, 0; reflexivity. -Qed. - -Goal exists x y : nat, x = y. -Proof. -eexists _, 0; reflexivity. -Qed. - -Goal exists x y : nat, x = y. -Proof. -refine '(let x := 0 in _). -eexists; exists &x; reflexivity. -Qed. - -Goal True. -Proof. -pose (X := True). -constructor. -Qed. - -Goal True. -Proof. -pose True as X. -constructor. -Qed. - -Goal True. -Proof. -let x := @foo in -set ($x := True) in * |-. -constructor. -Qed. - -Goal 0 = 0. -Proof. -remember 0 as n eqn: foo at 1. -rewrite foo. -reflexivity. -Qed. - -Goal True. -Proof. -assert (H := 0 + 0). -constructor. -Qed. - -Goal True. -Proof. -assert (exists n, n = 0) as [n Hn]. -+ exists 0; reflexivity. -+ exact I. -Qed. - -Goal True -> True. -Proof. -assert (H : 0 + 0 = 0) by reflexivity. -intros x; exact x. -Qed. - -Goal 1 + 1 = 2. -Proof. -change (?a + 1 = 2) with (2 = $a + 1). -reflexivity. -Qed. - -Goal (forall n, n = 0 -> False) -> False. -Proof. -intros H. -specialize (H 0 eq_refl). -destruct H. -Qed. - -Goal (forall n, n = 0 -> False) -> False. -Proof. -intros H. -specialize (H 0 eq_refl) as []. -Qed. diff --git a/tests/matching.v b/tests/matching.v deleted file mode 100644 index 4338cbd32f..0000000000 --- a/tests/matching.v +++ /dev/null @@ -1,71 +0,0 @@ -Require Import Ltac2.Ltac2 Ltac2.Notations. - -Ltac2 Type exn ::= [ Nope ]. - -Ltac2 check_id id id' := match Ident.equal id id' with -| true => () -| false => Control.throw Nope -end. - -Goal True -> False. -Proof. -Fail -let b := { contents := true } in -let f c := - match b.(contents) with - | true => Message.print (Message.of_constr c); b.(contents) := false; fail - | false => () - end -in -(** This fails because the matching is not allowed to backtrack once - it commits to a branch*) -lazy_match! '(nat -> bool) with context [?a] => f a end. -lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. - -(** This one works by taking the second match context, i.e. ?a := nat *) -let b := { contents := true } in -let f c := - match b.(contents) with - | true => b.(contents) := false; fail - | false => Message.print (Message.of_constr c) - end -in -match! '(nat -> bool) with context [?a] => f a end. -Abort. - -Goal forall (i j : unit) (x y : nat) (b : bool), True. -Proof. -Fail match! goal with -| [ h : ?t, h' : ?t |- _ ] => () -end. -intros i j x y b. -match! goal with -| [ h : ?t, h' : ?t |- _ ] => - check_id h @x; - check_id h' @y -end. -match! reverse goal with -| [ h : ?t, h' : ?t |- _ ] => - check_id h @j; - check_id h' @i -end. -Abort. - -(* Check #79 *) -Goal 2 = 3. - Control.plus - (fun () - => lazy_match! goal with - | [ |- 2 = 3 ] => Control.zero (Tactic_failure None) - | [ |- 2 = _ ] => Control.zero (Tactic_failure (Some (Message.of_string "should not be printed"))) - end) - (fun e - => match e with - | Tactic_failure c - => match c with - | None => () - | _ => Control.zero e - end - | e => Control.zero e - end). -Abort. diff --git a/tests/quot.v b/tests/quot.v deleted file mode 100644 index 624c4ad0c1..0000000000 --- a/tests/quot.v +++ /dev/null @@ -1,26 +0,0 @@ -Require Import Ltac2.Ltac2. - -(** Test for quotations *) - -Ltac2 ref0 () := reference:(&x). -Ltac2 ref1 () := reference:(nat). -Ltac2 ref2 () := reference:(Datatypes.nat). -Fail Ltac2 ref () := reference:(i_certainly_dont_exist). -Fail Ltac2 ref () := reference:(And.Me.neither). - -Goal True. -Proof. -let x := constr:(I) in -let y := constr:((fun z => z) $x) in -Control.refine (fun _ => y). -Qed. - -Goal True. -Proof. -(** Here, Ltac2 should not put its variables in the same environment as - Ltac1 otherwise the second binding fails as x is bound but not an - ident. *) -let x := constr:(I) in -let y := constr:((fun x => x) $x) in -Control.refine (fun _ => y). -Qed. diff --git a/tests/rebind.v b/tests/rebind.v deleted file mode 100644 index e1c20a2059..0000000000 --- a/tests/rebind.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Import Ltac2.Ltac2 Ltac2.Notations. - -Ltac2 mutable foo () := constructor. - -Goal True. -Proof. -foo (). -Qed. - -Ltac2 Set foo := fun _ => fail. - -Goal True. -Proof. -Fail foo (). -constructor. -Qed. - -(** Not the right type *) -Fail Ltac2 Set foo := 0. - -Ltac2 bar () := (). - -(** Cannot redefine non-mutable tactics *) -Fail Ltac2 Set bar := fun _ => (). - -(** Subtype check *) - -Ltac2 mutable rec f x := f x. - -Fail Ltac2 Set f := fun x => x. - -Ltac2 mutable g x := x. - -Ltac2 Set g := f. diff --git a/tests/stuff/ltac2.v b/tests/stuff/ltac2.v deleted file mode 100644 index 370bc70d15..0000000000 --- a/tests/stuff/ltac2.v +++ /dev/null @@ -1,143 +0,0 @@ -Require Import Ltac2.Ltac2. - -Ltac2 foo (_ : int) := - let f (x : int) := x in - let _ := f 0 in - f 1. - -Print Ltac2 foo. - -Import Control. - -Ltac2 exact x := refine (fun () => x). - -Print Ltac2 refine. -Print Ltac2 exact. - -Ltac2 foo' () := ident:(bla). - -Print Ltac2 foo'. - -Ltac2 bar x h := match x with -| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) -| Some x => x -end. - -Print Ltac2 bar. - -Ltac2 qux := Some 0. - -Print Ltac2 qux. - -Ltac2 Type foo := [ Foo (int) ]. - -Fail Ltac2 qux0 := Foo None. - -Ltac2 Type 'a ref := { mutable contents : 'a }. - -Fail Ltac2 qux0 := { contents := None }. -Ltac2 foo0 () := { contents := None }. - -Print Ltac2 foo0. - -Ltac2 qux0 x := x.(contents). -Ltac2 qux1 x := x.(contents) := x.(contents). - -Ltac2 qux2 := ([1;2], true). - -Print Ltac2 qux0. -Print Ltac2 qux1. -Print Ltac2 qux2. - -Import Control. - -Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). - -Print Ltac2 qux3. - -Ltac2 Type rec nat := [ O | S (nat) ]. - -Ltac2 message_of_nat n := -let rec aux n := -match n with -| O => Message.of_string "O" -| S n => Message.concat (Message.of_string "S") (aux n) -end in aux n. - -Print Ltac2 message_of_nat. - -Ltac2 numgoals () := - let r := { contents := O } in - enter (fun () => r.(contents) := S (r.(contents))); - r.(contents). - -Print Ltac2 numgoals. - -Goal True /\ False. -Proof. -let n := numgoals () in Message.print (message_of_nat n). -refine (fun () => open_constr:((fun x => conj _ _) 0)); (). -let n := numgoals () in Message.print (message_of_nat n). - -Fail (hyp ident:(x)). -Fail (enter (fun () => hyp ident:(There_is_no_spoon); ())). - -enter (fun () => Message.print (Message.of_string "foo")). - -enter (fun () => Message.print (Message.of_constr (goal ()))). -Fail enter (fun () => Message.print (Message.of_constr (qux3 ident:(x)))). -enter (fun () => plus (fun () => constr:(_); ()) (fun _ => ())). -plus - (fun () => enter (fun () => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). -let x := { contents := 0 } in -let x := x.(contents) := x.(contents) in x. -Abort. - -Ltac2 Type exn ::= [ Foo ]. - -Goal True. -Proof. -plus (fun () => zero Foo) (fun _ => ()). -Abort. - -Ltac2 Type exn ::= [ Bar (string) ]. - -Goal True. -Proof. -Fail zero (Bar "lol"). -Abort. - -Ltac2 Notation "refine!" c(thunk(constr)) := refine c. - -Goal True. -Proof. -refine! I. -Abort. - -Goal True. -Proof. -let x () := plus (fun () => 0) (fun _ => 1) in -match case x with -| Val x => - match x with - | (x, k) => Message.print (Message.of_int (k Not_found)) - end -| Err x => Message.print (Message.of_string "Err") -end. -Abort. - -Goal (forall n : nat, n = 0 -> False) -> True. -Proof. -refine (fun () => '(fun H => _)). -Std.case true (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). -refine (fun () => 'eq_refl). -Qed. - -Goal forall x, 1 + x = x + 1. -Proof. -refine (fun () => '(fun x => _)). -Std.cbv { - Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; - Std.rZeta := true; Std.rDelta := true; Std.rConst := []; -} { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. -Abort. diff --git a/tests/tacticals.v b/tests/tacticals.v deleted file mode 100644 index 1a2fbcbb37..0000000000 --- a/tests/tacticals.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Notations. - -Goal True. -Proof. -Fail fail. -Fail solve [ () ]. -try fail. -repeat fail. -repeat (). -solve [ constructor ]. -Qed. - -Goal True. -Proof. -first [ - Message.print (Message.of_string "Yay"); fail -| constructor -| Message.print (Message.of_string "I won't be printed") -]. -Qed. - -Goal True /\ True. -Proof. -Fail split > [ split | |]. -split > [split | split]. -Qed. - -Goal True /\ (True -> True) /\ True. -Proof. -split > [ | split] > [split | .. | split]. -intros H; refine &H. -Qed. diff --git a/tests/typing.v b/tests/typing.v deleted file mode 100644 index 9f18292716..0000000000 --- a/tests/typing.v +++ /dev/null @@ -1,72 +0,0 @@ -Require Import Ltac2.Ltac2. - -(** Ltac2 is typed à la ML. *) - -Ltac2 test0 n := Int.add n 1. - -Print Ltac2 test0. - -Ltac2 test1 () := test0 0. - -Print Ltac2 test1. - -Fail Ltac2 test2 () := test0 true. - -Fail Ltac2 test2 () := test0 0 0. - -Ltac2 test3 f x := x, (f x, x). - -Print Ltac2 test3. - -(** Polymorphism *) - -Ltac2 rec list_length l := -match l with -| [] => 0 -| x :: l => Int.add 1 (list_length l) -end. - -Print Ltac2 list_length. - -(** Pattern-matching *) - -Ltac2 ifb b f g := match b with -| true => f () -| false => g () -end. - -Print Ltac2 ifb. - -Ltac2 if_not_found e f g := match e with -| Not_found => f () -| _ => g () -end. - -Fail Ltac2 ifb' b f g := match b with -| true => f () -end. - -Fail Ltac2 if_not_found' e f g := match e with -| Not_found => f () -end. - -(** Reimplementing 'do'. Return value of the function useless. *) - -Ltac2 rec do n tac := match Int.equal n 0 with -| true => () -| false => tac (); do (Int.sub n 1) tac -end. - -Print Ltac2 do. - -(** Non-function pure values are OK. *) - -Ltac2 tuple0 := ([1; 2], true, (fun () => "yay")). - -Print Ltac2 tuple0. - -(** Impure values are not. *) - -Fail Ltac2 not_a_value := { contents := 0 }. -Fail Ltac2 not_a_value := "nope". -Fail Ltac2 not_a_value := list_length []. diff --git a/theories/Array.v b/theories/Array.v deleted file mode 100644 index 11b64e3515..0000000000 --- a/theories/Array.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> 'a array := "ltac2" "array_make". -Ltac2 @external length : 'a array -> int := "ltac2" "array_length". -Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". -Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/theories/Char.v b/theories/Char.v deleted file mode 100644 index 29fef60f2c..0000000000 --- a/theories/Char.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* char := "ltac2" "char_of_int". -Ltac2 @external to_int : char -> int := "ltac2" "char_to_int". diff --git a/theories/Constr.v b/theories/Constr.v deleted file mode 100644 index d8d222730e..0000000000 --- a/theories/Constr.v +++ /dev/null @@ -1,72 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr := "ltac2" "constr_type". -(** Return the type of a term *) - -Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". -(** Strict syntactic equality: only up to α-conversion and evar expansion *) - -Module Unsafe. - -(** Low-level access to kernel terms. Use with care! *) - -Ltac2 Type case. - -Ltac2 Type kind := [ -| Rel (int) -| Var (ident) -| Meta (meta) -| Evar (evar, constr array) -| Sort (sort) -| Cast (constr, cast, constr) -| Prod (ident option, constr, constr) -| Lambda (ident option, constr, constr) -| LetIn (ident option, constr, constr, constr) -| App (constr, constr array) -| Constant (constant, instance) -| Ind (inductive, instance) -| Constructor (constructor, instance) -| Case (case, constr, constr, constr array) -| Fix (int array, int, ident option array, constr array, constr array) -| CoFix (int, ident option array, constr array, constr array) -| Proj (projection, constr) -]. - -Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". - -Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". - -Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". -(** Checks that a constr generated by unsafe means is indeed safe in the - current environment, and returns it, or the error otherwise. Panics if - not focussed. *) - -Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". -(** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with - [r₁;...;rₙ] in [c]. *) - -Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "constr_closenl". -(** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with - [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) - -Ltac2 @ external case : inductive -> case := "ltac2" "constr_case". -(** Generate the case information for a given inductive type. *) - -Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "constr_constructor". -(** Generate the i-th constructor for a given inductive type. Indexing starts - at 0. Panics if there is no such constructor. *) - -End Unsafe. - -Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". -(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a - focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is - the proof built by the tactic. *) diff --git a/theories/Control.v b/theories/Control.v deleted file mode 100644 index 071c2ea8ce..0000000000 --- a/theories/Control.v +++ /dev/null @@ -1,76 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a := "ltac2" "throw". -(** Fatal exception throwing. This does not induce backtracking. *) - -(** Generic backtracking control *) - -Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". -Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". -Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". -Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". -Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". -Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". -Ltac2 @ external case : (unit -> 'a) -> ('a * (exn -> 'a)) result := "ltac2" "case". - -(** Proof state manipulation *) - -Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". -Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". -Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". - -Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". -(** Adds the given evar to the list of goals as the last one. If it is - already defined in the current state, don't do anything. Panics if the - evar is not in the current state. *) - -Ltac2 @ external progress : (unit -> 'a) -> 'a := "ltac2" "progress". - -(** Goal inspection *) - -Ltac2 @ external goal : unit -> constr := "ltac2" "goal". -(** Panics if there is not exactly one goal under focus. Otherwise returns - the conclusion of this goal. *) - -Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". -(** Panics if there is more than one goal under focus. If there is no - goal under focus, looks for the section variable with the given name. - If there is one, looks for the hypothesis with the given name. *) - -Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" "hyps". -(** Panics if there is more than one goal under focus. If there is no - goal under focus, returns the list of section variables. - If there is one, returns the list of hypotheses. In both cases, the - list is ordered with rightmost values being last introduced. *) - -(** Refinement *) - -Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". - -(** Evars *) - -Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_holes". -(** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if - all evars generated by the call to [x] have not been solved when [f] - returns. *) - -(** Misc *) - -Ltac2 @ external time : string option -> (unit -> 'a) -> 'a := "ltac2" "time". -(** Displays the time taken by a tactic to evaluate. *) - -Ltac2 @ external abstract : ident option -> (unit -> unit) -> unit := "ltac2" "abstract". -(** Abstract a subgoal. *) - -Ltac2 @ external check_interrupt : unit -> unit := "ltac2" "check_interrupt". -(** For internal use. *) diff --git a/theories/Env.v b/theories/Env.v deleted file mode 100644 index c9b250f4ba..0000000000 --- a/theories/Env.v +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Std.reference option := "ltac2" "env_get". -(** Returns the global reference corresponding to the absolute name given as - argument if it exists. *) - -Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". -(** Returns the list of all global references whose absolute name contains - the argument list as a prefix. *) - -Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". -(** Returns the absolute name of the given reference. Panics if the reference - does not exist. *) - -Ltac2 @ external instantiate : Std.reference -> constr := "ltac2" "env_instantiate". -(** Returns a fresh instance of the corresponding reference, in particular - generating fresh universe variables and constraints when this reference is - universe-polymorphic. *) diff --git a/theories/Fresh.v b/theories/Fresh.v deleted file mode 100644 index 5e876bb077..0000000000 --- a/theories/Fresh.v +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> t := "ltac2" "fresh_free_union". - -Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". - -Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". - -End Free. - -Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". -(** Generate a fresh identifier with the given base name which is not a - member of the provided set of free variables. *) diff --git a/theories/Ident.v b/theories/Ident.v deleted file mode 100644 index 55456afbe2..0000000000 --- a/theories/Ident.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> bool := "ltac2" "ident_equal". - -Ltac2 @ external of_string : string -> t option := "ltac2" "ident_of_string". - -Ltac2 @ external to_string : t -> string := "ltac2" "ident_to_string". diff --git a/theories/Init.v b/theories/Init.v deleted file mode 100644 index 16e7d7a6f9..0000000000 --- a/theories/Init.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* int -> bool := "ltac2" "int_equal". -Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". -Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". -Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". -Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". -Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/theories/Ltac1.v b/theories/Ltac1.v deleted file mode 100644 index c4e0b606d0..0000000000 --- a/theories/Ltac1.v +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t := "ltac2" "ltac1_ref". -(** Returns the Ltac1 definition with the given absolute name. *) - -Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". -(** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning - anything. *) - -Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". -(** Applies an Ltac1 value to a list of arguments, and provides the result in - CPS style. It does **not** run the returned value. *) - -(** Conversion functions *) - -Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". -Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". - -Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". -Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/theories/Ltac2.v b/theories/Ltac2.v deleted file mode 100644 index ac90f63560..0000000000 --- a/theories/Ltac2.v +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit := "ltac2" "print". - -Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". - -Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". - -Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". - -Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". -(** Panics if there is more than one goal under focus. *) - -Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". -(** Panics if there is more than one goal under focus. *) - -Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/theories/Notations.v b/theories/Notations.v deleted file mode 100644 index f4621656d6..0000000000 --- a/theories/Notations.v +++ /dev/null @@ -1,568 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* f e -| Val ans => - let (x, k) := ans in - Control.plus (fun _ => x) k -end. - -Ltac2 ifcatch t s f := -match Control.case t with -| Err e => f e -| Val ans => - let (x, k) := ans in - Control.plus (fun _ => s x) (fun e => s (k e)) -end. - -Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero (Tactic_failure None)). - -Ltac2 Notation fail := fail0 (). - -Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). - -Ltac2 Notation try := try0. - -Ltac2 rec repeat0 (t : unit -> unit) := - Control.enter (fun () => - ifcatch (fun _ => Control.progress t) - (fun _ => Control.check_interrupt (); repeat0 t) (fun _ => ())). - -Ltac2 Notation repeat := repeat0. - -Ltac2 dispatch0 t (head, tail) := - match tail with - | None => Control.enter (fun _ => t (); Control.dispatch head) - | Some tacs => - let (def, rem) := tacs in - Control.enter (fun _ => t (); Control.extend head def rem) - end. - -Ltac2 Notation t(thunk(self)) ">" "[" l(dispatch) "]" : 4 := dispatch0 t l. - -Ltac2 do0 n t := - let rec aux n t := match Int.equal n 0 with - | true => () - | false => t (); aux (Int.sub n 1) t - end in - aux (n ()) t. - -Ltac2 Notation do := do0. - -Ltac2 Notation once := Control.once. - -Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). - -Ltac2 Notation progress := progress0. - -Ltac2 rec first0 tacs := -match tacs with -| [] => Control.zero (Tactic_failure None) -| tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) -end. - -Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs. - -Ltac2 complete tac := - let ans := tac () in - Control.enter (fun () => Control.zero (Tactic_failure None)); - ans. - -Ltac2 rec solve0 tacs := -match tacs with -| [] => Control.zero (Tactic_failure None) -| tac :: tacs => - Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) -end. - -Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. - -Ltac2 time0 tac := Control.time None tac. - -Ltac2 Notation time := time0. - -Ltac2 abstract0 tac := Control.abstract None tac. - -Ltac2 Notation abstract := abstract0. - -(** Base tactics *) - -(** Note that we redeclare notations that can be parsed as mere identifiers - as abbreviations, so that it allows to parse them as function arguments - without having to write them within parentheses. *) - -(** Enter and check evar resolution *) -Ltac2 enter_h ev f arg := -match ev with -| true => Control.enter (fun () => f ev (arg ())) -| false => - Control.enter (fun () => - Control.with_holes arg (fun x => f ev x)) -end. - -Ltac2 intros0 ev p := - Control.enter (fun () => Std.intros false p). - -Ltac2 Notation "intros" p(intropatterns) := intros0 false p. -Ltac2 Notation intros := intros. - -Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. -Ltac2 Notation eintros := eintros. - -Ltac2 split0 ev bnd := - enter_h ev Std.split bnd. - -Ltac2 Notation "split" bnd(thunk(with_bindings)) := split0 false bnd. -Ltac2 Notation split := split. - -Ltac2 Notation "esplit" bnd(thunk(with_bindings)) := split0 true bnd. -Ltac2 Notation esplit := esplit. - -Ltac2 exists0 ev bnds := match bnds with -| [] => split0 ev (fun () => Std.NoBindings) -| _ => - let rec aux bnds := match bnds with - | [] => () - | bnd :: bnds => split0 ev bnd; aux bnds - end in - aux bnds -end. - -Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. -(* Ltac2 Notation exists := exists. *) - -Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. -Ltac2 Notation eexists := eexists. - -Ltac2 left0 ev bnd := enter_h ev Std.left bnd. - -Ltac2 Notation "left" bnd(thunk(with_bindings)) := left0 false bnd. -Ltac2 Notation left := left. - -Ltac2 Notation "eleft" bnd(thunk(with_bindings)) := left0 true bnd. -Ltac2 Notation eleft := eleft. - -Ltac2 right0 ev bnd := enter_h ev Std.right bnd. - -Ltac2 Notation "right" bnd(thunk(with_bindings)) := right0 false bnd. -Ltac2 Notation right := right. - -Ltac2 Notation "eright" bnd(thunk(with_bindings)) := right0 true bnd. -Ltac2 Notation eright := eright. - -Ltac2 constructor0 ev n bnd := - enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. - -Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). -Ltac2 Notation constructor := constructor. -Ltac2 Notation "constructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 false n bnd. - -Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). -Ltac2 Notation econstructor := econstructor. -Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. - -Ltac2 specialize0 c pat := - enter_h false (fun _ c => Std.specialize c pat) c. - -Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("as", intropattern))) := - specialize0 c ipat. - -Ltac2 elim0 ev c bnd use := - let f ev (c, bnd, use) := Std.elim ev (c, bnd) use in - enter_h ev f (fun () => c (), bnd (), use ()). - -Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) - use(thunk(opt(seq("using", constr, with_bindings)))) := - elim0 false c bnd use. - -Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) - use(thunk(opt(seq("using", constr, with_bindings)))) := - elim0 true c bnd use. - -Ltac2 apply0 adv ev cb cl := - Std.apply adv ev cb cl. - -Ltac2 Notation "eapply" - cb(list1(thunk(seq(constr, with_bindings)), ",")) - cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := - apply0 true true cb cl. - -Ltac2 Notation "apply" - cb(list1(thunk(seq(constr, with_bindings)), ",")) - cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := - apply0 true false cb cl. - -Ltac2 default_on_concl cl := -match cl with -| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } -| Some cl => cl -end. - -Ltac2 pose0 ev p := - enter_h ev (fun ev (na, p) => Std.pose na p) p. - -Ltac2 Notation "pose" p(thunk(pose)) := - pose0 false p. - -Ltac2 Notation "epose" p(thunk(pose)) := - pose0 true p. - -Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := - Std.set false p (default_on_concl cl). - -Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := - Std.set true p (default_on_concl cl). - -Ltac2 assert0 ev ast := - enter_h ev (fun _ ast => Std.assert ast) ast. - -Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. - -Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. - -Ltac2 default_everywhere cl := -match cl with -| None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } -| Some cl => cl -end. - -Ltac2 Notation "remember" - c(thunk(open_constr)) - na(opt(seq("as", ident))) - pat(opt(seq("eqn", ":", intropattern))) - cl(opt(clause)) := - Std.remember false na c pat (default_everywhere cl). - -Ltac2 Notation "eremember" - c(thunk(open_constr)) - na(opt(seq("as", ident))) - pat(opt(seq("eqn", ":", intropattern))) - cl(opt(clause)) := - Std.remember true na c pat (default_everywhere cl). - -Ltac2 induction0 ev ic use := - let f ev use := Std.induction ev ic use in - enter_h ev f use. - -Ltac2 Notation "induction" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - induction0 false ic use. - -Ltac2 Notation "einduction" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - induction0 true ic use. - -Ltac2 generalize0 gen := - enter_h false (fun _ gen => Std.generalize gen) gen. - -Ltac2 Notation "generalize" - gen(thunk(list1(seq (open_constr, occurrences, opt(seq("as", ident))), ","))) := - generalize0 gen. - -Ltac2 destruct0 ev ic use := - let f ev use := Std.destruct ev ic use in - enter_h ev f use. - -Ltac2 Notation "destruct" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - destruct0 false ic use. - -Ltac2 Notation "edestruct" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - destruct0 true ic use. - -Ltac2 Notation "simple" "inversion" - arg(destruction_arg) - pat(opt(seq("as", intropattern))) - ids(opt(seq("in", list1(ident)))) := - Std.inversion Std.SimpleInversion arg pat ids. - -Ltac2 Notation "inversion" - arg(destruction_arg) - pat(opt(seq("as", intropattern))) - ids(opt(seq("in", list1(ident)))) := - Std.inversion Std.FullInversion arg pat ids. - -Ltac2 Notation "inversion_clear" - arg(destruction_arg) - pat(opt(seq("as", intropattern))) - ids(opt(seq("in", list1(ident)))) := - Std.inversion Std.FullInversionClear arg pat ids. - -Ltac2 Notation "red" cl(opt(clause)) := - Std.red (default_on_concl cl). -Ltac2 Notation red := red. - -Ltac2 Notation "hnf" cl(opt(clause)) := - Std.hnf (default_on_concl cl). -Ltac2 Notation hnf := hnf. - -Ltac2 Notation "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.simpl s pl (default_on_concl cl). -Ltac2 Notation simpl := simpl. - -Ltac2 Notation "cbv" s(strategy) cl(opt(clause)) := - Std.cbv s (default_on_concl cl). -Ltac2 Notation cbv := cbv. - -Ltac2 Notation "cbn" s(strategy) cl(opt(clause)) := - Std.cbn s (default_on_concl cl). -Ltac2 Notation cbn := cbn. - -Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := - Std.lazy s (default_on_concl cl). -Ltac2 Notation lazy := lazy. - -Ltac2 Notation "unfold" pl(list1(seq(reference, occurrences), ",")) cl(opt(clause)) := - Std.unfold pl (default_on_concl cl). - -Ltac2 fold0 pl cl := - let cl := default_on_concl cl in - Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). - -Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := - fold0 pl cl. - -Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := - Std.pattern pl (default_on_concl cl). - -Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.vm pl (default_on_concl cl). -Ltac2 Notation vm_compute := vm_compute. - -Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.native pl (default_on_concl cl). -Ltac2 Notation native_compute := native_compute. - -Ltac2 change0 p cl := - let (pat, c) := p in - Std.change pat c (default_on_concl cl). - -Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. - -Ltac2 rewrite0 ev rw cl tac := - let cl := default_on_concl cl in - Std.rewrite ev rw cl tac. - -Ltac2 Notation "rewrite" - rw(list1(rewriting, ",")) - cl(opt(clause)) - tac(opt(seq("by", thunk(tactic)))) := - rewrite0 false rw cl tac. - -Ltac2 Notation "erewrite" - rw(list1(rewriting, ",")) - cl(opt(clause)) - tac(opt(seq("by", thunk(tactic)))) := - rewrite0 true rw cl tac. - -(** coretactics *) - -Ltac2 exact0 ev c := - Control.enter (fun _ => - match ev with - | true => - let c := c () in - Control.refine (fun _ => c) - | false => - Control.with_holes c (fun c => Control.refine (fun _ => c)) - end - ). - -Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. -Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. - -Ltac2 Notation "intro" id(opt(ident)) mv(opt(move_location)) := Std.intro id mv. -Ltac2 Notation intro := intro. - -Ltac2 Notation "move" id(ident) mv(move_location) := Std.move id mv. - -Ltac2 Notation reflexivity := Std.reflexivity (). - -Ltac2 symmetry0 cl := - Std.symmetry (default_on_concl cl). - -Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. -Ltac2 Notation symmetry := symmetry. - -Ltac2 Notation "revert" ids(list1(ident)) := Std.revert ids. - -Ltac2 Notation assumption := Std.assumption (). - -Ltac2 Notation etransitivity := Std.etransitivity (). - -Ltac2 Notation admit := Std.admit (). - -Ltac2 clear0 ids := match ids with -| [] => Std.keep [] -| _ => Std.clear ids -end. - -Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. -Ltac2 Notation "clear" "-" ids(list1(ident)) := Std.keep ids. -Ltac2 Notation clear := clear. - -Ltac2 Notation refine := Control.refine. - -(** extratactics *) - -Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). - -Ltac2 Notation "absurd" c(thunk(open_constr)) := absurd0 c. - -Ltac2 subst0 ids := match ids with -| [] => Std.subst_all () -| _ => Std.subst ids -end. - -Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. -Ltac2 Notation subst := subst. - -Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := - Std.discriminate false arg. -Ltac2 Notation discriminate := discriminate. - -Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := - Std.discriminate true arg. -Ltac2 Notation ediscriminate := ediscriminate. - -Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= - Std.injection false ipat arg. - -Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= - Std.injection true ipat arg. - -(** Auto *) - -Ltac2 default_db dbs := match dbs with -| None => Some [] -| Some dbs => - match dbs with - | None => None - | Some l => Some l - end -end. - -Ltac2 default_list use := match use with -| None => [] -| Some use => use -end. - -Ltac2 trivial0 use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.trivial Std.Off use dbs. - -Ltac2 Notation "trivial" - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := trivial0 use dbs. - -Ltac2 Notation trivial := trivial. - -Ltac2 auto0 n use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.auto Std.Off n use dbs. - -Ltac2 Notation "auto" n(opt(tactic(0))) - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := auto0 n use dbs. - -Ltac2 Notation auto := auto. - -Ltac2 new_eauto0 n use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.new_auto Std.Off n use dbs. - -Ltac2 Notation "new" "auto" n(opt(tactic(0))) - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := new_eauto0 n use dbs. - -Ltac2 eauto0 n p use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.eauto Std.Off n p use dbs. - -Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := eauto0 n p use dbs. - -Ltac2 Notation eauto := eauto. - -Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) - dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto None n dbs. - -Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) - dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto (Some Std.BFS) n dbs. - -Ltac2 Notation typeclasses_eauto := typeclasses_eauto. - -(** Congruence *) - -Ltac2 f_equal0 () := ltac1:(f_equal). -Ltac2 Notation f_equal := f_equal0 (). - -(** Firstorder *) - -Ltac2 firstorder0 tac refs ids := - let refs := default_list refs in - let ids := default_list ids in - Std.firstorder tac refs ids. - -Ltac2 Notation "firstorder" - tac(opt(thunk(tactic))) - refs(opt(seq("using", list1(reference, ",")))) - ids(opt(seq("with", list1(ident)))) := firstorder0 tac refs ids. - -(** now *) - -Ltac2 now0 t := t (); ltac1:(easy). -Ltac2 Notation "now" t(thunk(self)) := now0 t. diff --git a/theories/Pattern.v b/theories/Pattern.v deleted file mode 100644 index 8d1fb0cd8a..0000000000 --- a/theories/Pattern.v +++ /dev/null @@ -1,145 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* context := - "ltac2" "pattern_empty_context". -(** A trivial context only made of the hole. *) - -Ltac2 @ external matches : t -> constr -> (ident * constr) list := - "ltac2" "pattern_matches". -(** If the term matches the pattern, returns the bound variables. If it doesn't, - fail with [Match_failure]. Panics if not focussed. *) - -Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := - "ltac2" "pattern_matches_subterm". -(** Returns a stream of results corresponding to all of the subterms of the term - that matches the pattern as in [matches]. The stream is encoded as a - backtracking value whose last exception is [Match_failure]. The additional - value compared to [matches] is the context of the match, to be filled with - the instantiate function. *) - -Ltac2 @ external matches_vect : t -> constr -> constr array := - "ltac2" "pattern_matches_vect". -(** Internal version of [matches] that does not return the identifiers. *) - -Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := - "ltac2" "pattern_matches_subterm_vect". -(** Internal version of [matches_subterms] that does not return the identifiers. *) - -Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t) -> - ident array * context array * constr array * context := - "ltac2" "pattern_matches_goal". -(** Given a list of patterns [hpats] for hypotheses and one pattern [cpat] for the - conclusion, [matches_goal rev hpats cpat] produces (a stream of) tuples of: - - An array of idents, whose size is the length of [hpats], corresponding to the - name of matched hypotheses. - - An array of contexts, whose size is the length of [hpats], corresponding to - the contexts matched for every hypothesis pattern. In case the match kind of - a hypothesis was [MatchPattern], the corresponding context is ensured to be empty. - - An array of terms, whose size is the total number of pattern variables without - duplicates. Terms are ordered by identifier order, e.g. ?a comes before ?b. - - A context corresponding to the conclusion, which is ensured to be empty if - the kind of [cpat] was [MatchPattern]. - This produces a backtracking stream of results containing all the possible - result combinations. The order of considered hypotheses is reversed if [rev] - is true. -*) - -Ltac2 @ external instantiate : context -> constr -> constr := - "ltac2" "pattern_instantiate". -(** Fill the hole of a context with the given term. *) - -(** Implementation of Ltac matching over terms and goals *) - -Ltac2 lazy_match0 t pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (knd, pat, f) := p in - let p := match knd with - | MatchPattern => - (fun _ => - let context := empty_context () in - let bind := matches_vect pat t in - fun _ => f context bind) - | MatchContext => - (fun _ => - let (context, bind) := matches_subterm_vect pat t in - fun _ => f context bind) - end in - Control.plus p next - end in - Control.once (fun () => interp pats) (). - -Ltac2 multi_match0 t pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (knd, pat, f) := p in - let p := match knd with - | MatchPattern => - (fun _ => - let context := empty_context () in - let bind := matches_vect pat t in - f context bind) - | MatchContext => - (fun _ => - let (context, bind) := matches_subterm_vect pat t in - f context bind) - end in - Control.plus p next - end in - interp pats. - -Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). - -Ltac2 lazy_goal_match0 rev pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (pat, f) := p in - let (phyps, pconcl) := pat in - let cur _ := - let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in - fun _ => f hids hctx subst cctx - in - Control.plus cur next - end in - Control.once (fun () => interp pats) (). - -Ltac2 multi_goal_match0 rev pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (pat, f) := p in - let (phyps, pconcl) := pat in - let cur _ := - let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in - f hids hctx subst cctx - in - Control.plus cur next - end in - interp pats. - -Ltac2 one_goal_match0 rev pats := Control.once (fun _ => multi_goal_match0 rev pats). diff --git a/theories/Std.v b/theories/Std.v deleted file mode 100644 index 73b2ba02c4..0000000000 --- a/theories/Std.v +++ /dev/null @@ -1,263 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr), intro_pattern) -| IntroRewrite (bool) -] -with or_and_intro_pattern := [ -| IntroOrPattern (intro_pattern list list) -| IntroAndPattern (intro_pattern list) -]. - -Ltac2 Type destruction_arg := [ -| ElimOnConstr (unit -> constr_with_bindings) -| ElimOnIdent (ident) -| ElimOnAnonHyp (int) -]. - -Ltac2 Type induction_clause := { - indcl_arg : destruction_arg; - indcl_eqn : intro_pattern_naming option; - indcl_as : or_and_intro_pattern option; - indcl_in : clause option; -}. - -Ltac2 Type assertion := [ -| AssertType (intro_pattern option, constr, (unit -> unit) option) -| AssertValue (ident, constr) -]. - -Ltac2 Type repeat := [ -| Precisely (int) -| UpTo (int) -| RepeatStar -| RepeatPlus -]. - -Ltac2 Type orientation := [ LTR | RTL ]. - -Ltac2 Type rewriting := { - rew_orient : orientation option; - rew_repeat : repeat; - rew_equatn : (unit -> constr_with_bindings); -}. - -Ltac2 Type evar_flag := bool. -Ltac2 Type advanced_flag := bool. - -Ltac2 Type move_location := [ -| MoveAfter (ident) -| MoveBefore (ident) -| MoveFirst -| MoveLast -]. - -Ltac2 Type inversion_kind := [ -| SimpleInversion -| FullInversion -| FullInversionClear -]. - -(** Standard, built-in tactics. See Ltac1 for documentation. *) - -Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". - -Ltac2 @ external apply : advanced_flag -> evar_flag -> - (unit -> constr_with_bindings) list -> (ident * (intro_pattern option)) option -> unit := "ltac2" "tac_apply". - -Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". -Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". - -Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". - -Ltac2 @ external assert : assertion -> unit := "ltac2" "tac_assert". -Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". - -Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". -Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". - -Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". - -Ltac2 @ external destruct : evar_flag -> induction_clause list -> - constr_with_bindings option -> unit := "ltac2" "tac_induction". - -Ltac2 @ external induction : evar_flag -> induction_clause list -> - constr_with_bindings option -> unit := "ltac2" "tac_induction". - -Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". -Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". -Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_simpl". -Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". -Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". -Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". -Ltac2 @ external unfold : (reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". -Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". -Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". -Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". -Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". - -Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". -Ltac2 @ external eval_hnf : constr -> constr := "ltac2" "eval_hnf". -Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". -Ltac2 @ external eval_simpl : red_flags -> (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_simpl". -Ltac2 @ external eval_cbv : red_flags -> constr -> constr := "ltac2" "eval_cbv". -Ltac2 @ external eval_cbn : red_flags -> constr -> constr := "ltac2" "eval_cbn". -Ltac2 @ external eval_lazy : red_flags -> constr -> constr := "ltac2" "eval_lazy". -Ltac2 @ external eval_unfold : (reference * occurrences) list -> constr -> constr := "ltac2" "eval_unfold". -Ltac2 @ external eval_fold : constr list -> constr -> constr := "ltac2" "eval_fold". -Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr := "ltac2" "eval_pattern". -Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". -Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". - -Ltac2 @ external change : pattern option -> (constr array -> constr) -> clause -> unit := "ltac2" "tac_change". - -Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". - -Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". - -Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". - -Ltac2 @ external transitivity : constr -> unit := "ltac2" "tac_transitivity". - -Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". - -Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". - -Ltac2 @ external left : evar_flag -> bindings -> unit := "ltac2" "tac_left". -Ltac2 @ external right : evar_flag -> bindings -> unit := "ltac2" "tac_right". - -Ltac2 @ external constructor : evar_flag -> unit := "ltac2" "tac_constructor". -Ltac2 @ external split : evar_flag -> bindings -> unit := "ltac2" "tac_split". - -Ltac2 @ external constructor_n : evar_flag -> int -> bindings -> unit := "ltac2" "tac_constructorn". - -Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". - -Ltac2 @ external symmetry : clause -> unit := "ltac2" "tac_symmetry". - -Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". - -Ltac2 @ external revert : ident list -> unit := "ltac2" "tac_revert". - -Ltac2 @ external admit : unit -> unit := "ltac2" "tac_admit". - -Ltac2 @ external fix_ : ident option -> int -> unit := "ltac2" "tac_fix". -Ltac2 @ external cofix_ : ident option -> unit := "ltac2" "tac_cofix". - -Ltac2 @ external clear : ident list -> unit := "ltac2" "tac_clear". -Ltac2 @ external keep : ident list -> unit := "ltac2" "tac_keep". - -Ltac2 @ external clearbody : ident list -> unit := "ltac2" "tac_clearbody". - -Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". -Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". -Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". - -Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern option -> ident list option -> unit := "ltac2" "tac_inversion". - -(** coretactics *) - -Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". - -Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". - -Ltac2 @ external specialize : constr_with_bindings -> intro_pattern option -> unit := "ltac2" "tac_specialize". - -(** extratactics *) - -Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". -Ltac2 @ external injection : evar_flag -> intro_pattern list option -> destruction_arg option -> unit := "ltac2" "tac_injection". - -Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". -Ltac2 @ external contradiction : constr_with_bindings option -> unit := "ltac2" "tac_contradiction". - -Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> clause -> unit := "ltac2" "tac_autorewrite". - -Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". -Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". - -(** auto *) - -Ltac2 Type debug := [ Off | Info | Debug ]. - -Ltac2 Type strategy := [ BFS | DFS ]. - -Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". - -Ltac2 @ external auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_auto". - -Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_newauto". - -Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". - -Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". - -(** firstorder *) - -Ltac2 @ external firstorder : (unit -> unit) option -> reference list -> ident list -> unit := "ltac2" "tac_firstorder". diff --git a/theories/String.v b/theories/String.v deleted file mode 100644 index 99e1dab76b..0000000000 --- a/theories/String.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* char -> string := "ltac2" "string_make". -Ltac2 @external length : string -> int := "ltac2" "string_length". -Ltac2 @external get : string -> int -> char := "ltac2" "string_get". -Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/theories/dune b/theories/dune deleted file mode 100644 index 1fe3ba28fe..0000000000 --- a/theories/dune +++ /dev/null @@ -1,6 +0,0 @@ -(coqlib - (name Ltac2) ; This determines the -R flag - (public_name ltac2.Ltac2) - (synopsis "Ltac 2 Plugin") - (libraries ltac2.plugin)) - diff --git a/vendor/Ltac2/.gitignore b/vendor/Ltac2/.gitignore new file mode 100644 index 0000000000..00e15f8daa --- /dev/null +++ b/vendor/Ltac2/.gitignore @@ -0,0 +1,18 @@ +Makefile.coq +Makefile.coq.conf +*.glob +*.d +*.d.raw +*.vio +*.vo +*.cm* +*.annot +*.spit +*.spot +*.o +*.a +*.aux +tests/*.log +*.install +_build +.merlin diff --git a/vendor/Ltac2/.travis.yml b/vendor/Ltac2/.travis.yml new file mode 100644 index 0000000000..2628abde45 --- /dev/null +++ b/vendor/Ltac2/.travis.yml @@ -0,0 +1,40 @@ +dist: trusty +sudo: required +language: generic + +services: + - docker + +env: + global: + - NJOBS="2" + - CONTRIB_NAME="ltac2" + matrix: + - COQ_IMAGE="coqorg/coq:dev" + +install: | + # Prepare the COQ container + docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/${CONTRIB_NAME} -w /home/coq/${CONTRIB_NAME} ${COQ_IMAGE} + docker exec COQ /bin/bash --login -c " + # This bash script is double-quoted to interpolate Travis CI env vars: + echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex # -e = exit on failure; -x = trace for debug + # opam update -y + # opam install -y -j ${NJOBS} coq-mathcomp-ssreflect + opam config list + opam repo list + opam list + " +script: +- echo -e "${ANSI_YELLOW}Building ${CONTRIB_NAME}...${ANSI_RESET}" && echo -en 'travis_fold:start:script\\r' +- | + docker exec COQ /bin/bash --login -c " + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex + sudo chown -R coq:coq /home/coq/${CONTRIB_NAME} + make + make tests + " +- docker stop COQ # optional +- echo -en 'travis_fold:end:script\\r' diff --git a/vendor/Ltac2/LICENSE b/vendor/Ltac2/LICENSE new file mode 100644 index 0000000000..27950e8d20 --- /dev/null +++ b/vendor/Ltac2/LICENSE @@ -0,0 +1,458 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/vendor/Ltac2/Makefile b/vendor/Ltac2/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/vendor/Ltac2/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/vendor/Ltac2/README.md b/vendor/Ltac2/README.md new file mode 100644 index 0000000000..d49dd88076 --- /dev/null +++ b/vendor/Ltac2/README.md @@ -0,0 +1,25 @@ +[![Build Status](https://travis-ci.org/ppedrot/ltac2.svg?branch=master)](https://travis-ci.org/ppedrot/ltac2) + +Overview +======== + +This is a standalone version of the Ltac2 plugin. Ltac2 is an attempt at +providing the Coq users with a tactic language that is more robust and more +expressive than the venerable Ltac language. + +Status +======== + +It is mostly a toy to experiment for now, and the implementation is quite +bug-ridden. Don't mistake this for a final product! + +Installation +============ + +This should compile with Coq master, assuming the `COQBIN` variable is set +correctly. Standard procedures for `coq_makefile`-generated plugins apply. + +Demo +==== + +Horrible test-files are provided in the `tests` folder. Not for kids. diff --git a/vendor/Ltac2/_CoqProject b/vendor/Ltac2/_CoqProject new file mode 100644 index 0000000000..dda5a8001a --- /dev/null +++ b/vendor/Ltac2/_CoqProject @@ -0,0 +1,51 @@ +-R theories/ Ltac2 +-I src/ + +src/tac2dyn.ml +src/tac2dyn.mli +src/tac2expr.mli +src/tac2types.mli +src/tac2env.ml +src/tac2env.mli +src/tac2print.ml +src/tac2print.mli +src/tac2intern.ml +src/tac2intern.mli +src/tac2interp.ml +src/tac2interp.mli +src/tac2entries.ml +src/tac2entries.mli +src/tac2ffi.ml +src/tac2ffi.mli +src/tac2qexpr.mli +src/tac2quote.ml +src/tac2quote.mli +src/tac2match.ml +src/tac2match.mli +src/tac2core.ml +src/tac2core.mli +src/tac2extffi.ml +src/tac2extffi.mli +src/tac2tactics.ml +src/tac2tactics.mli +src/tac2stdlib.ml +src/tac2stdlib.mli +src/g_ltac2.mlg +src/ltac2_plugin.mlpack + +theories/Init.v +theories/Int.v +theories/Char.v +theories/String.v +theories/Ident.v +theories/Array.v +theories/Control.v +theories/Message.v +theories/Constr.v +theories/Pattern.v +theories/Fresh.v +theories/Std.v +theories/Env.v +theories/Notations.v +theories/Ltac1.v +theories/Ltac2.v diff --git a/vendor/Ltac2/doc/ltac2.md b/vendor/Ltac2/doc/ltac2.md new file mode 100644 index 0000000000..b217cb08e6 --- /dev/null +++ b/vendor/Ltac2/doc/ltac2.md @@ -0,0 +1,1036 @@ +# Summary + +The Ltac tactic language is probably one of the ingredients of the success of +Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: + +- has nothing like intended semantics +- is very non-uniform due to organic growth +- lacks expressivity and requires programming-by-hacking +- is slow +- is error-prone and fragile +- has an intricate implementation + +This has a lot of terrible consequences, most notably the fact that it is never +clear whether some observed behaviour is a bug or a proper one. + +Following the need of users that start developing huge projects relying +critically on Ltac, we believe that we should offer a proper modern language +that features at least the following: + +- at least informal, predictable semantics +- a typing system +- standard programming facilities (i.e. datatypes) + +This document describes the implementation of such a language. The +implementation of Ltac as of Coq 8.7 will be referred to as Ltac1. + +# Contents + + +**Table of Contents** + +- [Summary](#summary) +- [Contents](#contents) +- [General design](#general-design) +- [ML component](#ml-component) + - [Overview](#overview) + - [Type Syntax](#type-syntax) + - [Type declarations](#type-declarations) + - [Term Syntax](#term-syntax) + - [Ltac Definitions](#ltac-definitions) + - [Reduction](#reduction) + - [Typing](#typing) + - [Effects](#effects) + - [Standard IO](#standard-io) + - [Fatal errors](#fatal-errors) + - [Backtrack](#backtrack) + - [Goals](#goals) +- [Meta-programming](#meta-programming) + - [Overview](#overview-1) + - [Generic Syntax for Quotations](#generic-syntax-for-quotations) + - [Built-in quotations](#built-in-quotations) + - [Strict vs. non-strict mode](#strict-vs-non-strict-mode) + - [Term Antiquotations](#term-antiquotations) + - [Syntax](#syntax) + - [Semantics](#semantics) + - [Static semantics](#static-semantics) + - [Dynamic semantics](#dynamic-semantics) + - [Trivial Term Antiquotations](#trivial-term-antiquotations) + - [Match over terms](#match-over-terms) + - [Match over goals](#match-over-goals) +- [Notations](#notations) + - [Scopes](#scopes) + - [Notations](#notations-1) + - [Abbreviations](#abbreviations) +- [Evaluation](#evaluation) +- [Debug](#debug) +- [Compatibility layer with Ltac1](#compatibility-layer-with-ltac1) + - [Ltac1 from Ltac2](#ltac1-from-ltac2) + - [Ltac2 from Ltac1](#ltac2-from-ltac1) +- [Transition from Ltac1](#transition-from-ltac1) + - [Syntax changes](#syntax-changes) + - [Tactic delay](#tactic-delay) + - [Variable binding](#variable-binding) + - [In Ltac expressions](#in-ltac-expressions) + - [In quotations](#in-quotations) + - [Exception catching](#exception-catching) +- [TODO](#todo) + + + + +# General design + +There are various alternatives to Ltac1, such that Mtac or Rtac for instance. +While those alternatives can be quite distinct from Ltac1, we designed +Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +aforementioned defects. + +In particular, Ltac2 is: +- a member of the ML family of languages, i.e. + * a call-by-value functional language + * with effects + * together with Hindley-Milner type system +- a language featuring meta-programming facilities for the manipulation of + Coq-side terms +- a language featuring notation facilities to help writing palatable scripts + +We describe more in details each point in the remainder of this document. + +# ML component + +## Overview + +Ltac2 is a member of the ML family of languages, in the sense that it is an +effectful call-by-value functional language, with static typing à la +Hindley-Milner. It is commonly accepted that ML constitutes a sweet spot in PL +design, as it is relatively expressive while not being either too lax +(contrarily to dynamic typing) nor too strict (contrarily to say, dependent +types). + +The main goal of Ltac2 is to serve as a meta-language for Coq. As such, it +naturally fits in the ML lineage, just as the historical ML was designed as +the tactic language for the LCF prover. It can also be seen as a general-purpose +language, by simply forgetting about the Coq-specific features. + +Sticking to a standard ML type system can be considered somewhat weak for a +meta-language designed to manipulate Coq terms. In particular, there is no +way to statically guarantee that a Coq term resulting from an Ltac2 +computation will be well-typed. This is actually a design choice, motivated +by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +dynamic checks, allowing many primitive functions to fail whenever they are +provided with an ill-typed term. + +The language is naturally effectful as it manipulates the global state of the +proof engine. This allows to think of proof-modifying primitives as effects +in a straightforward way. Semantically, proof manipulation lives in a monad, +which allows to ensure that Ltac2 satisfies the same equations as a generic ML +with unspecified effects would do, e.g. function reduction is substitution +by a value. + +## Type Syntax + +At the level of terms, we simply elaborate on Ltac1 syntax, which is quite +close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. + +``` +TYPE := +| "(" TYPE₀ "," ... "," TYPEₙ ")" TYPECONST +| "(" TYPE₀ "*" ... "*" TYPEₙ ")" +| TYPE₁ "->" TYPE₂ +| TYPEVAR + +TYPECONST := ( MODPATH "." )* LIDENT + +TYPEVAR := "'" LIDENT + +TYPEPARAMS := "(" TYPEVAR₀ "," ... "," TYPEVARₙ ")" +``` + +The set of base types can be extended thanks to the usual ML type +declarations such as algebraic datatypes and records. + +Built-in types include: +- `int`, machine integers (size not specified, in practice inherited from OCaml) +- `string`, mutable strings +- `'a array`, mutable arrays +- `exn`, exceptions +- `constr`, kernel-side terms +- `pattern`, term patterns +- `ident`, well-formed identifiers + +## Type declarations + +One can define new types by the following commands. + +``` +VERNAC ::= +| "Ltac2" "Type" TYPEPARAMS LIDENT +| "Ltac2" "Type" RECFLAG TYPEPARAMS LIDENT ":=" TYPEDEF + +RECFLAG := ( "rec" ) +``` + +The first command defines an abstract type. It has no use for the end user and +is dedicated to types representing data coming from the OCaml world. + +The second command defines a type with a manifest. There are four possible +kinds of such definitions: alias, variant, record and open variant types. + +``` +TYPEDEF := +| TYPE +| "[" CONSTRUCTORDEF₀ "|" ... "|" CONSTRUCTORDEFₙ "]" +| "{" FIELDDEF₀ ";" ... ";" FIELDDEFₙ "}" +| "[" ".." "]" + +CONSTRUCTORDEF := +| IDENT ( "(" TYPE₀ "," ... "," TYPE₀ ")" ) + +FIELDDEF := +| MUTFLAG IDENT ":" TYPE + +MUTFLAG := ( "mutable" ) +``` + +Aliases are just a name for a given type expression and are transparently +unfoldable to it. They cannot be recursive. + +Variants are sum types defined by constructors and eliminated by +pattern-matching. They can be recursive, but the `RECFLAG` must be explicitly +set. Pattern-maching must be exhaustive. + +Records are product types with named fields and eliminated by projection. +Likewise they can be recursive if the `RECFLAG` is set. + +Open variants are a special kind of variant types whose constructors are not +statically defined, but can instead be extended dynamically. A typical example +is the standard `exn` type. Pattern-matching must always include a catch-all +clause. They can be extended by the following command. + +``` +VERNAC ::= +| "Ltac2" "Type" TYPEPARAMS QUALID ":=" "[" CONSTRUCTORDEF "]" +``` + +## Term Syntax + +The syntax of the functional fragment is very close to the one of Ltac1, except +that it adds a true pattern-matching feature, as well as a few standard +constructions from ML. + +``` +VAR := LIDENT + +QUALID := ( MODPATH "." )* LIDENT + +CONSTRUCTOR := UIDENT + +TERM := +| QUALID +| CONSTRUCTOR TERM₀ ... TERMₙ +| TERM TERM₀ ... TERMₙ +| "fun" VAR "=>" TERM +| "let" VAR ":=" TERM "in" TERM +| "let" "rec" VAR ":=" TERM "in" TERM +| "match" TERM "with" BRANCH* "end" +| INT +| STRING +| "[|" TERM₀ ";" ... ";" TERMₙ "|]" +| "(" TERM₀ "," ... "," TERMₙ ")" +| "{" FIELD+ "}" +| TERM "." "(" QUALID ")" +| TERM₁ "." "(" QUALID ")" ":=" TERM₂ +| "["; TERM₀ ";" ... ";" TERMₙ "]" +| TERM₁ "::" TERM₂ +| ... + +BRANCH := +| PATTERN "=>" TERM + +PATTERN := +| VAR +| "_" +| "(" PATTERN₀ "," ... "," PATTERNₙ ")" +| CONSTRUCTOR PATTERN₀ ... PATTERNₙ +| "[" "]" +| PATTERN₁ "::" PATTERN₂ + +FIELD := +| QUALID ":=" TERM + +``` + +In practice, there is some additional syntactic sugar that allows e.g. to +bind a variable and match on it at the same time, in the usual ML style. + +There is a dedicated syntax for list and array litterals. + +Limitations: for now, deep pattern matching is not implemented yet. + +## Ltac Definitions + +One can define a new global Ltac2 value using the following syntax. +``` +VERNAC ::= +| "Ltac2" MUTFLAG RECFLAG LIDENT ":=" TERM +``` + +For semantic reasons, the body of the Ltac2 definition must be a syntactical +value, i.e. a function, a constant or a pure constructor recursively applied to +values. + +If the `RECFLAG` is set, the tactic is expanded into a recursive binding. + +If the `MUTFLAG` is set, the definition can be redefined at a later stage. This +can be performed through the following command. + +``` +VERNAC ::= +| "Ltac2" "Set" QUALID ":=" TERM +``` + +Mutable definitions act like dynamic binding, i.e. at runtime, the last defined +value for this entry is chosen. This is useful for global flags and the like. + +## Reduction + +We use the usual ML call-by-value reduction, with an otherwise unspecified +evaluation order. This is a design choice making it compatible with OCaml, +if ever we implement native compilation. The expected equations are as follows. +``` +(fun x => t) V ≡ t{x := V} (βv) + +let x := V in t ≡ t{x := V} (let) + +match C V₀ ... Vₙ with ... | C x₀ ... xₙ => t | ... end ≡ t {xᵢ := Vᵢ} (ι) + +(t any term, V values, C constructor) +``` + +Note that call-by-value reduction is already a departure from Ltac1 which uses +heuristics to decide when evaluating an expression. For instance, the following +expressions do not evaluate the same way in Ltac1. + +``` +foo (idtac; let x := 0 in bar) + +foo (let x := 0 in bar) +``` + +Instead of relying on the `idtac` hack, we would now require an explicit thunk +not to compute the argument, and `foo` would have e.g. type +`(unit -> unit) -> unit`. + +``` +foo (fun () => let x := 0 in bar) +``` + +## Typing + +Typing is strict and follows Hindley-Milner system. We will not implement the +current hackish subtyping semantics, and one will have to resort to conversion +functions. See notations though to make things more palatable. + +In this setting, all usual argument-free tactics have type `unit -> unit`, but +one can return as well a value of type `t` thanks to terms of type `unit -> t`, +or take additional arguments. + +## Effects + +Regarding effects, nothing involved here, except that instead of using the +standard IO monad as the ambient effectful world, Ltac2 is going to use the +tactic monad. + +Note that the order of evaluation of application is *not* specified and is +implementation-dependent, as in OCaml. + +We recall that the `Proofview.tactic` monad is essentially a IO monad together +with backtracking state representing the proof state. + +Intuitively a thunk of type `unit -> 'a` can do the following: +- It can perform non-backtracking IO like printing and setting mutable variables +- It can fail in a non-recoverable way +- It can use first-class backtrack. The proper way to figure that is that we + morally have the following isomorphism: + `(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a + lazy list of results where each tail is waiting for a continuation exception. +- It can access a backtracking proof state, made out amongst other things of + the current evar assignation and the list of goals under focus. + +We describe more thoroughly the various effects existing in Ltac2 hereafter. + +### Standard IO + +The Ltac2 language features non-backtracking IO, notably mutable data and +printing operations. + +Mutable fields of records can be modified using the set syntax. Likewise, +built-in types like `string` and `array` feature imperative assignment. See +modules `String` and `Array` respectively. + +A few printing primitives are provided in the `Message` module, allowing to +display information to the user. + +### Fatal errors + +The Ltac2 language provides non-backtracking exceptions through the +following primitive in module `Control`. + +``` +val throw : exn -> 'a +``` + +Contrarily to backtracking exceptions from the next section, this kind of error +is never caught by backtracking primitives, that is, throwing an exception +destroys the stack. This is materialized by the following equation, where `E` +is an evaluation context. + +``` +E[throw e] ≡ throw e + +(e value) +``` + +There is currently no way to catch such an exception and it is a design choice. +There might be at some future point a way to catch it in a brutal way, +destroying all backtrack and return values. + +### Backtrack + +In Ltac2, we have the following backtracking primitives, defined in the +`Control` module. + +``` +Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. + +val zero : exn -> 'a +val plus : (unit -> 'a) -> (exn -> 'a) -> 'a +val case : (unit -> 'a) -> ('a * (exn -> 'a)) result +``` + +If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +list concatenation, while `case` is pattern-matching. + +The backtracking is first-class, i.e. one can write +`plus (fun () => "x") (fun _ => "y") : string` producing a backtracking string. + +These operations are expected to satisfy a few equations, most notably that they +form a monoid compatible with sequentialization. + +``` +plus t zero ≡ t () +plus (fun () => zero e) f ≡ f e +plus (plus t f) g ≡ plus t (fun e => plus (f e) g) + +case (fun () => zero e) ≡ Err e +case (fun () => plus (fun () => t) f) ≡ Val t f + +let x := zero e in u ≡ zero e +let x := plus t f in u ≡ plus (fun () => let x := t in u) (fun e => let x := f e in u) + +(t, u, f, g, e values) +``` + +### Goals + +A goal is given by the data of its conclusion and hypotheses, i.e. it can be +represented as `[Γ ⊢ A]`. + +The tactic monad naturally operates over the whole proofview, which may +represent several goals, including none. Thus, there is no such thing as +*the current goal*. Goals are naturally ordered, though. + +It is natural to do the same in Ltac2, but we must provide a way to get access +to a given goal. This is the role of the `enter` primitive, that applies a +tactic to each currently focused goal in turn. + +``` +val enter : (unit -> unit) -> unit +``` + +It is guaranteed that when evaluating `enter f`, `f` is called with exactly one +goal under focus. Note that `f` may be called several times, or never, depending +on the number of goals under focus before the call to `enter`. + +Accessing the goal data is then implicit in the Ltac2 primitives, and may panic +if the invariants are not respected. The two essential functions for observing +goals are given below. + +``` +val hyp : ident -> constr +val goal : unit -> constr +``` + +The two above functions panic if there is not exactly one goal under focus. +In addition, `hyp` may also fail if there is no hypothesis with the +corresponding name. + +# Meta-programming + +## Overview + +One of the horrendous implementation issues of Ltac is the fact that it is +never clear whether an object refers to the object world or the meta-world. +This is an incredible source of slowness, as the interpretation must be +aware of bound variables and must use heuristics to decide whether a variable +is a proper one or referring to something in the Ltac context. + +Likewise, in Ltac1, constr parsing is implicit, so that `foo 0` is +not `foo` applied to the Ltac integer expression `0` (Ltac does have a +non-first-class notion of integers), but rather the Coq term `Datatypes.O`. + +We should stop doing that! We need to mark when quoting and unquoting, although +we need to do that in a short and elegant way so as not to be too cumbersome +to the user. + +## Generic Syntax for Quotations + +In general, quotations can be introduced in term by the following syntax, where +`QUOTENTRY` is some parsing entry. +``` +TERM ::= +| QUOTNAME ":" "(" QUOTENTRY ")" + +QUOTNAME := IDENT +``` + +### Built-in quotations + +The current implementation recognizes the following built-in quotations: +- "ident", which parses identifiers (type `Init.ident`). +- "constr", which parses Coq terms and produces an-evar free term at runtime + (type `Init.constr`). +- "open_constr", which parses Coq terms and produces a term potentially with + holes at runtime (type `Init.constr` as well). +- "pattern", which parses Coq patterns and produces a pattern used for term + matching (type `Init.pattern`). +- "reference", which parses either a `QUALID` or `"&" IDENT`. Qualified names + are globalized at internalization into the corresponding global reference, + while `&id` is turned into `Std.VarRef id`. This produces at runtime a + `Std.reference`. + +The following syntactic sugar is provided for two common cases. +- `@id` is the same as ident:(id) +- `'t` is the same as open_constr:(t) + +### Strict vs. non-strict mode + +Depending on the context, quotations producing terms (i.e. `constr` or +`open_constr`) are not internalized in the same way. There are two possible +modes, respectively called the *strict* and the *non-strict* mode. + +- In strict mode, all simple identifiers appearing in a term quotation are +required to be resolvable statically. That is, they must be the short name of +a declaration which is defined globally, excluding section variables and +hypotheses. If this doesn't hold, internalization will fail. To work around +this error, one has to specifically use the `&` notation. +- In non-strict mode, any simple identifier appearing in a term quotation which +is not bound in the global context is turned into a dynamic reference to a +hypothesis. That is to say, internalization will succeed, but the evaluation +of the term at runtime will fail if there is no such variable in the dynamic +context. + +Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +mode is only set when evaluating Ltac2 snippets in interactive proof mode. The +rationale is that it is cumbersome to explicitly add `&` interactively, while it +is expected that global tactics enforce more invariants on their code. + +## Term Antiquotations + +### Syntax + +One can also insert Ltac2 code into Coq term, similarly to what was possible in +Ltac1. + +``` +COQCONSTR ::= +| "ltac2" ":" "(" TERM ")" +``` + +Antiquoted terms are expected to have type `unit`, as they are only evaluated +for their side-effects. + +### Semantics + +Interpretation of a quoted Coq term is done in two phases, internalization and +evaluation. + +- Internalization is part of the static semantics, i.e. it is done at Ltac2 + typing time. +- Evaluation is part of the dynamic semantics, i.e. it is done when + a term gets effectively computed by Ltac2. + +Remark that typing of Coq terms is a *dynamic* process occuring at Ltac2 +evaluation time, and not at Ltac2 typing time. + +#### Static semantics + +During internalization, Coq variables are resolved and antiquotations are +type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq +implementation terminology. Note that although it went through the +type-checking of **Ltac2**, the resulting term has not been fully computed and +is potentially ill-typed as a runtime **Coq** term. + +``` +Ltac2 Definition myconstr () := constr:(nat -> 0). +// Valid with type `unit -> constr`, but will fail at runtime. +``` + +Term antiquotations are type-checked in the enclosing Ltac2 typing context +of the corresponding term expression. For instance, the following will +type-check. + +``` +let x := '0 in constr:(1 + ltac2:(exact x)) +// type constr +``` + +Beware that the typing environment of typing of antiquotations is **not** +expanded by the Coq binders from the term. Namely, it means that the following +Ltac2 expression will **not** type-check. +``` +constr:(fun x : nat => ltac2:(exact x)) +// Error: Unbound variable 'x' +``` + +There is a simple reason for that, which is that the following expression would +not make sense in general. +``` +constr:(fun x : nat => ltac2:(clear @x; exact x)) +``` +Indeed, a hypothesis can suddenly disappear from the runtime context if some +other tactic pulls the rug from under you. + +Rather, the tactic writer has to resort to the **dynamic** goal environment, +and must write instead explicitly that she is accessing a hypothesis, typically +as follows. +``` +constr:(fun x : nat => ltac2:(exact (hyp @x))) +``` + +This pattern is so common that we provide dedicated Ltac2 and Coq term notations +for it. + +- `&x` as an Ltac2 expression expands to `hyp @x`. +- `&x` as a Coq constr expression expands to + `ltac2:(Control.refine (fun () => hyp @x))`. + +#### Dynamic semantics + +During evaluation, a quoted term is fully evaluated to a kernel term, and is +in particular type-checked in the current environment. + +Evaluation of a quoted term goes as follows. +- The quoted term is first evaluated by the pretyper. +- Antiquotations are then evaluated in a context where there is exactly one goal +under focus, with the hypotheses coming from the current environment extended +with the bound variables of the term, and the resulting term is fed into the +quoted term. + +Relative orders of evaluation of antiquotations and quoted term are not +specified. + +For instance, in the following example, `tac` will be evaluated in a context +with exactly one goal under focus, whose last hypothesis is `H : nat`. The +whole expression will thus evaluate to the term `fun H : nat => nat`. +``` +let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ())) +``` + +Many standard tactics perform type-checking of their argument before going +further. It is your duty to ensure that terms are well-typed when calling +such tactics. Failure to do so will result in non-recoverable exceptions. + +## Trivial Term Antiquotations + +It is possible to refer to a variable of type `constr` in the Ltac2 environment +through a specific syntax consistent with the antiquotations presented in +the notation section. + +``` +COQCONSTR ::= +| "$" LIDENT +``` + +In a Coq term, writing `$x` is semantically equivalent to +`ltac2:(Control.refine (fun () => x))`, up to re-typechecking. It allows to +insert in a concise way an Ltac2 variable of type `constr` into a Coq term. + +## Match over terms + +Ltac2 features a construction similar to Ltac1 `match` over terms, although +in a less hard-wired way. + +``` +TERM ::= +| "match!" TERM "with" CONSTR-MATCHING* "end" +| "lazy_match!" TERM "with" CONSTR-MATCHING* "end" +| "multi_match!" TERM "with" CONSTR-MATCHING*"end" + +CONSTR-MATCHING := +| "|" CONSTR-PATTERN "=>" TERM + +CONSTR-PATTERN := +| CONSTR +| "context" LIDENT? "[" CONSTR "]" +``` + +This construction is not primitive and is desugared at parsing time into +calls to term matching functions from the `Pattern` module. Internally, it is +implemented thanks to a specific scope accepting the `CONSTR-MATCHING` syntax. + +Variables from the `CONSTR-PATTERN` are statically bound in the body of the branch, to +values of type `constr` for the variables from the `CONSTR` pattern and to a +value of type `Pattern.context` for the variable `LIDENT`. + +Note that contrarily to Ltac, only lowercase identifiers are valid as Ltac2 +bindings, so that there will be a syntax error if one of the bound variables +starts with an uppercase character. + +The semantics of this construction is otherwise the same as the corresponding +one from Ltac1, except that it requires the goal to be focused. + +## Match over goals + +Similarly, there is a way to match over goals in an elegant way, which is +just a notation desugared at parsing time. + +``` +TERM ::= +| "match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" +| "lazy_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" +| "multi_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING*"end" + +GOAL-MATCHING := +| "|" "[" HYP-MATCHING* "|-" CONSTR-PATTERN "]" "=>" TERM + +HYP-MATCHING := +| LIDENT ":" CONSTR-PATTERN + +MATCH-ORDER := +| "reverse" +``` + +Variables from `HYP-MATCHING` and `CONSTR-PATTERN` are bound in the body of the +branch. Their types are: +- `constr` for pattern variables appearing in a `CONSTR` +- `Pattern.context` for variables binding a context +- `ident` for variables binding a hypothesis name. + +The same identifier caveat as in the case of matching over constr applies, and +this features has the same semantics as in Ltac1. In particular, a `reverse` +flag can be specified to match hypotheses from the more recently introduced to +the least recently introduced one. + +# Notations + +Notations are the crux of the usability of Ltac1. We should be able to recover +a feeling similar to the old implementation by using and abusing notations. + +## Scopes + +A scope is a name given to a grammar entry used to produce some Ltac2 expression +at parsing time. Scopes are described using a form of S-expression. + +``` +SCOPE := +| STRING +| INT +| LIDENT ( "(" SCOPE₀ "," ... "," SCOPEₙ ")" ) +``` + +A few scopes contain antiquotation features. For sake of uniformity, all +antiquotations are introduced by the syntax `"$" VAR`. + +The following scopes are built-in. +- constr: + + parses `c = COQCONSTR` and produces `constr:(c)` +- ident: + + parses `id = IDENT` and produces `ident:(id)` + + parses `"$" (x = IDENT)` and produces the variable `x` +- list0(*scope*): + + if *scope* parses `ENTRY`, parses ̀`(x₀, ..., xₙ = ENTRY*)` and produces + `[x₀; ...; xₙ]`. +- list0(*scope*, sep = STRING): + + if *scope* parses `ENTRY`, parses `(x₀ = ENTRY, "sep", ..., "sep", xₙ = ENTRY)` + and produces `[x₀; ...; xₙ]`. +- list1: same as list0 (with or without separator) but parses `ENTRY+` instead + of `ENTRY*`. +- opt(*scope*) + + if *scope* parses `ENTRY`, parses `ENTRY?` and produces either `None` or + `Some x` where `x` is the parsed expression. +- self: + + parses a Ltac2 expression at the current level and return it as is. +- next: + + parses a Ltac2 expression at the next level and return it as is. +- tactic(n = INT): + + parses a Ltac2 expression at the provided level *n* and return it as is. +- thunk(*scope*): + + parses the same as *scope*, and if *e* is the parsed expression, returns + `fun () => e`. +- STRING: + + parses the corresponding string as a CAMLP5 IDENT and returns `()`. +- keyword(s = STRING): + + parses the string *s* as a keyword and returns `()`. +- terminal(s = STRING): + + parses the string *s* as a keyword, if it is already a + keyword, otherwise as an IDENT. Returns `()`. +- seq(*scope₁*, ..., *scopeₙ*): + + parses *scope₁*, ..., *scopeₙ* in this order, and produces a tuple made + out of the parsed values in the same order. As an optimization, all + subscopes of the form STRING are left out of the returned tuple, instead + of returning a useless unit value. It is forbidden for the various + subscopes to refer to the global entry using self of next. + +A few other specific scopes exist to handle Ltac1-like syntax, but their use is +discouraged and they are thus not documented. + +For now there is no way to declare new scopes from Ltac2 side, but this is +planned. + +## Notations + +The Ltac2 parser can be extended by syntactic notations. +``` +VERNAC ::= +| "Ltac2" "Notation" TOKEN+ LEVEL? ":=" TERM + +LEVEL := ":" INT + +TOKEN := +| VAR "(" SCOPE ")" +| STRING +``` + +A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded +to the provided body where every token from the notation is let-bound to the +corresponding generated expression. + +For instance, assume we perform: +``` +Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. +``` +Then the following expression +``` +let y := @X in foo (nat -> nat) x $y +``` +will expand at parsing time to +``` +let y := @X in +let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids +``` + +Beware that the order of evaluation of multiple let-bindings is not specified, +so that you may have to resort to thunking to ensure that side-effects are +performed at the right time. + +## Abbreviations + +There exists a special kind of notations, called abbreviations, that is designed +so that it does not add any parsing rules. It is similar in spirit to Coq +abbreviations, insofar as its main purpose is to give an absolute name to a +piece of pure syntax, which can be transparently referred by this name as if it +were a proper definition. Abbreviations are introduced by the following +syntax. + +``` +VERNAC ::= +| "Ltac2" "Notation" IDENT ":=" TERM +``` + +The abbreviation can then be manipulated just as a normal Ltac2 definition, +except that it is expanded at internalization time into the given expression. +Furthermore, in order to make this kind of construction useful in practice in +an effectful language such as Ltac2, any syntactic argument to an abbreviation +is thunked on-the-fly during its expansion. + +For instance, suppose that we define the following. +``` +Ltac2 Notation foo := fun x => x (). +``` +Then we have the following expansion at internalization time. +``` +foo 0 ↦ (fun x => x ()) (fun _ => 0) +``` + +Note that abbreviations are not typechecked at all, and may result in typing +errors after expansion. + +# Evaluation + +Ltac2 features a toplevel loop that can be used to evaluate expressions. + +``` +VERNAC ::= +| "Ltac2" "Eval" TERM +``` + +This command evaluates the term in the current proof if there is one, or in the +global environment otherwise, and displays the resulting value to the user +together with its type. This function is pure in the sense that it does not +modify the state of the proof, and in particular all side-effects are discarded. + +# Debug + +When the option `Ltac2 Backtrace` is set, toplevel failures will be printed with +a backtrace. + +# Compatibility layer with Ltac1 + +## Ltac1 from Ltac2 + +### Simple API + +One can call Ltac1 code from Ltac2 by using the `ltac1` quotation. It parses +a Ltac1 expression, and semantics of this quotation is the evaluation of the +corresponding code for its side effects. In particular, in cannot return values, +and the quotation has type `unit`. + +Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited +to the use of standalone function calls. + +### Low-level API + +There exists a lower-level FFI into Ltac1 that is not recommended for daily use, +which is available in the `Ltac2.Ltac1` module. This API allows to directly +manipulate dynamically-typed Ltac1 values, either through the function calls, +or using the `ltac1val` quotation. The latter parses the same as `ltac1`, but +has type `Ltac2.Ltac1.t` instead of `unit`, and dynamically behaves as an Ltac1 +thunk, i.e. `ltac1val:(foo)` corresponds to the tactic closure that Ltac1 +would generate from `idtac; foo`. + +Due to intricate dynamic semantics, understanding when Ltac1 value quotations +focus is very hard. This is why some functions return a continuation-passing +style value, as it can dispatch dynamically between focused and unfocused +behaviour. + +## Ltac2 from Ltac1 + +Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation +instead. + +Note that the tactic expression is evaluated eagerly, if one wants to use it as +an argument to a Ltac1 function, she has to resort to the good old +`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately +and won't print anything. + +``` +Ltac mytac tac := idtac "wow"; tac. + +Goal True. +Proof. +mytac ltac2:(fail). +``` + +# Transition from Ltac1 + +Owing to the use of a bunch of notations, the transition shouldn't be +atrociously horrible and shockingly painful up to the point you want to retire +in the Ariège mountains, living off the land and insulting careless bypassers in +proto-georgian. + +That said, we do *not* guarantee you it is going to be a blissful walk either. +Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq +will help you. + +We list the major changes and the transition strategies hereafter. + +## Syntax changes + +Due to conflicts, a few syntactic rules have changed. + +- The dispatch tactical `tac; [foo|bar]` is now written `tac > [foo|bar]`. +- Levels of a few operators have been revised. Some tacticals now parse as if + they were a normal function, i.e. one has to put parentheses around the + argument when it is complex, e.g an abstraction. List of affected tacticals: + `try`, `repeat`, `do`, `once`, `progress`, `time`, `abstract`. +- `idtac` is no more. Either use `()` if you expect nothing to happen, + `(fun () => ())` if you want a thunk (see next section), or use printing + primitives from the `Message` module if you want to display something. + +## Tactic delay + +Tactics are not magically delayed anymore, neither as functions nor as +arguments. It is your responsibility to thunk them beforehand and apply them +at the call site. + +A typical example of a delayed function: +``` +Ltac foo := blah. +``` +becomes +``` +Ltac2 foo () := blah. +``` + +All subsequent calls to `foo` must be applied to perform the same effect as +before. + +Likewise, for arguments: +``` +Ltac bar tac := tac; tac; tac. +``` +becomes +``` +Ltac2 bar tac := tac (); tac (); tac (). +``` + +We recommend the use of syntactic notations to ease the transition. For +instance, the first example can alternatively written as: +``` +Ltac2 foo0 () := blah. +Ltac2 Notation foo := foo0 (). +``` + +This allows to keep the subsequent calls to the tactic as-is, as the +expression `foo` will be implicitly expanded everywhere into `foo0 ()`. Such +a trick also works for arguments, as arguments of syntactic notations are +implicitly thunked. The second example could thus be written as follows. + +``` +Ltac2 bar0 tac := tac (); tac (); tac (). +Ltac2 Notation bar := bar0. +``` + +## Variable binding + +Ltac1 relies on a crazy amount of dynamic trickery to be able to tell apart +bound variables from terms, hypotheses and whatnot. There is no such thing in +Ltac2, as variables are recognized statically and other constructions do not +live in the same syntactic world. Due to the abuse of quotations, it can +sometimes be complicated to know what a mere identifier represents in a tactic +expression. We recommend tracking the context and letting the compiler spit +typing errors to understand what is going on. + +We list below the typical changes one has to perform depending on the static +errors produced by the typechecker. + +### In Ltac expressions + +- `Unbound value X`, `Unbound constructor X`: + * if `X` is meant to be a term from the current stactic environment, replace + the problematic use by `'X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +### In quotations + +- `The reference X was not found in the current environment`: + * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, + replace the problematic use by `$X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +## Exception catching + +Ltac2 features a proper exception-catching mechanism. For this reason, the +Ltac1 mechanism relying on `fail` taking integers and tacticals decreasing it +has been removed. Now exceptions are preserved by all tacticals, and it is +your duty to catch it and reraise it depending on your use. + +# TODO + +- Implement deep pattern-matching. +- Craft an expressive set of primitive functions +- Implement native compilation to OCaml diff --git a/vendor/Ltac2/dune b/vendor/Ltac2/dune new file mode 100644 index 0000000000..5dbc4db66a --- /dev/null +++ b/vendor/Ltac2/dune @@ -0,0 +1,3 @@ +(env + (dev (flags :standard -rectypes)) + (release (flags :standard -rectypes))) diff --git a/vendor/Ltac2/dune-project b/vendor/Ltac2/dune-project new file mode 100644 index 0000000000..8154e999de --- /dev/null +++ b/vendor/Ltac2/dune-project @@ -0,0 +1,3 @@ +(lang dune 1.6) +(using coq 0.1) +(name ltac2) diff --git a/vendor/Ltac2/ltac2.opam b/vendor/Ltac2/ltac2.opam new file mode 100644 index 0000000000..47ceb882b1 --- /dev/null +++ b/vendor/Ltac2/ltac2.opam @@ -0,0 +1,18 @@ +synopsis: "A Tactic Language for Coq." +description: "A Tactic Language for Coq." +name: "coq-ltac2" +opam-version: "2.0" +maintainer: "Pierre-Marie Pédrot " +authors: "Pierre-Marie Pédrot " +homepage: "https://github.com/ppedrot/ltac2" +dev-repo: "https://github.com/ppedrot/ltac2.git" +bug-reports: "https://github.com/ppedrot/ltac2/issues" +license: "LGPL 2.1" +doc: "https://ppedrot.github.io/ltac2/doc" + +depends: [ + "coq" { = "dev" } + "dune" { build & >= "1.9.0" } +] + +build: [ "dune" "build" "-p" name "-j" jobs ] diff --git a/vendor/Ltac2/src/dune b/vendor/Ltac2/src/dune new file mode 100644 index 0000000000..332f3644b0 --- /dev/null +++ b/vendor/Ltac2/src/dune @@ -0,0 +1,11 @@ +(library + (name ltac2_plugin) + (public_name ltac2.plugin) + (modules_without_implementation tac2expr tac2qexpr tac2types) + (flags :standard -warn-error -9-27-50) + (libraries coq.plugins.firstorder)) + +(rule + (targets g_ltac2.ml) + (deps (:mlg-file g_ltac2.mlg)) + (action (run coqpp %{mlg-file}))) diff --git a/vendor/Ltac2/src/g_ltac2.mlg b/vendor/Ltac2/src/g_ltac2.mlg new file mode 100644 index 0000000000..0071dbb088 --- /dev/null +++ b/vendor/Ltac2/src/g_ltac2.mlg @@ -0,0 +1,933 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tok.t Stream.t -> int option + +let entry_of_lookahead s (lk : lookahead) = + let run strm = match lk 0 strm with None -> err () | Some _ -> () in + Pcoq.Entry.of_parser s run + +let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> None +| Some n -> lk2 n strm + +let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> lk2 n strm +| Some n -> Some n + +let lk_kw kw n strm = match stream_nth n strm with +| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None +| _ -> None + +let lk_ident n strm = match stream_nth n strm with +| IDENT _ -> Some (n + 1) +| _ -> None + +let lk_int n strm = match stream_nth n strm with +| NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) +| _ -> None + +let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) + +(* lookahead for (x:=t), (?x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + entry_of_lookahead "test_lpar_idnum_coloneq" begin + lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" + end + +(* lookahead for (x:t), (?x:t) *) +let test_lpar_id_colon = + entry_of_lookahead "test_lpar_id_colon" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" + end + +(* Hack to recognize "(x := t)" and "($x := t)" *) +let test_lpar_id_coloneq = + entry_of_lookahead "test_lpar_id_coloneq" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" + end + +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + entry_of_lookahead "test_lpar_id_rpar" begin + lk_kw "(" >> lk_ident >> lk_kw ")" + end + +let test_ampersand_ident = + entry_of_lookahead "test_ampersand_ident" begin + lk_kw "&" >> lk_ident + end + +let test_dollar_ident = + entry_of_lookahead "test_dollar_ident" begin + lk_kw "$" >> lk_ident + end + +let tac2expr = Tac2entries.Pltac.tac2expr +let tac2type = Entry.create "tactic:tac2type" +let tac2def_val = Entry.create "tactic:tac2def_val" +let tac2def_typ = Entry.create "tactic:tac2def_typ" +let tac2def_ext = Entry.create "tactic:tac2def_ext" +let tac2def_syn = Entry.create "tactic:tac2def_syn" +let tac2def_mut = Entry.create "tactic:tac2def_mut" +let tac2def_run = Entry.create "tactic:tac2def_run" +let tac2mode = Entry.create "vernac:ltac2_command" + +let ltac1_expr = Pltac.tactic_expr + +let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) +let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c +let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c +let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c +let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e +let inj_ltac1val loc e = inj_wit Tac2quote.wit_ltac1val loc e + +let pattern_of_qualid qid = + if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) + else + let open Libnames in + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) + else + CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") + +} + +GRAMMAR EXTEND Gram + GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + tac2def_mut tac2def_run; + tac2pat: + [ "1" LEFTA + [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { + if Tac2env.is_constructor qid then + CAst.make ~loc @@ CPatRef (RelId qid, pl) + else + CErrors.user_err ~loc (Pp.str "Syntax error") } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } + | p1 = tac2pat; "::"; p2 = tac2pat -> + { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])} + ] + | "0" + [ "_" -> { CAst.make ~loc @@ CPatVar Anonymous } + | "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "("; p = atomic_tac2pat; ")" -> { p } + ] ] + ; + atomic_tac2pat: + [ [ -> + { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | p = tac2pat; ":"; t = tac2type -> + { CAst.make ~loc @@ CPatCnv (p, t) } + | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> + { let pl = p :: pl in + CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) } + | p = tac2pat -> { p } + ] ] + ; + tac2expr: + [ "6" RIGHTA + [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] + | "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacFun (it, body) } + | "let"; isrec = rec_flag; + lc = LIST1 let_clause SEP "with"; "in"; + e = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacLet (isrec, lc, e) } + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> + { CAst.make ~loc @@ CTacCse (e, bl) } + ] + | "4" LEFTA [ ] + | "::" RIGHTA + [ e1 = tac2expr; "::"; e2 = tac2expr -> + { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } + ] + | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + { let el = e0 :: el in + CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] + | "1" LEFTA + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + { CAst.make ~loc @@ CTacApp (e, el) } + | e = SELF; ".("; qid = Prim.qualid; ")" -> + { CAst.make ~loc @@ CTacPrj (e, RelId qid) } + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] + | "0" + [ "("; a = SELF; ")" -> { a } + | "("; a = SELF; ":"; t = tac2type; ")" -> + { CAst.make ~loc @@ CTacCnv (a, t) } + | "()" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "("; ")" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + { Tac2quote.of_list ~loc (fun x -> x) a } + | "{"; a = tac2rec_fieldexprs; "}" -> + { CAst.make ~loc @@ CTacRec a } + | a = tactic_atom -> { a } ] + ] + ; + branches: + [ [ -> { [] } + | "|"; bl = LIST1 branch SEP "|" -> { bl } + | bl = LIST1 branch SEP "|" -> { bl } ] + ] + ; + branch: + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] + ; + rec_flag: + [ [ IDENT "rec" -> { true } + | -> { false } ] ] + ; + mut_flag: + [ [ IDENT "mutable" -> { true } + | -> { false } ] ] + ; + typ_param: + [ [ "'"; id = Prim.ident -> { id } ] ] + ; + tactic_atom: + [ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) } + | s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) } + | qid = Prim.qualid -> + { if Tac2env.is_constructor qid then + CAst.make ~loc @@ CTacCst (RelId qid) + else + CAst.make ~loc @@ CTacRef (RelId qid) } + | "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) } + | "&"; id = lident -> { Tac2quote.of_hyp ~loc id } + | "'"; c = Constr.constr -> { inj_open_constr loc c } + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } + | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } + | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } + | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } + | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } + | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1val loc qid } + ] ] + ; + let_clause: + [ [ binder = let_binder; ":="; te = tac2expr -> + { let (pat, fn) = binder in + let te = match fn with + | None -> te + | Some args -> CAst.make ~loc @@ CTacFun (args, te) + in + (pat, te) } + ] ] + ; + let_binder: + [ [ pats = LIST1 input_fun -> + { match pats with + | [{CAst.v=CPatVar _} as pat] -> (pat, None) + | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) + | [pat] -> (pat, None) + | _ -> CErrors.user_err ~loc (str "Invalid pattern") } + ] ] + ; + tac2type: + [ "5" RIGHTA + [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] + | "2" + [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + { let tl = t :: tl in + CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] + | "1" LEFTA + [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] + | "0" + [ "("; t = tac2type LEVEL "5"; ")" -> { t } + | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } + | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } + | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } + | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> + { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] + ]; + locident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + binder: + [ [ "_" -> { CAst.make ~loc Anonymous } + | l = Prim.ident -> { CAst.make ~loc (Name l) } ] ] + ; + input_fun: + [ [ b = tac2pat LEVEL "0" -> { b } ] ] + ; + tac2def_body: + [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in + (name, e) } + ] ] + ; + tac2def_val: + [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + { StrVal (mut, isrec, l) } + ] ] + ; + tac2def_mut: + [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] + ; + tac2def_run: + [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] + ; + tac2typ_knd: + [ [ t = tac2type -> { CTydDef (Some t) } + | "["; ".."; "]" -> { CTydOpn } + | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } + | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] + ; + tac2alg_constructors: + [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs } + | cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ] + ; + tac2alg_constructor: + [ [ c = Prim.ident -> { (c, []) } + | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] + ; + tac2rec_fields: + [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } + | f = tac2rec_field; ";" -> { [f] } + | f = tac2rec_field -> { [f] } + | -> { [] } ] ] + ; + tac2rec_field: + [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] + ; + tac2rec_fieldexprs: + [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } + | f = tac2rec_fieldexpr; ";" -> { [f] } + | f = tac2rec_fieldexpr-> { [f] } + | -> { [] } ] ] + ; + tac2rec_fieldexpr: + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] + ; + tac2typ_prm: + [ [ -> { [] } + | id = typ_param -> { [CAst.make ~loc id] } + | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } + ] ] + ; + tac2typ_def: + [ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ] + ; + tac2type_body: + [ [ -> { false, CTydDef None } + | ":="; e = tac2typ_knd -> { false, e } + | "::="; e = tac2typ_knd -> { true, e } + ] ] + ; + tac2def_typ: + [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> + { StrTyp (isrec, l) } + ] ] + ; + tac2def_ext: + [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + plugin = Prim.string; name = Prim.string -> + { let ml = { mltac_plugin = plugin; mltac_tactic = name } in + StrPrm (id, t, ml) } + ] ] + ; + syn_node: + [ [ "_" -> { CAst.make ~loc None } + | id = Prim.ident -> { CAst.make ~loc (Some id) } + ] ] + ; + sexpr: + [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } + | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } + | id = syn_node -> { SexprRec (loc, id, []) } + | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + { SexprRec (loc, id, tok) } + ] ] + ; + syn_level: + [ [ -> { None } + | ":"; n = Prim.integer -> { Some n } + ] ] + ; + tac2def_syn: + [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; + e = tac2expr -> + { StrSyn (toks, n, e) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + globref: + [ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) } + | qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid } + ] ] + ; +END + +(* Quotation scopes used by notations *) + +{ + +open Tac2entries.Pltac + +let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) + +} + +GRAMMAR EXTEND Gram + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause + q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag + q_destruction_arg q_reference q_with_bindings q_constr_matching + q_goal_matching q_hintdb q_move_location q_pose q_assert; + anti: + [ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ] + ; + ident_or_anti: + [ [ id = lident -> { QExpr id } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + lnatural: + [ [ n = Prim.natural -> { CAst.make ~loc n } ] ] + ; + q_ident: + [ [ id = ident_or_anti -> { id } ] ] + ; + qhyp: + [ [ x = anti -> { x } + | n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) } + | id = lident -> { QExpr (CAst.make ~loc @@ QNamedHyp id) } + ] ] + ; + simple_binding: + [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (h, c) } + ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + { CAst.make ~loc @@ QExplicitBindings bl } + | bl = LIST1 Constr.constr -> + { CAst.make ~loc @@ QImplicitBindings bl } + ] ] + ; + q_bindings: + [ [ bl = bindings -> { bl } ] ] + ; + q_with_bindings: + [ [ bl = with_bindings -> { bl } ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ] + ; +(* ne_intropatterns: *) +(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) +(* ; *) + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc } + | "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) } + | "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) } + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) } + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + { let rec pairify = function + | ([]|[_]|[_;_]) as l -> CAst.make ~loc l + | t::q -> + let q = + CAst.make ~loc @@ + QIntroAction (CAst.make ~loc @@ + QIntroOrAndPattern (CAst.make ~loc @@ + QIntroAndPattern (pairify q))) + in + CAst.make ~loc [t; q] + in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ] + ; + equality_intropattern: + [ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true } + | "<-" -> { CAst.make ~loc @@ QIntroRewrite false } + | "[="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ] + ; + naming_intropattern: + [ [ LEFTQMARK; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QExpr id) } + | "?$"; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QAnti id) } + | "?" -> + { CAst.make ~loc @@ QIntroAnonymous } + | id = ident_or_anti -> + { CAst.make ~loc @@ QIntroIdentifier id } + ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> { l } + | "*" -> { CAst.make ~loc @@ QIntroForthcoming true } + | "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed -> +(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) + (** TODO: handle %pat *) + { pat } + ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) } + | pat = equality_intropattern -> + { CAst.make ~loc @@ QIntroAction pat } + | "_" -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) } + | pat = naming_intropattern -> + { CAst.make ~loc @@ QIntroNaming pat } + ] ] + ; + q_intropatterns: + [ [ ipat = intropatterns -> { ipat } ] ] + ; + q_intropattern: + [ [ ipat = simple_intropattern -> { ipat } ] ] + ; + nat_or_anti: + [ [ n = lnatural -> { QExpr n } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat } + | -> { None } + ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ] + ; + constr_with_bindings: + [ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ] + ; + destruction_arg: + [ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n } + | id = lident -> { CAst.make ~loc @@ QElimOnIdent id } + | c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c } + ] ] + ; + q_destruction_arg: + [ [ arg = destruction_arg -> { arg } ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl } + | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> + { CAst.make ~loc @@ QAllOccurrencesBut (n::nl) } + ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ] + ; + hypident: + [ [ id = ident_or_anti -> + { id,Locus.InHyp } + | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypTypeOnly } + | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypValueOnly } + ] ] + ; + hypident_occ: + [ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + { { q_onhyps = None; q_concl_occs = occs } } + | "*"; "|-"; occs = concl_occ -> + { { q_onhyps = None; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> + { { q_onhyps = Some hl; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP "," -> + { { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } } + ] ] + ; + clause: + [ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl } + | "at"; occs = occs_nums -> + { CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } } + ] ] + ; + q_clause: + [ [ cl = clause -> { cl } ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> { occs } + | -> { CAst.make ~loc QNoOccurrences } + ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = OPT clause -> + { CAst.make ~loc @@ { + indcl_arg = c; + indcl_eqn = eq; + indcl_as = pat; + indcl_in = cl; + } } + ] ] + ; + q_induction_clause: + [ [ cl = induction_clause -> { cl } ] ] + ; + conversion: + [ [ c = Constr.constr -> + { CAst.make ~loc @@ QConvert c } + | c1 = Constr.constr; "with"; c2 = Constr.constr -> + { CAst.make ~loc @@ QConvertWith (c1, c2) } + ] ] + ; + q_conversion: + [ [ c = conversion -> { c } ] ] + ; + orient: + [ [ "->" -> { CAst.make ~loc (Some true) } + | "<-" -> { CAst.make ~loc (Some false) } + | -> { CAst.make ~loc None } + ]] + ; + rewriter: + [ [ "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatPlus,c) } + | [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatStar,c) } + | n = lnatural; "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QUpTo n,c) } + | n = lnatural; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) } + ] ] + ; + oriented_rewriter: + [ [ b = orient; r = rewriter -> + { let (m, c) = r in + CAst.make ~loc @@ { + rew_orient = b; + rew_repeat = m; + rew_equatn = c; + } } + ] ] + ; + q_rewriting: + [ [ r = oriented_rewriter -> { r } ] ] + ; + tactic_then_last: + [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } + | -> { [] } + ] ] + ; + tactic_then_gen: + [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } + | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (None, l)) } + | ta = tac2expr -> { ([Some ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } + | -> { ([None], None) } + ] ] + ; + q_dispatch: + [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] + ; + q_occurrences: + [ [ occs = occs -> { occs } ] ] + ; + red_flag: + [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } + | IDENT "iota" -> { CAst.make ~loc @@ QIota } + | IDENT "match" -> { CAst.make ~loc @@ QMatch } + | IDENT "fix" -> { CAst.make ~loc @@ QFix } + | IDENT "cofix" -> { CAst.make ~loc @@ QCofix } + | IDENT "zeta" -> { CAst.make ~loc @@ QZeta } + | IDENT "delta"; d = delta_flag -> { d } + ] ] + ; + refglobal: + [ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) } + | qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + q_reference: + [ [ r = refglobal -> { r } ] ] + ; + refglobals: + [ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ] + ; + delta_flag: + [ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl } + | "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl } + | -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) } + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flag -> { CAst.make ~loc s } + | d = delta_flag -> + { CAst.make ~loc + [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } + ] ] + ; + q_strategy_flag: + [ [ flag = strategy_flag -> { flag } ] ] + ; + hintdb: + [ [ "*" -> { CAst.make ~loc @@ QHintAll } + | l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l } + ] ] + ; + q_hintdb: + [ [ db = hintdb -> { db } ] ] + ; + match_pattern: + [ [ IDENT "context"; id = OPT Prim.ident; + "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } + | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_constr_matching: + [ [ m = match_list -> { m } ] ] + ; + gmatch_hyp_pattern: + [ [ na = Prim.name; ":"; pat = match_pattern -> { (na, pat) } ] ] + ; + gmatch_pattern: + [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> + { CAst.make ~loc @@ { + q_goal_match_concl = p; + q_goal_match_hyps = hl; + } } + ] ] + ; + gmatch_rule: + [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + gmatch_list: + [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_goal_matching: + [ [ m = gmatch_list -> { m } ] ] + ; + move_location: + [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } + | "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast } + | IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id } + | IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id } + ] ] + ; + q_move_location: + [ [ mv = move_location -> { mv } ] ] + ; + as_name: + [ [ -> { None } + | "as"; id = ident_or_anti -> { Some id } + ] ] + ; + pose: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (Some id, c) } + | c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) } + ] ] + ; + q_pose: + [ [ p = pose -> { p } ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + by_tactic: + [ [ "by"; tac = tac2expr -> { Some tac } + | -> { None } + ] ] + ; + assertion: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (QAssertValue (id, c)) } + | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> + { let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in + CAst.make ~loc (QAssertType (Some ipat, c, tac)) } + | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> + { CAst.make ~loc (QAssertType (ipat, c, tac)) } + ] ] + ; + q_assert: + [ [ a = assertion -> { a } ] ] + ; +END + +(** Extension of constr syntax *) + +(* +GRAMMAR EXTEND Gram + Pcoq.Constr.operconstr: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_ampersand_ident; "&"; id = Prim.ident -> + { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_dollar_ident; "$"; id = Prim.ident -> + { let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + ] ] + ; +END +*) +{ + +let () = + +let open Extend in +let open Tok in +let (++) r s = Next (r, s) in +let rules = [ + Rule ( + Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ + Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), + begin fun _ tac _ _ _ loc -> + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ) +] in + +Hook.set Tac2entries.register_constr_quotations begin fun () -> + Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) +end + +} + +{ + +let pr_ltac2entry _ = mt () (* FIXME *) +let pr_ltac2expr _ = mt () (* FIXME *) + +} + +VERNAC ARGUMENT EXTEND ltac2_entry +PRINTED BY { pr_ltac2entry } +| [ tac2def_val(v) ] -> { v } +| [ tac2def_typ(t) ] -> { t } +| [ tac2def_ext(e) ] -> { e } +| [ tac2def_syn(e) ] -> { e } +| [ tac2def_mut(e) ] -> { e } +| [ tac2def_run(e) ] -> { e } +END + +{ + +let classify_ltac2 = function +| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff + +} + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition +| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate + } +END + +{ + +let _ = Pvernac.register_proof_mode "Ltac2" tac2mode + +} + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY { pr_ltac2expr } +| [ tac2expr(e) ] -> { e } +END + +{ + +open G_ltac +open Vernacextend + +} + +VERNAC { tac2mode } EXTEND VernacLtac2 +| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => + { classify_as_proofstep } -> { +(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) + fun ~pstate -> + Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate + } +END + +{ + +open Stdarg + +} + +VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF +| [ "Print" "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac tac } +END diff --git a/vendor/Ltac2/src/ltac2_plugin.mlpack b/vendor/Ltac2/src/ltac2_plugin.mlpack new file mode 100644 index 0000000000..2a25e825cb --- /dev/null +++ b/vendor/Ltac2/src/ltac2_plugin.mlpack @@ -0,0 +1,14 @@ +Tac2dyn +Tac2ffi +Tac2env +Tac2print +Tac2intern +Tac2interp +Tac2entries +Tac2quote +Tac2match +Tac2core +Tac2extffi +Tac2tactics +Tac2stdlib +G_ltac2 diff --git a/vendor/Ltac2/src/tac2core.ml b/vendor/Ltac2/src/tac2core.ml new file mode 100644 index 0000000000..d7e7b91ee6 --- /dev/null +++ b/vendor/Ltac2/src/tac2core.ml @@ -0,0 +1,1446 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Value.of_option Value.of_ident None +| Name id -> Value.of_option Value.of_ident (Some id) + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let of_relevance = function + | Sorts.Relevant -> ValInt 0 + | Sorts.Irrelevant -> ValInt 1 + +let to_relevance = function + | ValInt 0 -> Sorts.Relevant + | ValInt 1 -> Sorts.Irrelevant + | _ -> assert false + +let of_annot f Context.{binder_name;binder_relevance} = + of_tuple [|(f binder_name); of_relevance binder_relevance|] + +let to_annot f x = + match to_tuple x with + | [|x;y|] -> + let x = f x in + let y = to_relevance y in + Context.make_annot x y + | _ -> assert false + +let of_instance u = + let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in + Value.of_array (fun v -> Value.of_ext Value.val_univ v) u + +let to_instance u = + let u = Value.to_array (fun v -> Value.to_ext Value.val_univ v) u in + EConstr.EInstance.make (Univ.Instance.of_array u) + +let of_rec_declaration (nas, ts, cs) = + (Value.of_array (of_annot of_name) nas, + Value.of_array Value.of_constr ts, + Value.of_array Value.of_constr cs) + +let to_rec_declaration (nas, ts, cs) = + (Value.to_array (to_annot to_name) nas, + Value.to_array Value.to_constr ts, + Value.to_array Value.to_constr cs) + +let of_result f = function +| Inl c -> v_blk 0 [|f c|] +| Inr e -> v_blk 1 [|Value.of_exn e|] + +(** Stdlib exceptions *) + +let err_notfocussed = + Tac2interp.LtacError (coq_core "Not_focussed", [||]) + +let err_outofbounds = + Tac2interp.LtacError (coq_core "Out_of_bounds", [||]) + +let err_notfound = + Tac2interp.LtacError (coq_core "Not_found", [||]) + +let err_matchfailure = + Tac2interp.LtacError (coq_core "Match_failure", [||]) + +(** Helper functions *) + +let thaw f = Tac2ffi.apply f [v_unit] + +let fatal_flag : unit Exninfo.t = Exninfo.make () + +let set_bt info = + if !Tac2interp.print_ltac2_backtrace then + Tac2interp.get_backtrace >>= fun bt -> + Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) + else Proofview.tclUNIT info + +let throw ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + let info = Exninfo.add info fatal_flag () in + Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) + +let fail ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + Proofview.tclZERO ~info e + +let return x = Proofview.tclUNIT x +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let wrap f = + return () >>= fun () -> return (f ()) + +let wrap_unit f = + return () >>= fun () -> f (); return v_unit + +let assert_focussed = + Proofview.Goal.goals >>= fun gls -> + match gls with + | [_] -> Proofview.tclUNIT () + | [] | _ :: _ :: _ -> throw err_notfocussed + +let pf_apply f = + Proofview.Goal.goals >>= function + | [] -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + f env sigma + | [gl] -> + gl >>= fun gl -> + f (Proofview.Goal.env gl) (Tacmach.New.project gl) + | _ :: _ :: _ -> + throw err_notfocussed + +(** Primitives *) + +let define_primitive name arity f = + Tac2env.define_primitive (pname name) (mk_closure arity f) + +let define0 name f = define_primitive name arity_one (fun _ -> f) + +let define1 name r0 f = define_primitive name arity_one begin fun x -> + f (Value.repr_to r0 x) +end + +let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> + f (Value.repr_to r0 x) (Value.repr_to r1 y) +end + +let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> + f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) +end + +(** Printing *) + +let () = define1 "print" pp begin fun pp -> + wrap_unit (fun () -> Feedback.msg_notice pp) +end + +let () = define1 "message_of_int" int begin fun n -> + return (Value.of_pp (Pp.int n)) +end + +let () = define1 "message_of_string" string begin fun s -> + return (Value.of_pp (str (Bytes.to_string s))) +end + +let () = define1 "message_of_constr" constr begin fun c -> + pf_apply begin fun env sigma -> + let pp = Printer.pr_econstr_env env sigma c in + return (Value.of_pp pp) + end +end + +let () = define1 "message_of_ident" ident begin fun c -> + let pp = Id.print c in + return (Value.of_pp pp) +end + +let () = define1 "message_of_exn" valexpr begin fun v -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let pp = Tac2print.pr_valexpr env sigma v (GTypRef (Other Core.t_exn, [])) in + return (Value.of_pp pp) +end + + +let () = define2 "message_concat" pp pp begin fun m1 m2 -> + return (Value.of_pp (Pp.app m1 m2)) +end + +(** Array *) + +let () = define2 "array_make" int valexpr begin fun n x -> + if n < 0 || n > Sys.max_array_length then throw err_outofbounds + else wrap (fun () -> v_blk 0 (Array.make n x)) +end + +let () = define1 "array_length" block begin fun (_, v) -> + return (Value.of_int (Array.length v)) +end + +let () = define3 "array_set" block int valexpr begin fun (_, v) n x -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap_unit (fun () -> v.(n) <- x) +end + +let () = define2 "array_get" block int begin fun (_, v) n -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap (fun () -> v.(n)) +end + +(** Ident *) + +let () = define2 "ident_equal" ident ident begin fun id1 id2 -> + return (Value.of_bool (Id.equal id1 id2)) +end + +let () = define1 "ident_to_string" ident begin fun id -> + return (Value.of_string (Bytes.of_string (Id.to_string id))) +end + +let () = define1 "ident_of_string" string begin fun s -> + let id = try Some (Id.of_string (Bytes.to_string s)) with _ -> None in + return (Value.of_option Value.of_ident id) +end + +(** Int *) + +let () = define2 "int_equal" int int begin fun m n -> + return (Value.of_bool (m == n)) +end + +let binop n f = define2 n int int begin fun m n -> + return (Value.of_int (f m n)) +end + +let () = binop "int_compare" Int.compare +let () = binop "int_add" (+) +let () = binop "int_sub" (-) +let () = binop "int_mul" ( * ) + +let () = define1 "int_neg" int begin fun m -> + return (Value.of_int (~- m)) +end + +(** Char *) + +let () = define1 "char_of_int" int begin fun n -> + wrap (fun () -> Value.of_char (Char.chr n)) +end + +let () = define1 "char_to_int" char begin fun n -> + wrap (fun () -> Value.of_int (Char.code n)) +end + +(** String *) + +let () = define2 "string_make" int char begin fun n c -> + if n < 0 || n > Sys.max_string_length then throw err_outofbounds + else wrap (fun () -> Value.of_string (Bytes.make n c)) +end + +let () = define1 "string_length" string begin fun s -> + return (Value.of_int (Bytes.length s)) +end + +let () = define3 "string_set" string int char begin fun s n c -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap_unit (fun () -> Bytes.set s n c) +end + +let () = define2 "string_get" string int begin fun s n -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap (fun () -> Value.of_char (Bytes.get s n)) +end + +(** Terms *) + +(** constr -> constr *) +let () = define1 "constr_type" constr begin fun c -> + let get_type env sigma = + Proofview.V82.wrap_exceptions begin fun () -> + let (sigma, t) = Typing.type_of env sigma c in + let t = Value.of_constr t in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t + end in + pf_apply get_type +end + +(** constr -> constr *) +let () = define2 "constr_equal" constr constr begin fun c1 c2 -> + Proofview.tclEVARMAP >>= fun sigma -> + let b = EConstr.eq_constr sigma c1 c2 in + Proofview.tclUNIT (Value.of_bool b) +end + +let () = define1 "constr_kind" constr begin fun c -> + let open Constr in + Proofview.tclEVARMAP >>= fun sigma -> + return begin match EConstr.kind sigma c with + | Rel n -> + v_blk 0 [|Value.of_int n|] + | Var id -> + v_blk 1 [|Value.of_ident id|] + | Meta n -> + v_blk 2 [|Value.of_int n|] + | Evar (evk, args) -> + v_blk 3 [| + Value.of_int (Evar.repr evk); + Value.of_array Value.of_constr args; + |] + | Sort s -> + v_blk 4 [|Value.of_ext Value.val_sort s|] + | Cast (c, k, t) -> + v_blk 5 [| + Value.of_constr c; + Value.of_ext Value.val_cast k; + Value.of_constr t; + |] + | Prod (na, t, u) -> + v_blk 6 [| + of_annot of_name na; + Value.of_constr t; + Value.of_constr u; + |] + | Lambda (na, t, c) -> + v_blk 7 [| + of_annot of_name na; + Value.of_constr t; + Value.of_constr c; + |] + | LetIn (na, b, t, c) -> + v_blk 8 [| + of_annot of_name na; + Value.of_constr b; + Value.of_constr t; + Value.of_constr c; + |] + | App (c, cl) -> + v_blk 9 [| + Value.of_constr c; + Value.of_array Value.of_constr cl; + |] + | Const (cst, u) -> + v_blk 10 [| + Value.of_constant cst; + of_instance u; + |] + | Ind (ind, u) -> + v_blk 11 [| + Value.of_ext Value.val_inductive ind; + of_instance u; + |] + | Construct (cstr, u) -> + v_blk 12 [| + Value.of_ext Value.val_constructor cstr; + of_instance u; + |] + | Case (ci, c, t, bl) -> + v_blk 13 [| + Value.of_ext Value.val_case ci; + Value.of_constr c; + Value.of_constr t; + Value.of_array Value.of_constr bl; + |] + | Fix ((recs, i), def) -> + let (nas, ts, cs) = of_rec_declaration def in + v_blk 14 [| + Value.of_array Value.of_int recs; + Value.of_int i; + nas; + ts; + cs; + |] + | CoFix (i, def) -> + let (nas, ts, cs) = of_rec_declaration def in + v_blk 15 [| + Value.of_int i; + nas; + ts; + cs; + |] + | Proj (p, c) -> + v_blk 16 [| + Value.of_ext Value.val_projection p; + Value.of_constr c; + |] + | Int _ -> + assert false + end +end + +let () = define1 "constr_make" valexpr begin fun knd -> + let c = match Tac2ffi.to_block knd with + | (0, [|n|]) -> + let n = Value.to_int n in + EConstr.mkRel n + | (1, [|id|]) -> + let id = Value.to_ident id in + EConstr.mkVar id + | (2, [|n|]) -> + let n = Value.to_int n in + EConstr.mkMeta n + | (3, [|evk; args|]) -> + let evk = Evar.unsafe_of_int (Value.to_int evk) in + let args = Value.to_array Value.to_constr args in + EConstr.mkEvar (evk, args) + | (4, [|s|]) -> + let s = Value.to_ext Value.val_sort s in + EConstr.mkSort (EConstr.Unsafe.to_sorts s) + | (5, [|c; k; t|]) -> + let c = Value.to_constr c in + let k = Value.to_ext Value.val_cast k in + let t = Value.to_constr t in + EConstr.mkCast (c, k, t) + | (6, [|na; t; u|]) -> + let na = to_annot to_name na in + let t = Value.to_constr t in + let u = Value.to_constr u in + EConstr.mkProd (na, t, u) + | (7, [|na; t; c|]) -> + let na = to_annot to_name na in + let t = Value.to_constr t in + let u = Value.to_constr c in + EConstr.mkLambda (na, t, u) + | (8, [|na; b; t; c|]) -> + let na = to_annot to_name na in + let b = Value.to_constr b in + let t = Value.to_constr t in + let c = Value.to_constr c in + EConstr.mkLetIn (na, b, t, c) + | (9, [|c; cl|]) -> + let c = Value.to_constr c in + let cl = Value.to_array Value.to_constr cl in + EConstr.mkApp (c, cl) + | (10, [|cst; u|]) -> + let cst = Value.to_constant cst in + let u = to_instance u in + EConstr.mkConstU (cst, u) + | (11, [|ind; u|]) -> + let ind = Value.to_ext Value.val_inductive ind in + let u = to_instance u in + EConstr.mkIndU (ind, u) + | (12, [|cstr; u|]) -> + let cstr = Value.to_ext Value.val_constructor cstr in + let u = to_instance u in + EConstr.mkConstructU (cstr, u) + | (13, [|ci; c; t; bl|]) -> + let ci = Value.to_ext Value.val_case ci in + let c = Value.to_constr c in + let t = Value.to_constr t in + let bl = Value.to_array Value.to_constr bl in + EConstr.mkCase (ci, c, t, bl) + | (14, [|recs; i; nas; ts; cs|]) -> + let recs = Value.to_array Value.to_int recs in + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkFix ((recs, i), def) + | (15, [|i; nas; ts; cs|]) -> + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkCoFix (i, def) + | (16, [|p; c|]) -> + let p = Value.to_ext Value.val_projection p in + let c = Value.to_constr c in + EConstr.mkProj (p, c) + | _ -> assert false + in + return (Value.of_constr c) +end + +let () = define1 "constr_check" constr begin fun c -> + pf_apply begin fun env sigma -> + try + let (sigma, _) = Typing.type_of env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (of_result Value.of_constr (Inl c)) + with e when CErrors.noncritical e -> + let e = CErrors.push e in + return (of_result Value.of_constr (Inr e)) + end +end + +let () = define3 "constr_substnl" (list constr) int constr begin fun subst k c -> + let ans = EConstr.Vars.substnl subst k c in + return (Value.of_constr ans) +end + +let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> + let ans = EConstr.Vars.substn_vars k ids c in + return (Value.of_constr ans) +end + +let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + try + let ans = Inductiveops.make_case_info env ind Sorts.Relevant Constr.RegularStyle in + return (Value.of_ext Value.val_case ans) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define2 "constr_constructor" (repr_ext val_inductive) int begin fun (ind, i) k -> + Proofview.tclENV >>= fun env -> + try + let open Declarations in + let ans = Environ.lookup_mind ind env in + let _ = ans.mind_packets.(i).mind_consnames.(k) in + return (Value.of_ext val_constructor ((ind, i), (k + 1))) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define3 "constr_in_context" ident constr closure begin fun id t c -> + Proofview.Goal.goals >>= function + | [gl] -> + gl >>= fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let has_var = + try + let _ = Environ.lookup_named_val id env in + true + with Not_found -> false + in + if has_var then + Tacticals.New.tclZEROMSG (str "Variable already exists") + else + let open Context.Named.Declaration in + let nenv = EConstr.push_named (LocalAssum (Context.make_annot id Sorts.Relevant, t)) env in + let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in + let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> + thaw c >>= fun _ -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> + let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in + let args = Array.of_list (EConstr.mkRel 1 :: args) in + let ans = EConstr.mkEvar (evk, args) in + let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in + return (Value.of_constr ans) + | _ -> + throw err_notfocussed +end + +(** Patterns *) + +let empty_context = EConstr.mkMeta Constr_matching.special_meta + +let () = define0 "pattern_empty_context" begin + return (Value.of_constr empty_context) +end + +let () = define2 "pattern_matches" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> fail err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + return (Value.of_list of_pair ans) + end + end +end + +let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> fail err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_list of_pair ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in + of_ans ans + end +end + +let () = define2 "pattern_matches_vect" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> fail err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let ans = Array.map_of_list snd ans in + return (Value.of_array Value.of_constr ans) + end + end +end + +let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c -> + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> fail err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let ans = Array.map_of_list snd ans in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_array Value.of_constr ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in + of_ans ans + end +end + +let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bool pattern) begin fun rev hp cp -> + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let mk_pattern (b, pat) = if b then Tac2match.MatchPattern pat else Tac2match.MatchContext pat in + let r = (List.map mk_pattern hp, mk_pattern cp) in + Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> + let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in + let hids = Value.of_array Value.of_ident (Array.map_of_list fst hyps) in + let hctx = Value.of_array of_ctxopt (Array.map_of_list snd hyps) in + let subs = Value.of_array Value.of_constr (Array.map_of_list snd (Id.Map.bindings subst)) in + let cctx = of_ctxopt ctx in + let ans = Value.of_tuple [| hids; hctx; subs; cctx |] in + Proofview.tclUNIT ans + end +end + +let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> + let ctx = EConstr.Unsafe.to_constr ctx in + let c = EConstr.Unsafe.to_constr c in + let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in + return (Value.of_constr (EConstr.of_constr ans)) +end + +(** Error *) + +let () = define1 "throw" exn begin fun (e, info) -> + throw ~info e +end + +(** Control *) + +(** exn -> 'a *) +let () = define1 "zero" exn begin fun (e, info) -> + fail ~info e +end + +(** (unit -> 'a) -> (exn -> 'a) -> 'a *) +let () = define2 "plus" closure closure begin fun x k -> + Proofview.tclOR (thaw x) (fun e -> Tac2ffi.apply k [Value.of_exn e]) +end + +(** (unit -> 'a) -> 'a *) +let () = define1 "once" closure begin fun f -> + Proofview.tclONCE (thaw f) +end + +(** (unit -> unit) list -> unit *) +let () = define1 "dispatch" (list closure) begin fun l -> + let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in + Proofview.tclDISPATCH l >>= fun () -> return v_unit +end + +(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) +let () = define3 "extend" (list closure) closure (list closure) begin fun lft tac rgt -> + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let tac = Proofview.tclIGNORE (thaw tac) in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in + Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit +end + +(** (unit -> unit) -> unit *) +let () = define1 "enter" closure begin fun f -> + let f = Proofview.tclIGNORE (thaw f) in + Proofview.tclINDEPENDENT f >>= fun () -> return v_unit +end + +(** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) +let () = define1 "case" closure begin fun f -> + Proofview.tclCASE (thaw f) >>= begin function + | Proofview.Next (x, k) -> + let k = Tac2ffi.mk_closure arity_one begin fun e -> + let (e, info) = Value.to_exn e in + set_bt info >>= fun info -> + k (e, info) + end in + return (v_blk 0 [| Value.of_tuple [| x; Value.of_closure k |] |]) + | Proofview.Fail e -> return (v_blk 1 [| Value.of_exn e |]) + end +end + +(** int -> int -> (unit -> 'a) -> 'a *) +let () = define3 "focus" int int closure begin fun i j tac -> + Proofview.tclFOCUS i j (thaw tac) +end + +(** unit -> unit *) +let () = define0 "shelve" begin + Proofview.shelve >>= fun () -> return v_unit +end + +(** unit -> unit *) +let () = define0 "shelve_unifiable" begin + Proofview.shelve_unifiable >>= fun () -> return v_unit +end + +let () = define1 "new_goal" int begin fun ev -> + let ev = Evar.unsafe_of_int ev in + Proofview.tclEVARMAP >>= fun sigma -> + if Evd.mem sigma ev then + Proofview.Unsafe.tclNEWGOALS [Proofview.with_empty_state ev] <*> Proofview.tclUNIT v_unit + else throw err_notfound +end + +(** unit -> constr *) +let () = define0 "goal" begin + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + return (Value.of_constr concl) + end +end + +(** ident -> constr *) +let () = define1 "hyp" ident begin fun id -> + pf_apply begin fun env _ -> + let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in + if mem then return (Value.of_constr (EConstr.mkVar id)) + else Tacticals.New.tclZEROMSG + (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (* FIXME: Do something more sensible *) + end +end + +let () = define0 "hyps" begin + pf_apply begin fun env _ -> + let open Context in + let open Named.Declaration in + let hyps = List.rev (Environ.named_context env) in + let map = function + | LocalAssum (id, t) -> + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr None; Value.of_constr t|] + | LocalDef (id, c, t) -> + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr (Some c); Value.of_constr t|] + in + return (Value.of_list map hyps) + end +end + +(** (unit -> constr) -> unit *) +let () = define1 "refine" closure begin fun c -> + let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in + Proofview.Goal.enter begin fun gl -> + Refine.generic_refine ~typecheck:true c gl + end >>= fun () -> return v_unit +end + +let () = define2 "with_holes" closure closure begin fun x f -> + Proofview.tclEVARMAP >>= fun sigma0 -> + thaw x >>= fun ans -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> + Tacticals.New.tclWITHHOLES false (Tac2ffi.apply f [ans]) sigma +end + +let () = define1 "progress" closure begin fun f -> + Proofview.tclPROGRESS (thaw f) +end + +let () = define2 "abstract" (option ident) closure begin fun id f -> + Abstract.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> + return v_unit +end + +let () = define2 "time" (option string) closure begin fun s f -> + let s = Option.map Bytes.to_string s in + Proofview.tclTIME s (thaw f) +end + +let () = define0 "check_interrupt" begin + Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit +end + +(** Fresh *) + +let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun set1 set2 -> + let ans = Id.Set.union set1 set2 in + return (Value.of_ext Value.val_free ans) +end + +let () = define1 "fresh_free_of_ids" (list ident) begin fun ids -> + let free = List.fold_right Id.Set.add ids Id.Set.empty in + return (Value.of_ext Value.val_free free) +end + +let () = define1 "fresh_free_of_constr" constr begin fun c -> + Proofview.tclEVARMAP >>= fun sigma -> + let rec fold accu c = match EConstr.kind sigma c with + | Constr.Var id -> Id.Set.add id accu + | _ -> EConstr.fold sigma fold accu c + in + let ans = fold Id.Set.empty c in + return (Value.of_ext Value.val_free ans) +end + +let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> + let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in + return (Value.of_ident nid) +end + +(** Env *) + +let () = define1 "env_get" (list ident) begin fun ids -> + let r = match ids with + | [] -> None + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + try Some (Nametab.global_of_path fp) with Not_found -> None + in + return (Value.of_option Value.of_reference r) +end + +let () = define1 "env_expand" (list ident) begin fun ids -> + let r = match ids with + | [] -> [] + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let qid = Libnames.make_qualid path id in + Nametab.locate_all qid + in + return (Value.of_list Value.of_reference r) +end + +let () = define1 "env_path" reference begin fun r -> + match Nametab.path_of_global r with + | fp -> + let (path, id) = Libnames.repr_path fp in + let path = DirPath.repr path in + return (Value.of_list Value.of_ident (List.rev_append path [id])) + | exception Not_found -> + throw err_notfound +end + +let () = define1 "env_instantiate" reference begin fun r -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let (sigma, c) = Evd.fresh_global env sigma r in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (Value.of_constr c) +end + +(** Ltac1 in Ltac2 *) + +let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 +let of_ltac1 v = Value.of_ext Value.val_ltac1 v + +let () = define1 "ltac1_ref" (list ident) begin fun ids -> + let open Ltac_plugin in + let r = match ids with + | [] -> raise Not_found + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + if Tacenv.exists_tactic fp then + List.hd (Tacenv.locate_extended_all_tactic (Libnames.qualid_of_path fp)) + else raise Not_found + in + let tac = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) (Tacenv.interp_ltac r) in + return (Value.of_ext val_ltac1 tac) +end + +let () = define1 "ltac1_run" ltac1 begin fun v -> + let open Ltac_plugin in + Tacinterp.tactic_of_value (Tacinterp.default_ist ()) v >>= fun () -> + return v_unit +end + +let () = define3 "ltac1_apply" ltac1 (list ltac1) closure begin fun f args k -> + let open Ltac_plugin in + let open Tacexpr in + let open Locus in + let k ret = + Proofview.tclIGNORE (Tac2ffi.apply k [Value.of_ext val_ltac1 ret]) + in + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + Tacinterp.val_interp ist tac k >>= fun () -> + return v_unit +end + +let () = define1 "ltac1_of_constr" constr begin fun c -> + let open Ltac_plugin in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_constr c)) +end + +let () = define1 "ltac1_to_constr" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) +end + +let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> + let open Geninterp.Val in + return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) +end + +let () = define1 "ltac1_to_list" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option (Value.of_list of_ltac1) (Tacinterp.Value.to_list v)) +end + +(** ML types *) + +let constr_flags () = + let open Pretyping in + { + use_typeclasses = true; + solve_unification_constraints = true; + fail_evar = true; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +let open_constr_no_classes_flags () = + let open Pretyping in + { + use_typeclasses = false; + solve_unification_constraints = true; + fail_evar = false; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +(** Embed all Ltac2 data into Values *) +let to_lvar ist = + let open Glob_ops in + let lfun = Tac2interp.set_env ist Id.Map.empty in + { empty_lvar with Ltac_pretype.ltac_genargs = lfun } + +let gtypref kn = GTypRef (Other kn, []) + +let intern_constr self ist c = + let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in + (GlbVal c, gtypref t_constr) + +let catchable_exception = function + | Logic_monad.Exception _ -> false + | e -> CErrors.noncritical e + +let interp_constr flags ist c = + let open Pretyping in + let ist = to_lvar ist in + pf_apply begin fun env sigma -> + try + let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in + let c = Value.of_constr c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT c + with e when catchable_exception e -> + let (e, info) = CErrors.push e in + set_bt info >>= fun info -> + match Exninfo.get info fatal_flag with + | None -> Proofview.tclZERO ~info e + | Some () -> throw ~info e + end + +let () = + let intern = intern_constr in + let interp ist c = interp_constr (constr_flags ()) ist c in + let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_constr obj + +let () = + let intern = intern_constr in + let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_open_constr obj + +let () = + let interp _ id = return (Value.of_ident id) in + let print _ id = str "ident:(" ++ Id.print id ++ str ")" in + let obj = { + ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); + ml_interp = interp; + ml_subst = (fun _ id -> id); + ml_print = print; + } in + define_ml_object Tac2quote.wit_ident obj + +let () = + let intern self ist c = + let env = ist.Genintern.genv in + let sigma = Evd.from_env env in + let warn = if !Ltac_plugin.Tacintern.strict_check then fun x -> x else Constrintern.for_grammar in + let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in + GlbVal pat, gtypref t_pattern + in + let subst subst c = + let env = Global.env () in + let sigma = Evd.from_env env in + Patternops.subst_pattern env sigma subst c + in + let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in + let interp _ c = return (Value.of_pattern c) in + let obj = { + ml_intern = intern; + ml_interp = interp; + ml_subst = subst; + ml_print = print; + } in + define_ml_object Tac2quote.wit_pattern obj + +let () = + let intern self ist ref = match ref.CAst.v with + | Tac2qexpr.QHypothesis id -> + GlbVal (Globnames.VarRef id), gtypref t_reference + | Tac2qexpr.QReference qid -> + let gr = + try Nametab.locate qid + with Not_found -> + Nametab.error_global_not_found qid + in + GlbVal gr, gtypref t_reference + in + let subst s c = Globnames.subst_global_reference s c in + let interp _ gr = return (Value.of_reference gr) in + let print _ = function + | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" + | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_reference obj + +let () = + let intern self ist tac = + (* Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_unit + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + let tac = (Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in + let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in + Proofview.tclOR tac wrap >>= fun () -> + return v_unit + in + let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1 obj + +let () = + let open Ltac_plugin in + let intern self ist tac = + (* Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_ltac1 + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_closure ist tac)) + in + let subst s tac = Genintern.substitute Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1val:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1val obj + +(** Ltac2 in terms *) + +let () = + let interp ist poly env sigma concl tac = + let ist = Tac2interp.get_env ist in + let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in + let name, poly = Id.of_string "ltac2", poly in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in + (EConstr.of_constr c, sigma) + in + GlobEnv.register_constr_interp0 wit_ltac2 interp + +let () = + let interp ist poly env sigma concl id = + let ist = Tac2interp.get_env ist in + let c = Id.Map.find id ist.env_ist in + let c = Value.to_constr c in + let sigma = Typing.check env sigma c concl in + (c, sigma) + in + GlobEnv.register_constr_interp0 wit_ltac2_quotation interp + +let () = + let pr_raw id = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb id = Genprint.PrinterBasic (fun _env _sigma -> str "$" ++ Id.print id) in + let pr_top _ = Genprint.TopPrinterBasic mt in + Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top + +(** Ltac2 in Ltac1 *) + +let () = + let e = Tac2entries.Pltac.tac2expr in + let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in + Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) + +let () = + let open Ltac_plugin in + let open Tacinterp in + let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in + let interp ist tac = +(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) + let ist = { env_ist = Id.Map.empty } in + Tac2interp.interp ist tac >>= fun _ -> + Ftactic.return idtac + in + Geninterp.register_interp0 wit_ltac2 interp + +let () = + let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in + let pr_top _ = Genprint.TopPrinterBasic mt in + Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top + +(** Built-in notation scopes *) + +let add_scope s f = + Tac2entries.register_scope (Id.of_string s) f + +let rec pr_scope = let open CAst in function +| SexprStr {v=s} -> qstring s +| SexprInt {v=n} -> Pp.int n +| SexprRec (_, {v=na}, args) -> + let na = match na with + | None -> str "_" + | Some id -> Id.print id + in + na ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" + +let scope_fail s args = + let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in + CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) + +let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) + +let add_generic_scope s entry arg = + let parse = function + | [] -> + let scope = Extend.Aentry entry in + let act x = CAst.make @@ CTacExt (arg, x) in + Tac2entries.ScopeRule (scope, act) + | arg -> scope_fail s arg + in + add_scope s parse + +open CAst + +let () = add_scope "keyword" begin function +| [SexprStr {loc;v=s}] -> + let scope = Extend.Atoken (Tok.PKEYWORD s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| arg -> scope_fail "keyword" arg +end + +let () = add_scope "terminal" begin function +| [SexprStr {loc;v=s}] -> + let scope = Extend.Atoken (CLexer.terminal s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| arg -> scope_fail "terminal" arg +end + +let () = add_scope "list0" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist0 scope in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr {v=str}] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist0sep (scope, sep) in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "list0" arg +end + +let () = add_scope "list1" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist1 scope in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr {v=str}] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist1sep (scope, sep) in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "list1" arg +end + +let () = add_scope "opt" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Aopt scope in + let act opt = match opt with + | None -> + CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) + | Some x -> + CAst.make @@ CTacApp (CAst.make @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) + in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "opt" arg +end + +let () = add_scope "self" begin function +| [] -> + let scope = Extend.Aself in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "self" arg +end + +let () = add_scope "next" begin function +| [] -> + let scope = Extend.Anext in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "next" arg +end + +let () = add_scope "tactic" begin function +| [] -> + (* Default to level 5 parsing *) + let scope = Extend.Aentryl (tac2expr, "5") in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| [SexprInt {loc;v=n}] as arg -> + let () = if n < 0 || n > 6 then scope_fail "tactic" arg in + let scope = Extend.Aentryl (tac2expr, string_of_int n) in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "tactic" arg +end + +let () = add_scope "thunk" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let act e = Tac2quote.thunk (act e) in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "thunk" arg +end + +let add_expr_scope name entry f = + add_scope name begin function + | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) + | arg -> scope_fail name arg + end + +let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) +let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings +let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings +let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern +let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns +let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg +let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause +let () = add_expr_scope "conversion" q_conversion Tac2quote.of_conversion +let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting +let () = add_expr_scope "clause" q_clause Tac2quote.of_clause +let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb +let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences +let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch +let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag +let () = add_expr_scope "reference" q_reference Tac2quote.of_reference +let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location +let () = add_expr_scope "pose" q_pose Tac2quote.of_pose +let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion +let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching +let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching + +let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr +let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr +let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern + +(** seq scope, a bit hairy *) + +open Extend +exception SelfSymbol + +let rec generalize_symbol : + type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function +| Atoken tok -> Atoken tok +| Alist1 e -> Alist1 (generalize_symbol e) +| Alist1sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Alist1sep (e, sep) +| Alist0 e -> Alist0 (generalize_symbol e) +| Alist0sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Alist0sep (e, sep) +| Aopt e -> Aopt (generalize_symbol e) +| Aself -> raise SelfSymbol +| Anext -> raise SelfSymbol +| Aentry e -> Aentry e +| Aentryl (e, l) -> Aentryl (e, l) +| Arules r -> Arules r + +type _ converter = +| CvNil : (Loc.t -> raw_tacexpr) converter +| CvCns : 'act converter * ('a -> raw_tacexpr) option -> ('a -> 'act) converter + +let rec apply : type a. a converter -> raw_tacexpr list -> a = function +| CvNil -> fun accu loc -> Tac2quote.of_tuple ~loc accu +| CvCns (c, None) -> fun accu x -> apply c accu +| CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) + +type seqrule = +| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule + +let rec make_seq_rule = function +| [] -> + Seqrule (Stop, CvNil) +| tok :: rem -> + let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in + let scope = generalize_symbol scope in + let Seqrule (r, c) = make_seq_rule rem in + let r = NextNoRec (r, scope) in + let f = match tok with + | SexprStr _ -> None (* Leave out mere strings *) + | _ -> Some f + in + Seqrule (r, CvCns (c, f)) + +let () = add_scope "seq" begin fun toks -> + let scope = + try + let Seqrule (r, c) = make_seq_rule (List.rev toks) in + Arules [Rules (r, apply c [])] + with SelfSymbol -> + CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + in + Tac2entries.ScopeRule (scope, (fun e -> e)) +end diff --git a/vendor/Ltac2/src/tac2core.mli b/vendor/Ltac2/src/tac2core.mli new file mode 100644 index 0000000000..9fae65bb3e --- /dev/null +++ b/vendor/Ltac2/src/tac2core.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/vendor/Ltac2/src/tac2dyn.ml b/vendor/Ltac2/src/tac2dyn.ml new file mode 100644 index 0000000000..896676f08b --- /dev/null +++ b/vendor/Ltac2/src/tac2dyn.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('raw * 'glb) pack + include Arg.Map(struct type 'a t = 'a pack end) +end + +module Val = Dyn.Make(struct end) diff --git a/vendor/Ltac2/src/tac2dyn.mli b/vendor/Ltac2/src/tac2dyn.mli new file mode 100644 index 0000000000..e995296840 --- /dev/null +++ b/vendor/Ltac2/src/tac2dyn.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('a, 'b) tag + val eq : ('a1, 'b1) tag -> ('a2, 'b2) tag -> ('a1 * 'b1, 'a2 * 'b2) CSig.eq option + val repr : ('a, 'b) tag -> string +end +(** Arguments that are part of an AST. *) + +module type Param = sig type ('raw, 'glb) t end + +module ArgMap (M : Param) : +sig + type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack + type t + val empty : t + val add : ('a, 'b) Arg.tag -> ('a * 'b) pack -> t -> t + val remove : ('a, 'b) Arg.tag -> t -> t + val find : ('a, 'b) Arg.tag -> t -> ('a * 'b) pack + val mem : ('a, 'b) Arg.tag -> t -> bool +end + +module Val : Dyn.S +(** Toplevel values *) diff --git a/vendor/Ltac2/src/tac2entries.ml b/vendor/Ltac2/src/tac2entries.ml new file mode 100644 index 0000000000..9fd01426de --- /dev/null +++ b/vendor/Ltac2/src/tac2entries.ml @@ -0,0 +1,938 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object {(default_object "TAC2-DEFINITION") with + cache_function = cache_tacdef; + load_function = load_tacdef; + open_function = open_tacdef; + subst_function = subst_tacdef; + classify_function = classify_tacdef} + +(** Type definition *) + +type typdef = { + typdef_local : bool; + typdef_expr : glb_quant_typedef; +} + +let change_kn_label kn id = + let mp = KerName.modpath kn in + KerName.make mp (Label.of_id id) + +let change_sp_label sp id = + let (dp, _) = Libnames.repr_path sp in + Libnames.make_path dp id + +let push_typedef visibility sp kn (_, def) = match def with +| GTydDef _ -> + Tac2env.push_type visibility sp kn +| GTydAlg { galg_constructors = cstrs } -> + (* Register constructors *) + let iter (c, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_constructor visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter cstrs +| GTydRec fields -> + (* Register fields *) + let iter (c, _, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_projection visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter fields +| GTydOpn -> + Tac2env.push_type visibility sp kn + +let next i = + let ans = !i in + let () = incr i in + ans + +let define_typedef kn (params, def as qdef) = match def with +| GTydDef _ -> + Tac2env.define_type kn qdef +| GTydAlg { galg_constructors = cstrs } -> + (* Define constructors *) + let constant = ref 0 in + let nonconstant = ref 0 in + let iter (c, args) = + let knc = change_kn_label kn c in + let tag = if List.is_empty args then next constant else next nonconstant in + let data = { + Tac2env.cdata_prms = params; + cdata_type = kn; + cdata_args = args; + cdata_indx = Some tag; + } in + Tac2env.define_constructor knc data + in + Tac2env.define_type kn qdef; + List.iter iter cstrs +| GTydRec fs -> + (* Define projections *) + let iter i (id, mut, t) = + let knp = change_kn_label kn id in + let proj = { + Tac2env.pdata_prms = params; + pdata_type = kn; + pdata_ptyp = t; + pdata_mutb = mut; + pdata_indx = i; + } in + Tac2env.define_projection knp proj + in + Tac2env.define_type kn qdef; + List.iteri iter fs +| GTydOpn -> + Tac2env.define_type kn qdef + +let perform_typdef vs ((sp, kn), def) = + let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let load_typdef i obj = perform_typdef (Until i) obj +let open_typdef i obj = perform_typdef (Exactly i) obj + +let cache_typdef ((sp, kn), def) = + let () = push_typedef (Until 1) sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let subst_typdef (subst, def) = + let expr' = subst_quant_typedef subst def.typdef_expr in + if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } + +let classify_typdef o = Substitute o + +let inTypDef : typdef -> obj = + declare_object {(default_object "TAC2-TYPE-DEFINITION") with + cache_function = cache_typdef; + load_function = load_typdef; + open_function = open_typdef; + subst_function = subst_typdef; + classify_function = classify_typdef} + +(** Type extension *) + +type extension_data = { + edata_name : Id.t; + edata_args : int glb_typexpr list; +} + +type typext = { + typext_local : bool; + typext_prms : int; + typext_type : type_constant; + typext_expr : extension_data list; +} + +let push_typext vis sp kn def = + let iter data = + let spc = change_sp_label sp data.edata_name in + let knc = change_kn_label kn data.edata_name in + Tac2env.push_constructor vis spc knc + in + List.iter iter def.typext_expr + +let define_typext kn def = + let iter data = + let knc = change_kn_label kn data.edata_name in + let cdata = { + Tac2env.cdata_prms = def.typext_prms; + cdata_type = def.typext_type; + cdata_args = data.edata_args; + cdata_indx = None; + } in + Tac2env.define_constructor knc cdata + in + List.iter iter def.typext_expr + +let cache_typext ((sp, kn), def) = + let () = define_typext kn def in + push_typext (Until 1) sp kn def + +let perform_typext vs ((sp, kn), def) = + let () = if not def.typext_local then push_typext vs sp kn def in + define_typext kn def + +let load_typext i obj = perform_typext (Until i) obj +let open_typext i obj = perform_typext (Exactly i) obj + +let subst_typext (subst, e) = + let open Mod_subst in + let subst_data data = + let edata_args = List.Smart.map (fun e -> subst_type subst e) data.edata_args in + if edata_args == data.edata_args then data + else { data with edata_args } + in + let typext_type = subst_kn subst e.typext_type in + let typext_expr = List.Smart.map subst_data e.typext_expr in + if typext_type == e.typext_type && typext_expr == e.typext_expr then + e + else + { e with typext_type; typext_expr } + +let classify_typext o = Substitute o + +let inTypExt : typext -> obj = + declare_object {(default_object "TAC2-TYPE-EXTENSION") with + cache_function = cache_typext; + load_function = load_typext; + open_function = open_typext; + subst_function = subst_typext; + classify_function = classify_typext} + +(** Toplevel entries *) + +let fresh_var avoid x = + let bad id = + Id.Set.mem id avoid || + (try ignore (Tac2env.locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string x) bad + +let extract_pattern_type ({loc;v=p} as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + +(** Mangle recursive tactics *) +let inline_rec_tactic tactics = + let avoid = List.fold_left (fun accu ({v=id}, _) -> Id.Set.add id accu) Id.Set.empty tactics in + let map (id, e) = match e.v with + | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) + | _ -> + user_err ?loc:id.loc (str "Recursive tactic definitions must be functions") + in + let tactics = List.map map tactics in + let map (id, pat, e) = + let fold_var (avoid, ans) (pat, _) = + let id = fresh_var avoid "x" in + let loc = pat.loc in + (Id.Set.add id avoid, CAst.make ?loc id :: ans) + in + (* Fresh variables to abstract over the function patterns *) + let _, vars = List.fold_left fold_var (avoid, []) pat in + let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in + let bnd = List.map map_body tactics in + let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in + let var_of_id {loc;v=id} = + let qid = qualid_of_ident ?loc id in + CAst.make ?loc @@ CTacRef (RelId qid) + in + let loc0 = e.loc in + let vpat = List.map pat_of_id vars in + let varg = List.map var_of_id vars in + let e = CAst.make ?loc:loc0 @@ CTacLet (true, bnd, CAst.make ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in + (id, CAst.make ?loc:loc0 @@ CTacFun (vpat, e)) + in + List.map map tactics + +let check_lowercase {loc;v=id} = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") + +let register_ltac ?(local = false) ?(mut = false) isrec tactics = + let map ({loc;v=na}, e) = + let id = match na with + | Anonymous -> + user_err ?loc (str "Tactic definition must have a name") + | Name id -> id + in + let () = check_lowercase CAst.(make ?loc id) in + (CAst.(make ?loc id), e) + in + let tactics = List.map map tactics in + let tactics = + if isrec then inline_rec_tactic tactics else tactics + in + let map ({loc;v=id}, e) = + let (e, t) = intern ~strict:true e in + let () = + if not (is_value e) then + user_err ?loc (str "Tactic definition must be a syntactical value") + in + let kn = Lib.make_kn id in + let exists = + try let _ = Tac2env.interp_global kn in true with Not_found -> false + in + let () = + if exists then + user_err ?loc (str "Tactic " ++ Names.Id.print id ++ str " already exists") + in + (id, e, t) + in + let defs = List.map map tactics in + let iter (id, e, t) = + let def = { + tacdef_local = local; + tacdef_mutable = mut; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + in + List.iter iter defs + +let qualid_to_ident qid = + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid + else user_err ?loc:qid.CAst.loc (str "Identifier expected") + +let register_typedef ?(local = false) isrec types = + let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name types with + | [] -> () + | ({loc;v=id}, _) :: _ -> + user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) + in + let check ({loc;v=id}, (params, def)) = + let same_name {v=id1} {v=id2} = Id.equal id1 id2 in + let () = match List.duplicates same_name params with + | [] -> () + | {loc;v=id} :: _ -> + user_err ?loc (str "The type parameter " ++ Id.print id ++ + str " occurs several times") + in + match def with + | CTydDef _ -> + if isrec then + user_err ?loc (str "The type abbreviation " ++ Id.print id ++ + str " cannot be recursive") + | CTydAlg cs -> + let same_name (id1, _) (id2, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name cs with + | [] -> () + | (id, _) :: _ -> + user_err (str "Multiple definitions of the constructor " ++ Id.print id) + in + () + | CTydRec ps -> + let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name ps with + | [] -> () + | (id, _, _) :: _ -> + user_err (str "Multiple definitions of the projection " ++ Id.print id) + in + () + | CTydOpn -> + if isrec then + user_err ?loc (str "The open type declaration " ++ Id.print id ++ + str " cannot be recursive") + in + let () = List.iter check types in + let self = + if isrec then + let fold accu ({v=id}, (params, _)) = + Id.Map.add id (Lib.make_kn id, List.length params) accu + in + List.fold_left fold Id.Map.empty types + else Id.Map.empty + in + let map ({v=id}, def) = + let typdef = { + typdef_local = local; + typdef_expr = intern_typedef self def; + } in + (id, typdef) + in + let types = List.map map types in + let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in + List.iter iter types + +let register_primitive ?(local = false) {loc;v=id} t ml = + let t = intern_open_type t in + let rec count_arrow = function + | GTypArrow (_, t) -> 1 + count_arrow t + | _ -> 0 + in + let arrows = count_arrow (snd t) in + let () = if Int.equal arrows 0 then + user_err ?loc (str "External tactic must have at least one argument") in + let () = + try let _ = Tac2env.interp_primitive ml in () with Not_found -> + user_err ?loc (str "Unregistered primitive " ++ + quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) + in + let init i = Id.of_string (Printf.sprintf "x%i" i) in + let names = List.init arrows init in + let bnd = List.map (fun id -> Name id) names in + let arg = List.map (fun id -> GTacVar id) names in + let e = GTacFun (bnd, GTacPrm (ml, arg)) in + let def = { + tacdef_local = local; + tacdef_mutable = false; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + +let register_open ?(local = false) qid (params, def) = + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc:qid.CAst.loc (str "Unbound type " ++ pr_qualid qid) + in + let (tparams, t) = Tac2env.interp_type kn in + let () = match t with + | GTydOpn -> () + | GTydAlg _ | GTydRec _ | GTydDef _ -> + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") + in + let () = + if not (Int.equal (List.length params) tparams) then + Tac2intern.error_nparams_mismatch ?loc:qid.CAst.loc (List.length params) tparams + in + match def with + | CTydOpn -> () + | CTydAlg def -> + let intern_type t = + let tpe = CTydDef (Some t) in + let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in + match ans with + | GTydDef (Some t) -> t + | _ -> assert false + in + let map (id, tpe) = + let tpe = List.map intern_type tpe in + { edata_name = id; edata_args = tpe } + in + let def = List.map map def in + let def = { + typext_local = local; + typext_type = kn; + typext_prms = tparams; + typext_expr = def; + } in + Lib.add_anonymous_leaf (inTypExt def) + | CTydRec _ | CTydDef _ -> + user_err ?loc:qid.CAst.loc (str "Extensions only accept inductive constructors") + +let register_type ?local isrec types = match types with +| [qid, true, def] -> + let () = if isrec then user_err ?loc:qid.CAst.loc (str "Extensions cannot be recursive") in + register_open ?local qid def +| _ -> + let map (qid, redef, def) = + let () = if redef then + user_err ?loc:qid.loc (str "Types can only be extended one by one") + in + (qualid_to_ident qid, def) + in + let types = List.map map types in + register_typedef ?local isrec types + +(** Parsing *) + +type 'a token = +| TacTerm of string +| TacNonTerm of Name.t * 'a + +type scope_rule = +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty + +let register_scope id s = + scope_table := Id.Map.add id s !scope_table + +module ParseToken = +struct + +let loc_of_token = function +| SexprStr {loc} -> loc +| SexprInt {loc} -> loc +| SexprRec (loc, _, _) -> Some loc + +let parse_scope = function +| SexprRec (_, {loc;v=Some id}, toks) -> + if Id.Map.mem id !scope_table then + Id.Map.find id !scope_table toks + else + CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) +| SexprStr {v=str} -> + let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in + ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ?loc (str "Invalid parsing token") + +let parse_token = function +| SexprStr {v=s} -> TacTerm s +| SexprRec (_, {v=na}, [tok]) -> + let na = match na with None -> Anonymous | Some id -> Name id in + let scope = parse_scope tok in + TacNonTerm (na, scope) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ?loc (str "Invalid parsing token") + +end + +let parse_scope = ParseToken.parse_scope + +type synext = { + synext_tok : sexpr list; + synext_exp : raw_tacexpr; + synext_lev : int option; + synext_loc : bool; +} + +type krule = +| KRule : + (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * + ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule + +let rec get_rule (tok : scope_rule token list) : krule = match tok with +| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, scope) in + let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in + KRule (rule, act) +| TacTerm t :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let act k _ = act k in + KRule (rule, act) + +let perform_notation syn st = + let tok = List.rev_map ParseToken.parse_token syn.synext_tok in + let KRule (rule, act) = get_rule tok in + let mk loc args = + let map (na, e) = + ((CAst.make ?loc:e.loc @@ CPatVar na), e) + in + let bnd = List.map map args in + CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) + in + let rule = Extend.Rule (rule, act mk) in + let lev = match syn.synext_lev with + | None -> None + | Some lev -> Some (string_of_int lev) + in + let rule = (lev, None, [rule]) in + ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) + +let ltac2_notation = + Pcoq.create_grammar_command "ltac2-notation" perform_notation + +let cache_synext (_, syn) = + Pcoq.extend_grammar_command ltac2_notation syn + +let open_synext i (_, syn) = + if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn + +let subst_synext (subst, syn) = + let e = Tac2intern.subst_rawexpr subst syn.synext_exp in + if e == syn.synext_exp then syn else { syn with synext_exp = e } + +let classify_synext o = + if o.synext_loc then Dispose else Substitute o + +let inTac2Notation : synext -> obj = + declare_object {(default_object "TAC2-NOTATION") with + cache_function = cache_synext; + open_function = open_synext; + subst_function = subst_synext; + classify_function = classify_synext} + +type abbreviation = { + abbr_body : raw_tacexpr; +} + +let perform_abbreviation visibility ((sp, kn), abbr) = + let () = Tac2env.push_ltac visibility sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let load_abbreviation i obj = perform_abbreviation (Until i) obj +let open_abbreviation i obj = perform_abbreviation (Exactly i) obj + +let cache_abbreviation ((sp, kn), abbr) = + let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let subst_abbreviation (subst, abbr) = + let body' = subst_rawexpr subst abbr.abbr_body in + if body' == abbr.abbr_body then abbr + else { abbr_body = body' } + +let classify_abbreviation o = Substitute o + +let inTac2Abbreviation : abbreviation -> obj = + declare_object {(default_object "TAC2-ABBREVIATION") with + cache_function = cache_abbreviation; + load_function = load_abbreviation; + open_function = open_abbreviation; + subst_function = subst_abbreviation; + classify_function = classify_abbreviation} + +let register_notation ?(local = false) tkn lev body = match tkn, lev with +| [SexprRec (_, {loc;v=Some id}, [])], None -> + (* Tactic abbreviation *) + let () = check_lowercase CAst.(make ?loc id) in + let body = Tac2intern.globalize Id.Set.empty body in + let abbr = { abbr_body = body } in + ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) +| _ -> + (* Check that the tokens make sense *) + let entries = List.map ParseToken.parse_token tkn in + let fold accu tok = match tok with + | TacTerm _ -> accu + | TacNonTerm (Name id, _) -> Id.Set.add id accu + | TacNonTerm (Anonymous, _) -> accu + in + let ids = List.fold_left fold Id.Set.empty entries in + (* Globalize so that names are absolute *) + let body = Tac2intern.globalize ids body in + let lev = match lev with Some _ -> lev | None -> Some 5 in + let ext = { + synext_tok = tkn; + synext_exp = body; + synext_lev = lev; + synext_loc = local; + } in + Lib.add_anonymous_leaf (inTac2Notation ext) + +type redefinition = { + redef_kn : ltac_constant; + redef_body : glb_tacexpr; +} + +let perform_redefinition (_, redef) = + let kn = redef.redef_kn in + let data = Tac2env.interp_global kn in + let data = { data with Tac2env.gdata_expr = redef.redef_body } in + Tac2env.define_global kn data + +let subst_redefinition (subst, redef) = + let kn = Mod_subst.subst_kn subst redef.redef_kn in + let body = Tac2intern.subst_expr subst redef.redef_body in + if kn == redef.redef_kn && body == redef.redef_body then redef + else { redef_kn = kn; redef_body = body } + +let classify_redefinition o = Substitute o + +let inTac2Redefinition : redefinition -> obj = + declare_object {(default_object "TAC2-REDEFINITION") with + cache_function = perform_redefinition; + open_function = (fun _ -> perform_redefinition); + subst_function = subst_redefinition; + classify_function = classify_redefinition } + +let register_redefinition ?(local = false) qid e = + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) + in + let kn = match kn with + | TacConstant kn -> kn + | TacAlias _ -> + user_err ?loc:qid.CAst.loc (str "Cannot redefine syntactic abbreviations") + in + let data = Tac2env.interp_global kn in + let () = + if not (data.Tac2env.gdata_mutable) then + user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") + in + let (e, t) = intern ~strict:true e in + let () = + if not (is_value e) then + user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") + in + let () = + if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then + let name = int_name () in + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ + str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) + in + let def = { + redef_kn = kn; + redef_body = e; + } in + Lib.add_anonymous_leaf (inTac2Redefinition def) + +let perform_eval ~pstate e = + let open Proofview.Notations in + let env = Global.env () in + let (e, ty) = Tac2intern.intern ~strict:false e in + let v = Tac2interp.interp Tac2interp.empty_environment e in + let selector, proof = + match pstate with + | None -> + let sigma = Evd.from_env env in + let name, poly = Id.of_string "ltac2", false in + Goal_select.SelectAll, Proof.start ~name ~poly sigma [] + | Some pstate -> + Goal_select.get_default_goal_selector (), + Proof_global.give_me_the_proof pstate + in + let v = match selector with + | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v + | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v + | Goal_select.SelectId id -> Proofview.tclFOCUSID id v + | Goal_select.SelectAll -> v + | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) + in + (* HACK: the API doesn't allow to return a value *) + let ans = ref None in + let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in + let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in + let sigma = Proof.in_proof proof (fun sigma -> sigma) in + let ans = match !ans with None -> assert false | Some r -> r in + let name = int_name () in + Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) + ++ spc () ++ str "=" ++ spc () ++ + Tac2print.pr_valexpr env sigma ans (snd ty)) + +(** Toplevel entries *) + +let register_struct ?local ~pstate str = match str with +| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e +| StrTyp (isrec, t) -> register_type ?local isrec t +| StrPrm (id, t, ml) -> register_primitive ?local id t ml +| StrSyn (tok, lev, e) -> register_notation ?local tok lev e +| StrMut (qid, e) -> register_redefinition ?local qid e +| StrRun e -> perform_eval ~pstate e + +(** Toplevel exception *) + +let _ = Goptions.declare_bool_option { + Goptions.optdepr = false; + Goptions.optname = "print Ltac2 backtrace"; + Goptions.optkey = ["Ltac2"; "Backtrace"]; + Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); + Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); +} + +let backtrace : backtrace Exninfo.t = Exninfo.make () + +let pr_frame = function +| FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" +| FrLtac kn -> + str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) +| FrPrim ml -> + str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" +| FrExtn (tag, arg) -> + let obj = Tac2env.interp_ml_object tag in + str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ + obj.Tac2env.ml_print (Global.env ()) arg + +let () = register_handler begin function +| Tac2interp.LtacError (kn, args) -> + let t_exn = KerName.make Tac2env.coq_prefix (Label.make "exn") in + let v = Tac2ffi.of_open (kn, args) in + let t = GTypRef (Other t_exn, []) in + let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) +| _ -> raise Unhandled +end + +let () = ExplainErr.register_additional_error_info begin fun (e, info) -> + if !Tac2interp.print_ltac2_backtrace then + let bt = Exninfo.get info backtrace in + let bt = match bt with + | Some bt -> bt + | None -> raise Exit + in + let bt = + str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () + in + Some (Loc.tag @@ Some bt) + else raise Exit +end + +(** Printing *) + +let print_ltac qid = + if Tac2env.is_constructor qid then + let kn = + try Tac2env.locate_constructor qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown constructor " ++ pr_qualid qid) + in + let _ = Tac2env.interp_constructor kn in + Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) + in + match kn with + | TacConstant kn -> + let data = Tac2env.interp_global kn in + let e = data.Tac2env.gdata_expr in + let (_, t) = data.Tac2env.gdata_type in + let name = int_name () in + Feedback.msg_notice ( + hov 0 ( + hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ + hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + ) + ) + | TacAlias kn -> + Feedback.msg_notice (str "Alias to ...") + +(** Calling tactics *) + +let solve ~pstate default tac = + let pstate, status = Proof_global.with_current_proof begin fun etac p -> + let with_end_tac = if default then Some etac else None in + let g = Goal_select.get_default_goal_selector () in + let (p, status) = Pfedit.solve g None tac ?with_end_tac p in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p, status + end pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate + +let call ~pstate ~default e = + let loc = e.loc in + let (e, t) = intern ~strict:false e in + let () = check_unit ?loc t in + let tac = Tac2interp.interp Tac2interp.empty_environment e in + solve ~pstate default (Proofview.tclIGNORE tac) + +(** Primitive algebraic types than can't be defined Coq-side *) + +let register_prim_alg name params def = + let id = Id.of_string name in + let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) def in + let alg = { + galg_constructors = def; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + let def = (params, GTydAlg alg) in + let def = { typdef_local = false; typdef_expr = def } in + ignore (Lib.add_leaf id (inTypDef def)) + +let coq_def n = KerName.make Tac2env.coq_prefix (Label.make n) + +let def_unit = { + typdef_local = false; + typdef_expr = 0, GTydDef (Some (GTypRef (Tuple 0, []))); +} + +let t_list = coq_def "list" + +let (f_register_constr_quotations, register_constr_quotations) = Hook.make () + +let cache_ltac2_init (_, ()) = + Hook.get f_register_constr_quotations () + +let load_ltac2_init _ (_, ()) = + Hook.get f_register_constr_quotations () + +let open_ltac2_init _ (_, ()) = + Goptions.set_string_option_value_gen ["Default"; "Proof"; "Mode"] "Ltac2" + +(** Dummy object that register global rules when Require is called *) +let inTac2Init : unit -> obj = + declare_object {(default_object "TAC2-INIT") with + cache_function = cache_ltac2_init; + load_function = load_ltac2_init; + open_function = open_ltac2_init; + } + +let _ = Mltop.declare_cache_obj begin fun () -> + ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); + register_prim_alg "list" 1 [ + ("[]", []); + ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); + ]; + Lib.add_anonymous_leaf (inTac2Init ()); +end "ltac2_plugin" diff --git a/vendor/Ltac2/src/tac2entries.mli b/vendor/Ltac2/src/tac2entries.mli new file mode 100644 index 0000000000..d493192bb3 --- /dev/null +++ b/vendor/Ltac2/src/tac2entries.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ?mut:bool -> rec_flag -> + (Names.lname * raw_tacexpr) list -> unit + +val register_type : ?local:bool -> rec_flag -> + (qualid * redef_flag * raw_quant_typedef) list -> unit + +val register_primitive : ?local:bool -> + Names.lident -> raw_typexpr -> ml_tactic_name -> unit + +val register_struct + : ?local:bool + -> pstate:Proof_global.t option + -> strexpr + -> unit + +val register_notation : ?local:bool -> sexpr list -> int option -> + raw_tacexpr -> unit + +(** {5 Notations} *) + +type scope_rule = +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +val register_scope : Id.t -> scope_interpretation -> unit +(** Create a new scope with the provided name *) + +val parse_scope : sexpr -> scope_rule +(** Use this to interpret the subscopes for interpretation functions *) + +(** {5 Inspecting} *) + +val print_ltac : Libnames.qualid -> unit + +(** {5 Eval loop} *) + +(** Evaluate a tactic expression in the current environment *) +val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t + +(** {5 Toplevel exceptions} *) + +val backtrace : backtrace Exninfo.t + +(** {5 Parsing entries} *) + +module Pltac : +sig +val tac2expr : raw_tacexpr Pcoq.Entry.t + +(** Quoted entries. To be used for complex notations. *) + +open Tac2qexpr + +val q_ident : Id.t CAst.t or_anti Pcoq.Entry.t +val q_bindings : bindings Pcoq.Entry.t +val q_with_bindings : bindings Pcoq.Entry.t +val q_intropattern : intro_pattern Pcoq.Entry.t +val q_intropatterns : intro_pattern list CAst.t Pcoq.Entry.t +val q_destruction_arg : destruction_arg Pcoq.Entry.t +val q_induction_clause : induction_clause Pcoq.Entry.t +val q_conversion : conversion Pcoq.Entry.t +val q_rewriting : rewriting Pcoq.Entry.t +val q_clause : clause Pcoq.Entry.t +val q_dispatch : dispatch Pcoq.Entry.t +val q_occurrences : occurrences Pcoq.Entry.t +val q_reference : reference or_anti Pcoq.Entry.t +val q_strategy_flag : strategy_flag Pcoq.Entry.t +val q_constr_matching : constr_matching Pcoq.Entry.t +val q_goal_matching : goal_matching Pcoq.Entry.t +val q_hintdb : hintdb Pcoq.Entry.t +val q_move_location : move_location Pcoq.Entry.t +val q_pose : pose Pcoq.Entry.t +val q_assert : assertion Pcoq.Entry.t +end + +(** {5 Hooks} *) + +val register_constr_quotations : (unit -> unit) Hook.t diff --git a/vendor/Ltac2/src/tac2env.ml b/vendor/Ltac2/src/tac2env.ml new file mode 100644 index 0000000000..93ad57e97e --- /dev/null +++ b/vendor/Ltac2/src/tac2env.ml @@ -0,0 +1,298 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* KerName.compare c1 c2 +| TacAlias c1, TacAlias c2 -> KerName.compare c1 c2 +| TacConstant _, TacAlias _ -> -1 +| TacAlias _, TacConstant _ -> 1 + +let equal r1 r2 = compare r1 r2 == 0 + +end + +module KnTab = Nametab.Make(FullPath)(KerName) +module RfTab = Nametab.Make(FullPath)(TacRef) +module RfMap = Map.Make(TacRef) + +type nametab = { + tab_ltac : RfTab.t; + tab_ltac_rev : full_path RfMap.t; + tab_cstr : KnTab.t; + tab_cstr_rev : full_path KNmap.t; + tab_type : KnTab.t; + tab_type_rev : full_path KNmap.t; + tab_proj : KnTab.t; + tab_proj_rev : full_path KNmap.t; +} + +let empty_nametab = { + tab_ltac = RfTab.empty; + tab_ltac_rev = RfMap.empty; + tab_cstr = KnTab.empty; + tab_cstr_rev = KNmap.empty; + tab_type = KnTab.empty; + tab_type_rev = KNmap.empty; + tab_proj = KnTab.empty; + tab_proj_rev = KNmap.empty; +} + +let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" + +let push_ltac vis sp kn = + let tab = !nametab in + let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in + let tab_ltac_rev = RfMap.add kn sp tab.tab_ltac_rev in + nametab := { tab with tab_ltac; tab_ltac_rev } + +let locate_ltac qid = + let tab = !nametab in + RfTab.locate qid tab.tab_ltac + +let locate_extended_all_ltac qid = + let tab = !nametab in + RfTab.find_prefixes qid tab.tab_ltac + +let shortest_qualid_of_ltac kn = + let tab = !nametab in + let sp = RfMap.find kn tab.tab_ltac_rev in + RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + +let push_constructor vis sp kn = + let tab = !nametab in + let tab_cstr = KnTab.push vis sp kn tab.tab_cstr in + let tab_cstr_rev = KNmap.add kn sp tab.tab_cstr_rev in + nametab := { tab with tab_cstr; tab_cstr_rev } + +let locate_constructor qid = + let tab = !nametab in + KnTab.locate qid tab.tab_cstr + +let locate_extended_all_constructor qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_cstr + +let shortest_qualid_of_constructor kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_cstr_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr + +let push_type vis sp kn = + let tab = !nametab in + let tab_type = KnTab.push vis sp kn tab.tab_type in + let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in + nametab := { tab with tab_type; tab_type_rev } + +let locate_type qid = + let tab = !nametab in + KnTab.locate qid tab.tab_type + +let locate_extended_all_type qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_type + +let shortest_qualid_of_type ?loc kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_type_rev in + KnTab.shortest_qualid ?loc Id.Set.empty sp tab.tab_type + +let push_projection vis sp kn = + let tab = !nametab in + let tab_proj = KnTab.push vis sp kn tab.tab_proj in + let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in + nametab := { tab with tab_proj; tab_proj_rev } + +let locate_projection qid = + let tab = !nametab in + KnTab.locate qid tab.tab_proj + +let locate_extended_all_projection qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_proj + +let shortest_qualid_of_projection kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_proj_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj + +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + +type environment = { + env_ist : valexpr Id.Map.t; +} + +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + +type ('a, 'b) ml_object = { + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; +} + +module MLTypeObj = +struct + type ('a, 'b) t = ('a, 'b) ml_object +end + +module MLType = Tac2dyn.ArgMap(MLTypeObj) + +let ml_object_table = ref MLType.empty + +let define_ml_object t tpe = + ml_object_table := MLType.add t (MLType.Pack tpe) !ml_object_table + +let interp_ml_object t = + try + let MLType.Pack ans = MLType.find t !ml_object_table in + ans + with Not_found -> + CErrors.anomaly Pp.(str "Unknown object type " ++ str (Tac2dyn.Arg.repr t)) + +(** Absolute paths *) + +let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + +let std_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) + +let ltac1_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Ltac1"; "Ltac2"])) + +(** Generic arguments *) + +let wit_ltac2 = Genarg.make0 "ltac2:value" +let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" +let () = Geninterp.register_val0 wit_ltac2 None +let () = Geninterp.register_val0 wit_ltac2_quotation None + +let is_constructor qid = + let (_, id) = repr_qualid qid in + let id = Id.to_string id in + assert (String.length id > 0); + match id with + | "true" | "false" -> true (* built-in constructors *) + | _ -> + match id.[0] with + | 'A'..'Z' -> true + | _ -> false diff --git a/vendor/Ltac2/src/tac2env.mli b/vendor/Ltac2/src/tac2env.mli new file mode 100644 index 0000000000..c7e87c5432 --- /dev/null +++ b/vendor/Ltac2/src/tac2env.mli @@ -0,0 +1,146 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* global_data -> unit +val interp_global : ltac_constant -> global_data + +(** {5 Toplevel definition of types} *) + +val define_type : type_constant -> glb_quant_typedef -> unit +val interp_type : type_constant -> glb_quant_typedef + +(** {5 Toplevel definition of algebraic constructors} *) + +type constructor_data = { + cdata_prms : int; + (** Type parameters *) + cdata_type : type_constant; + (** Inductive definition to which the constructor pertains *) + cdata_args : int glb_typexpr list; + (** Types of the constructor arguments *) + cdata_indx : int option; + (** Index of the constructor in the ADT. Numbering is duplicated between + argumentless and argument-using constructors, e.g. in type ['a option] + [None] and [Some] have both index 0. This field is empty whenever the + constructor is a member of an open type. *) +} + +val define_constructor : ltac_constructor -> constructor_data -> unit +val interp_constructor : ltac_constructor -> constructor_data + +(** {5 Toplevel definition of projections} *) + +type projection_data = { + pdata_prms : int; + (** Type parameters *) + pdata_type : type_constant; + (** Record definition to which the projection pertains *) + pdata_ptyp : int glb_typexpr; + (** Type of the projection *) + pdata_mutb : bool; + (** Whether the field is mutable *) + pdata_indx : int; + (** Index of the projection *) +} + +val define_projection : ltac_projection -> projection_data -> unit +val interp_projection : ltac_projection -> projection_data + +(** {5 Toplevel definition of aliases} *) + +val define_alias : ltac_constant -> raw_tacexpr -> unit +val interp_alias : ltac_constant -> raw_tacexpr + +(** {5 Name management} *) + +val push_ltac : visibility -> full_path -> tacref -> unit +val locate_ltac : qualid -> tacref +val locate_extended_all_ltac : qualid -> tacref list +val shortest_qualid_of_ltac : tacref -> qualid + +val push_constructor : visibility -> full_path -> ltac_constructor -> unit +val locate_constructor : qualid -> ltac_constructor +val locate_extended_all_constructor : qualid -> ltac_constructor list +val shortest_qualid_of_constructor : ltac_constructor -> qualid + +val push_type : visibility -> full_path -> type_constant -> unit +val locate_type : qualid -> type_constant +val locate_extended_all_type : qualid -> type_constant list +val shortest_qualid_of_type : ?loc:Loc.t -> type_constant -> qualid + +val push_projection : visibility -> full_path -> ltac_projection -> unit +val locate_projection : qualid -> ltac_projection +val locate_extended_all_projection : qualid -> ltac_projection list +val shortest_qualid_of_projection : ltac_projection -> qualid + +(** {5 Toplevel definitions of ML tactics} *) + +(** This state is not part of the summary, contrarily to the ones above. It is + intended to be used from ML plugins to register ML-side functions. *) + +val define_primitive : ml_tactic_name -> closure -> unit +val interp_primitive : ml_tactic_name -> closure + +(** {5 ML primitive types} *) + +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + +type environment = { + env_ist : valexpr Id.Map.t; +} + +type ('a, 'b) ml_object = { + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; +} + +val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit +val interp_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object + +(** {5 Absolute paths} *) + +val coq_prefix : ModPath.t +(** Path where primitive datatypes are defined in Ltac2 plugin. *) + +val std_prefix : ModPath.t +(** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) + +val ltac1_prefix : ModPath.t +(** Path where the Ltac1 legacy FFI is defined. *) + +(** {5 Generic arguments} *) + +val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type + +(** {5 Helper functions} *) + +val is_constructor : qualid -> bool diff --git a/vendor/Ltac2/src/tac2expr.mli b/vendor/Ltac2/src/tac2expr.mli new file mode 100644 index 0000000000..1069d0bfa3 --- /dev/null +++ b/vendor/Ltac2/src/tac2expr.mli @@ -0,0 +1,190 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_tacexpr_r + +and raw_tacexpr = raw_tacexpr_r CAst.t + +and raw_taccase = raw_patexpr * raw_tacexpr + +and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list + +type case_info = type_constant or_tuple + +type 'a open_match = { + opn_match : 'a; + opn_branch : (Name.t * Name.t array * 'a) KNmap.t; + (** Invariant: should not be empty *) + opn_default : Name.t * 'a; +} + +type glb_tacexpr = +| GTacAtm of atom +| GTacVar of Id.t +| GTacRef of ltac_constant +| GTacFun of Name.t list * glb_tacexpr +| GTacApp of glb_tacexpr * glb_tacexpr list +| GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr +| GTacCst of case_info * int * glb_tacexpr list +| GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array +| GTacPrj of type_constant * glb_tacexpr * int +| GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr +| GTacOpn of ltac_constructor * glb_tacexpr list +| GTacWth of glb_tacexpr open_match +| GTacExt : (_, 'a) Tac2dyn.Arg.tag * 'a -> glb_tacexpr +| GTacPrm of ml_tactic_name * glb_tacexpr list + +(** {5 Parsing & Printing} *) + +type exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +type sexpr = +| SexprStr of string CAst.t +| SexprInt of int CAst.t +| SexprRec of Loc.t * Id.t option CAst.t * sexpr list + +(** {5 Toplevel statements} *) + +type strexpr = +| StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list + (** Term definition *) +| StrTyp of rec_flag * (qualid * redef_flag * raw_quant_typedef) list + (** Type definition *) +| StrPrm of Names.lident * raw_typexpr * ml_tactic_name + (** External definition *) +| StrSyn of sexpr list * int option * raw_tacexpr + (** Syntactic extensions *) +| StrMut of qualid * raw_tacexpr + (** Redefinition of mutable globals *) +| StrRun of raw_tacexpr + (** Toplevel evaluation of an expression *) + +(** {5 Dynamic semantics} *) + +(** Values are represented in a way similar to OCaml, i.e. they constrast + immediate integers (integers, constructors without arguments) and structured + blocks (tuples, arrays, constructors with arguments), as well as a few other + base cases, namely closures, strings, named constructors, and dynamic type + coming from the Coq implementation. *) + +type tag = int + +type frame = +| FrLtac of ltac_constant +| FrAnon of glb_tacexpr +| FrPrim of ml_tactic_name +| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame + +type backtrace = frame list diff --git a/vendor/Ltac2/src/tac2extffi.ml b/vendor/Ltac2/src/tac2extffi.ml new file mode 100644 index 0000000000..315c970f9e --- /dev/null +++ b/vendor/Ltac2/src/tac2extffi.ml @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false) f + +(** More ML representations *) + +let to_qhyp v = match Value.to_block v with +| (0, [| i |]) -> AnonHyp (Value.to_int i) +| (1, [| id |]) -> NamedHyp (Value.to_ident id) +| _ -> assert false + +let qhyp = make_to_repr to_qhyp + +let to_bindings = function +| ValInt 0 -> NoBindings +| ValBlk (0, [| vl |]) -> + ImplicitBindings (Value.to_list Value.to_constr vl) +| ValBlk (1, [| vl |]) -> + ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) +| _ -> assert false + +let bindings = make_to_repr to_bindings + +let to_constr_with_bindings v = match Value.to_tuple v with +| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) +| _ -> assert false + +let constr_with_bindings = make_to_repr to_constr_with_bindings diff --git a/vendor/Ltac2/src/tac2extffi.mli b/vendor/Ltac2/src/tac2extffi.mli new file mode 100644 index 0000000000..f5251c3d0d --- /dev/null +++ b/vendor/Ltac2/src/tac2extffi.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a Proofview.tactic) arity0 +| AddAty : ('a, 'b) arity0 -> ('a, 'a -> 'b) arity0 + +type valexpr = +| ValInt of int + (** Immediate integers *) +| ValBlk of tag * valexpr array + (** Structured blocks *) +| ValStr of Bytes.t + (** Strings *) +| ValCls of closure + (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr + (** Arbitrary data *) + +and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure + +let arity_one = OneAty +let arity_suc a = AddAty a + +type 'a arity = (valexpr, 'a) arity0 + +let mk_closure arity f = MLTactic (arity, f) + +module Valexpr = +struct + +type t = valexpr + +let is_int = function +| ValInt _ -> true +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false + +let tag v = match v with +| ValBlk (n, _) -> n +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let field v n = match v with +| ValBlk (_, v) -> v.(n) +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let set_field v n w = match v with +| ValBlk (_, v) -> v.(n) <- w +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let make_block tag v = ValBlk (tag, v) +let make_int n = ValInt n + +end + +type 'a repr = { + r_of : 'a -> valexpr; + r_to : valexpr -> 'a; + r_id : bool; +} + +let repr_of r x = r.r_of x +let repr_to r x = r.r_to x + +let make_repr r_of r_to = { r_of; r_to; r_id = false; } + +(** Dynamic tags *) + +let val_exn = Val.create "exn" +let val_constr = Val.create "constr" +let val_ident = Val.create "ident" +let val_pattern = Val.create "pattern" +let val_pp = Val.create "pp" +let val_sort = Val.create "sort" +let val_cast = Val.create "cast" +let val_inductive = Val.create "inductive" +let val_constant = Val.create "constant" +let val_constructor = Val.create "constructor" +let val_projection = Val.create "projection" +let val_case = Val.create "case" +let val_univ = Val.create "universe" +let val_free : Names.Id.Set.t Val.tag = Val.create "free" +let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" + +let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v + +(** Exception *) + +exception LtacError of KerName.t * valexpr array + +(** Conversion functions *) + +let valexpr = { + r_of = (fun obj -> obj); + r_to = (fun obj -> obj); + r_id = true; +} + +let of_unit () = ValInt 0 + +let to_unit = function +| ValInt 0 -> () +| _ -> assert false + +let unit = { + r_of = of_unit; + r_to = to_unit; + r_id = false; +} + +let of_int n = ValInt n +let to_int = function +| ValInt n -> n +| _ -> assert false + +let int = { + r_of = of_int; + r_to = to_int; + r_id = false; +} + +let of_bool b = if b then ValInt 0 else ValInt 1 + +let to_bool = function +| ValInt 0 -> true +| ValInt 1 -> false +| _ -> assert false + +let bool = { + r_of = of_bool; + r_to = to_bool; + r_id = false; +} + +let of_char n = ValInt (Char.code n) +let to_char = function +| ValInt n -> Char.chr n +| _ -> assert false + +let char = { + r_of = of_char; + r_to = to_char; + r_id = false; +} + +let of_string s = ValStr s +let to_string = function +| ValStr s -> s +| _ -> assert false + +let string = { + r_of = of_string; + r_to = to_string; + r_id = false; +} + +let rec of_list f = function +| [] -> ValInt 0 +| x :: l -> ValBlk (0, [| f x; of_list f l |]) + +let rec to_list f = function +| ValInt 0 -> [] +| ValBlk (0, [|v; vl|]) -> f v :: to_list f vl +| _ -> assert false + +let list r = { + r_of = (fun l -> of_list r.r_of l); + r_to = (fun l -> to_list r.r_to l); + r_id = false; +} + +let of_closure cls = ValCls cls + +let to_closure = function +| ValCls cls -> cls +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false + +let closure = { + r_of = of_closure; + r_to = to_closure; + r_id = false; +} + +let of_ext tag c = + ValExt (tag, c) + +let to_ext tag = function +| ValExt (tag', e) -> extract_val tag tag' e +| _ -> assert false + +let repr_ext tag = { + r_of = (fun e -> of_ext tag e); + r_to = (fun e -> to_ext tag e); + r_id = false; +} + +let of_constr c = of_ext val_constr c +let to_constr c = to_ext val_constr c +let constr = repr_ext val_constr + +let of_ident c = of_ext val_ident c +let to_ident c = to_ext val_ident c +let ident = repr_ext val_ident + +let of_pattern c = of_ext val_pattern c +let to_pattern c = to_ext val_pattern c +let pattern = repr_ext val_pattern + +let internal_err = + let open Names in + let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + in + KerName.make coq_prefix (Label.of_id (Id.of_string "Internal")) + +(** FIXME: handle backtrace in Ltac2 exceptions *) +let of_exn c = match fst c with +| LtacError (kn, c) -> ValOpn (kn, c) +| _ -> ValOpn (internal_err, [|of_ext val_exn c|]) + +let to_exn c = match c with +| ValOpn (kn, c) -> + if Names.KerName.equal kn internal_err then + to_ext val_exn c.(0) + else + (LtacError (kn, c), Exninfo.null) +| _ -> assert false + +let exn = { + r_of = of_exn; + r_to = to_exn; + r_id = false; +} + +let of_option f = function +| None -> ValInt 0 +| Some c -> ValBlk (0, [|f c|]) + +let to_option f = function +| ValInt 0 -> None +| ValBlk (0, [|c|]) -> Some (f c) +| _ -> assert false + +let option r = { + r_of = (fun l -> of_option r.r_of l); + r_to = (fun l -> to_option r.r_to l); + r_id = false; +} + +let of_pp c = of_ext val_pp c +let to_pp c = to_ext val_pp c +let pp = repr_ext val_pp + +let of_tuple cl = ValBlk (0, cl) +let to_tuple = function +| ValBlk (0, cl) -> cl +| _ -> assert false + +let of_pair f g (x, y) = ValBlk (0, [|f x; g y|]) +let to_pair f g = function +| ValBlk (0, [|x; y|]) -> (f x, g y) +| _ -> assert false +let pair r0 r1 = { + r_of = (fun p -> of_pair r0.r_of r1.r_of p); + r_to = (fun p -> to_pair r0.r_to r1.r_to p); + r_id = false; +} + +let of_array f vl = ValBlk (0, Array.map f vl) +let to_array f = function +| ValBlk (0, vl) -> Array.map f vl +| _ -> assert false +let array r = { + r_of = (fun l -> of_array r.r_of l); + r_to = (fun l -> to_array r.r_to l); + r_id = false; +} + +let of_block (n, args) = ValBlk (n, args) +let to_block = function +| ValBlk (n, args) -> (n, args) +| _ -> assert false + +let block = { + r_of = of_block; + r_to = to_block; + r_id = false; +} + +let of_open (kn, args) = ValOpn (kn, args) + +let to_open = function +| ValOpn (kn, args) -> (kn, args) +| _ -> assert false + +let open_ = { + r_of = of_open; + r_to = to_open; + r_id = false; +} + +let of_constant c = of_ext val_constant c +let to_constant c = to_ext val_constant c +let constant = repr_ext val_constant + +let of_reference = function +| VarRef id -> ValBlk (0, [| of_ident id |]) +| ConstRef cst -> ValBlk (1, [| of_constant cst |]) +| IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) +| ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) + +let to_reference = function +| ValBlk (0, [| id |]) -> VarRef (to_ident id) +| ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) +| ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) +| ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) +| _ -> assert false + +let reference = { + r_of = of_reference; + r_to = to_reference; + r_id = false; +} + +type ('a, 'b) fun1 = closure + +let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure +let to_fun1 r0 r1 f = to_closure f + +let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = + fun arity f args -> match args, arity with + | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) + (* A few hardcoded cases for efficiency *) + | [a0], OneAty -> f a0 + | [a0; a1], AddAty OneAty -> f a0 a1 + | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 + | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 + (* Generic cases *) + | a :: args, OneAty -> + f a >>= fun f -> + let MLTactic (arity, f) = to_closure f in + apply arity f args + | a :: args, AddAty arity -> + apply arity (f a) args + +let apply (MLTactic (arity, f)) args = apply arity f args + +type n_closure = +| NClosure : 'a arity * (valexpr list -> 'a) -> n_closure + +let rec abstract n f = + if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) + else + let NClosure (arity, fe) = abstract (n - 1) f in + NClosure (AddAty arity, fun accu v -> fe (v :: accu)) + +let abstract n f = + let () = assert (n > 0) in + let NClosure (arity, f) = abstract n f in + MLTactic (arity, f []) + +let app_fun1 cls r0 r1 x = + apply cls [r0.r_of x] >>= fun v -> Proofview.tclUNIT (r1.r_to v) diff --git a/vendor/Ltac2/src/tac2ffi.mli b/vendor/Ltac2/src/tac2ffi.mli new file mode 100644 index 0000000000..bfc93d99e6 --- /dev/null +++ b/vendor/Ltac2/src/tac2ffi.mli @@ -0,0 +1,189 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr + (** Arbitrary data *) + +type 'a arity + +val arity_one : (valexpr -> valexpr Proofview.tactic) arity +val arity_suc : 'a arity -> (valexpr -> 'a) arity + +val mk_closure : 'v arity -> 'v -> closure + +module Valexpr : +sig + type t = valexpr + val is_int : t -> bool + val tag : t -> int + val field : t -> int -> t + val set_field : t -> int -> t -> unit + val make_block : int -> t array -> t + val make_int : int -> t +end + +(** {5 Ltac2 FFI} *) + +type 'a repr + +val repr_of : 'a repr -> 'a -> valexpr +val repr_to : 'a repr -> valexpr -> 'a + +val make_repr : ('a -> valexpr) -> (valexpr -> 'a) -> 'a repr + +(** These functions allow to convert back and forth between OCaml and Ltac2 + data representation. The [to_*] functions raise an anomaly whenever the data + has not expected shape. *) + +val of_unit : unit -> valexpr +val to_unit : valexpr -> unit +val unit : unit repr + +val of_int : int -> valexpr +val to_int : valexpr -> int +val int : int repr + +val of_bool : bool -> valexpr +val to_bool : valexpr -> bool +val bool : bool repr + +val of_char : char -> valexpr +val to_char : valexpr -> char +val char : char repr + +val of_string : Bytes.t -> valexpr +val to_string : valexpr -> Bytes.t +val string : Bytes.t repr + +val of_list : ('a -> valexpr) -> 'a list -> valexpr +val to_list : (valexpr -> 'a) -> valexpr -> 'a list +val list : 'a repr -> 'a list repr + +val of_constr : EConstr.t -> valexpr +val to_constr : valexpr -> EConstr.t +val constr : EConstr.t repr + +val of_exn : Exninfo.iexn -> valexpr +val to_exn : valexpr -> Exninfo.iexn +val exn : Exninfo.iexn repr + +val of_ident : Id.t -> valexpr +val to_ident : valexpr -> Id.t +val ident : Id.t repr + +val of_closure : closure -> valexpr +val to_closure : valexpr -> closure +val closure : closure repr + +val of_block : (int * valexpr array) -> valexpr +val to_block : valexpr -> (int * valexpr array) +val block : (int * valexpr array) repr + +val of_array : ('a -> valexpr) -> 'a array -> valexpr +val to_array : (valexpr -> 'a) -> valexpr -> 'a array +val array : 'a repr -> 'a array repr + +val of_tuple : valexpr array -> valexpr +val to_tuple : valexpr -> valexpr array + +val of_pair : ('a -> valexpr) -> ('b -> valexpr) -> 'a * 'b -> valexpr +val to_pair : (valexpr -> 'a) -> (valexpr -> 'b) -> valexpr -> 'a * 'b +val pair : 'a repr -> 'b repr -> ('a * 'b) repr + +val of_option : ('a -> valexpr) -> 'a option -> valexpr +val to_option : (valexpr -> 'a) -> valexpr -> 'a option +val option : 'a repr -> 'a option repr + +val of_pattern : Pattern.constr_pattern -> valexpr +val to_pattern : valexpr -> Pattern.constr_pattern +val pattern : Pattern.constr_pattern repr + +val of_pp : Pp.t -> valexpr +val to_pp : valexpr -> Pp.t +val pp : Pp.t repr + +val of_constant : Constant.t -> valexpr +val to_constant : valexpr -> Constant.t +val constant : Constant.t repr + +val of_reference : GlobRef.t -> valexpr +val to_reference : valexpr -> GlobRef.t +val reference : GlobRef.t repr + +val of_ext : 'a Val.tag -> 'a -> valexpr +val to_ext : 'a Val.tag -> valexpr -> 'a +val repr_ext : 'a Val.tag -> 'a repr + +val of_open : KerName.t * valexpr array -> valexpr +val to_open : valexpr -> KerName.t * valexpr array +val open_ : (KerName.t * valexpr array) repr + +type ('a, 'b) fun1 + +val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic + +val to_fun1 : 'a repr -> 'b repr -> valexpr -> ('a, 'b) fun1 +val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr + +val valexpr : valexpr repr + +(** {5 Dynamic tags} *) + +val val_constr : EConstr.t Val.tag +val val_ident : Id.t Val.tag +val val_pattern : Pattern.constr_pattern Val.tag +val val_pp : Pp.t Val.tag +val val_sort : ESorts.t Val.tag +val val_cast : Constr.cast_kind Val.tag +val val_inductive : inductive Val.tag +val val_constant : Constant.t Val.tag +val val_constructor : constructor Val.tag +val val_projection : Projection.t Val.tag +val val_case : Constr.case_info Val.tag +val val_univ : Univ.Level.t Val.tag +val val_free : Id.Set.t Val.tag +val val_ltac1 : Geninterp.Val.t Val.tag + +val val_exn : Exninfo.iexn Tac2dyn.Val.tag +(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] + should be put into a value with tag [val_exn]. *) + +(** Closures *) + +val apply : closure -> valexpr list -> valexpr Proofview.tactic +(** Given a closure, apply it to some arguments. Handling of argument mismatches + is done automatically, i.e. in case of over or under-application. *) + +val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> closure +(** Turn a fixed-arity function into a closure. The inner function is guaranteed + to be applied to a list whose size is the integer argument. *) + +(** Exception *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) diff --git a/vendor/Ltac2/src/tac2intern.ml b/vendor/Ltac2/src/tac2intern.ml new file mode 100644 index 0000000000..de99fb167f --- /dev/null +++ b/vendor/Ltac2/src/tac2intern.ml @@ -0,0 +1,1545 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* elt -> bool +val create : unit -> 'a t +val fresh : 'a t -> elt +val find : elt -> 'a t -> (elt * 'a option) +val union : elt -> elt -> 'a t -> unit +val set : elt -> 'a -> 'a t -> unit +module Map : +sig + type key = elt + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val exists : (key -> 'a -> bool) -> 'a t -> bool +end +end += +struct +type elt = int +let equal = Int.equal +module Map = Int.Map + +type 'a node = +| Canon of int * 'a option +| Equiv of elt + +type 'a t = { + mutable uf_data : 'a node array; + mutable uf_size : int; +} + +let resize p = + if Int.equal (Array.length p.uf_data) p.uf_size then begin + let nsize = 2 * p.uf_size + 1 in + let v = Array.make nsize (Equiv 0) in + Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); + p.uf_data <- v; + end + +let create () = { uf_data = [||]; uf_size = 0 } + +let fresh p = + resize p; + let n = p.uf_size in + p.uf_data.(n) <- (Canon (1, None)); + p.uf_size <- n + 1; + n + +let rec lookup n p = + let node = Array.get p.uf_data n in + match node with + | Canon (size, v) -> n, size, v + | Equiv y -> + let ((z, _, _) as res) = lookup y p in + if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); + res + +let find n p = + let (x, _, v) = lookup n p in (x, v) + +let union x y p = + let ((x, size1, _) as xcan) = lookup x p in + let ((y, size2, _) as ycan) = lookup y p in + let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in + let x, _, xnode = xcan in + let y, _, ynode = ycan in + assert (Option.is_empty xnode); + assert (Option.is_empty ynode); + p.uf_data.(x) <- Equiv y; + p.uf_data.(y) <- Canon (size1 + size2, None) + +let set x v p = + let (x, s, v') = lookup x p in + assert (Option.is_empty v'); + p.uf_data.(x) <- Canon (s, Some v) + +end + +type mix_var = +| GVar of UF.elt +| LVar of int + +type mix_type_scheme = int * mix_var glb_typexpr + +type environment = { + env_var : mix_type_scheme Id.Map.t; + (** Type schemes of bound variables *) + env_cst : UF.elt glb_typexpr UF.t; + (** Unification state *) + env_als : UF.elt Id.Map.t ref; + (** Map user-facing type variables to unification variables *) + env_opn : bool; + (** Accept unbound type variables *) + env_rec : (KerName.t * int) Id.Map.t; + (** Recursive type definitions *) + env_str : bool; + (** True iff in strict mode *) +} + +let empty_env () = { + env_var = Id.Map.empty; + env_cst = UF.create (); + env_als = ref Id.Map.empty; + env_opn = true; + env_rec = Id.Map.empty; + env_str = true; +} + +let env_name env = + (* Generate names according to a provided environment *) + let mk num = + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + name + in + let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in + let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in + let vars = ref vars in + let rec fresh n = + let name = mk n in + if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) + else name + in + fun n -> + if UF.Map.mem n !vars then UF.Map.find n !vars + else + let ans = fresh 0 in + let () = vars := UF.Map.add n ans !vars in + ans + +let ltac2_env : environment Genintern.Store.field = + Genintern.Store.field () + +let drop_ltac2_env store = + Genintern.Store.remove store ltac2_env + +let fresh_id env = UF.fresh env.env_cst + +let get_alias {loc;v=id} env = + try Id.Map.find id env.env_als.contents + with Not_found -> + if env.env_opn then + let n = fresh_id env in + let () = env.env_als := Id.Map.add id n env.env_als.contents in + n + else user_err ?loc (str "Unbound type parameter " ++ Id.print id) + +let push_name id t env = match id with +| Anonymous -> env +| Name id -> { env with env_var = Id.Map.add id t env.env_var } + +let error_nargs_mismatch ?loc kn nargs nfound = + let cstr = Tac2env.shortest_qualid_of_constructor kn in + user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ + int nargs ++ str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let error_nparams_mismatch ?loc nargs nfound = + user_err ?loc (str "Type expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst id +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (Name id) -> GTypVar (get_alias (CAst.make ?loc id) env) +| CTypVar Anonymous -> GTypVar (fresh_id env) +| CTypRef (rel, args) -> + let (kn, nparams) = match rel with + | RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && Id.Map.mem id env.env_rec then + let (kn, n) = Id.Map.find id env.env_rec in + (Other kn, n) + else + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) + in + let (nparams, _) = Tac2env.interp_type kn in + (Other kn, nparams) + | AbsKn (Other kn) -> + let (nparams, _) = Tac2env.interp_type kn in + (Other kn, nparams) + | AbsKn (Tuple n) -> + (Tuple n, n) + in + let nargs = List.length args in + let () = + if not (Int.equal nparams nargs) then + let qid = match rel with + | RelId lid -> lid + | AbsKn (Other kn) -> shortest_qualid_of_type ?loc kn + | AbsKn (Tuple _) -> assert false + in + user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ + strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ + applied to " ++ int nargs ++ strbrk "argument(s)") + in + GTypRef (kn, List.map (fun t -> intern_type env t) args) +| CTypArrow (t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) + +let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + subst_type substf t + +let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf = function + | LVar i -> GTypVar subst.(i) + | GVar n -> GTypVar n + in + subst_type substf t + +let fresh_reftype env (kn : KerName.t or_tuple) = + let n = match kn with + | Other kn -> fst (Tac2env.interp_type kn) + | Tuple n -> n + in + let subst = Array.init n (fun _ -> fresh_id env) in + let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in + (subst, t) + +(** First-order unification algorithm *) +let is_unfoldable kn = match snd (Tac2env.interp_type kn) with +| GTydDef (Some _) -> true +| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false + +let unfold env kn args = + let (nparams, def) = Tac2env.interp_type kn in + let def = match def with + | GTydDef (Some t) -> t + | _ -> assert false + in + let args = Array.of_list args in + let subst n = args.(n) in + subst_type subst def + +(** View function, allows to ensure head normal forms *) +let rec kind env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> kind env t + end +| GTypRef (Other kn, tl) -> + if is_unfoldable kn then kind env (unfold env kn tl) else t +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +(** Normalize unification variables without unfolding type aliases *) +let rec nf env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> nf env t + end +| GTypRef (kn, tl) -> + let tl = List.map (fun t -> nf env t) tl in + GTypRef (kn, tl) +| GTypArrow (t, u) -> + let t = nf env t in + let u = nf env u in + GTypArrow (t, u) + +let pr_glbtype env t = + let t = nf env t in + let name = env_name env in + pr_glbtype name t + +exception Occur + +let rec occur_check env id t = match kind env t with +| GTypVar id' -> if UF.equal id id' then raise Occur +| GTypArrow (t1, t2) -> + let () = occur_check env id t1 in + occur_check env id t2 +| GTypRef (kn, tl) -> + List.iter (fun t -> occur_check env id t) tl + +exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr + +let unify_var env id t = match kind env t with +| GTypVar id' -> + if not (UF.equal id id') then UF.union id id' env.env_cst +| GTypArrow _ | GTypRef _ -> + try + let () = occur_check env id t in + UF.set id t env.env_cst + with Occur -> raise (CannotUnify (GTypVar id, t)) + +let eq_or_tuple eq t1 t2 = match t1, t2 with +| Tuple n1, Tuple n2 -> Int.equal n1 n2 +| Other o1, Other o2 -> eq o1 o2 +| _ -> false + +let rec unify0 env t1 t2 = match kind env t1, kind env t2 with +| GTypVar id, t | t, GTypVar id -> + unify_var env id t +| GTypArrow (t1, u1), GTypArrow (t2, u2) -> + let () = unify0 env t1 t2 in + unify0 env u1 u2 +| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> + if eq_or_tuple KerName.equal kn1 kn2 then + List.iter2 (fun t1 t2 -> unify0 env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| _ -> raise (CannotUnify (t1, t2)) + +let unify ?loc env t1 t2 = + try unify0 env t1 t2 + with CannotUnify (u1, u2) -> + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env t1 ++ + spc () ++ str "but an expression was expected of type" ++ spc () ++ pr_glbtype env t2) + +let unify_arrow ?loc env ft args = + let ft0 = ft in + let rec iter ft args is_fun = match kind env ft, args with + | t, [] -> t + | GTypArrow (t1, ft), (loc, t2) :: args -> + let () = unify ?loc env t2 t1 in + iter ft args true + | GTypVar id, (_, t) :: args -> + let ft = GTypVar (fresh_id env) in + let () = unify_var env id (GTypArrow (t, ft)) in + iter ft args true + | GTypRef _, _ :: _ -> + if is_fun then + user_err ?loc (str "This function has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is applied to too many arguments") + else + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is not a function") + in + iter ft args false + +(** Term typing *) + +let is_pure_constructor kn = + match snd (Tac2env.interp_type kn) with + | GTydAlg _ | GTydOpn -> true + | GTydRec fields -> + let is_pure (_, mut, _) = not mut in + List.for_all is_pure fields + | GTydDef _ -> assert false (** Type definitions have no constructors *) + +let rec is_value = function +| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true +| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false +| GTacCst (Tuple _, _, el) -> List.for_all is_value el +| GTacCst (_, _, []) -> true +| GTacOpn (_, el) -> List.for_all is_value el +| GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ +| GTacWth _ -> false + +let is_rec_rhs = function +| GTacFun _ -> true +| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ +| GTacSet _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacCse _ | GTacOpn _ | GTacWth _ -> false + +let rec fv_type f t accu = match t with +| GTypVar id -> f id accu +| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) +| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl + +let fv_env env = + let rec f id accu = match UF.find id env.env_cst with + | id, None -> UF.Map.add id () accu + | _, Some t -> fv_type f t accu + in + let fold_var id (_, t) accu = + let fmix id accu = match id with + | LVar _ -> accu + | GVar id -> f id accu + in + fv_type fmix t accu + in + let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in + let fold_als _ id accu = f id accu in + Id.Map.fold fold_als !(env.env_als) fv_var + +let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = + let fv = fv_env env in + let count = ref 0 in + let vars = ref UF.Map.empty in + let rec subst id = + let (id, t) = UF.find id env.env_cst in + match t with + | None -> + if UF.Map.mem id fv then GTypVar (GVar id) + else + begin try UF.Map.find id !vars + with Not_found -> + let n = !count in + let var = GTypVar (LVar n) in + let () = incr count in + let () = vars := UF.Map.add id var !vars in + var + end + | Some t -> subst_type subst t + in + let t = subst_type subst t in + (!count, t) + +let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = + let subst id = GTypVar (GVar id) in + (0, subst_type subst t) + +let warn_not_unit = + CWarnings.create ~name:"not-unit" ~category:"ltac" + (fun () -> strbrk "The following expression should have type unit.") + +let warn_redundant_clause = + CWarnings.create ~name:"redundant-clause" ~category:"ltac" + (fun () -> strbrk "The following clause is redundant.") + +let check_elt_unit loc env t = + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false + in + if not maybe_unit then warn_not_unit ?loc () + +let check_elt_empty loc env t = match kind env t with +| GTypVar _ -> + user_err ?loc (str "Cannot infer an empty type for this expression") +| GTypArrow _ | GTypRef (Tuple _, _) -> + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") +| GTypRef (Other kn, _) -> + let def = Tac2env.interp_type kn in + match def with + | _, GTydAlg { galg_constructors = [] } -> kn + | _ -> + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") + +let check_unit ?loc t = + let env = empty_env () in + (* Should not matter, t should be closed. *) + let t = fresh_type_scheme env t in + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false + in + if not maybe_unit then warn_not_unit ?loc () + +let check_redundant_clause = function +| [] -> () +| (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () + +let get_variable0 mem var = match var with +| RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && mem id then ArgVar CAst.(make ?loc:qid.CAst.loc id) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound value " ++ pr_qualid qid) + in + ArgArg kn +| AbsKn kn -> ArgArg kn + +let get_variable env var = + let mem id = Id.Map.mem id env.env_var in + get_variable0 mem var + +let get_constructor env var = match var with +| RelId qid -> + let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in + begin match c with + | Some knc -> Other knc + | None -> + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound constructor " ++ pr_qualid qid) + end +| AbsKn knc -> knc + +let get_projection var = match var with +| RelId qid -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") + in + Tac2env.interp_projection kn +| AbsKn kn -> + Tac2env.interp_projection kn + +let intern_atm env = function +| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (Other t_int, [])) +| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (Other t_string, [])) + +let invalid_pattern ?loc kn kn' = + let pr t = match t with + | Other kn' -> str "type " ++ pr_typref kn' + | Tuple n -> str "tuple of size " ++ int n + in + user_err ?loc (str "Invalid pattern, expected a pattern for " ++ + pr kn ++ str ", found a pattern for " ++ pr kn') (** FIXME *) + +(** Pattern view *) + +type glb_patexpr = +| GPatVar of Name.t +| GPatRef of ltac_constructor or_tuple * glb_patexpr list + +let rec intern_patexpr env {loc;v=pat} = match pat with +| CPatVar na -> GPatVar na +| CPatRef (qid, pl) -> + let kn = get_constructor env qid in + GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) +| CPatCnv (pat, ty) -> + user_err ?loc (str "Pattern not handled yet") + +type pattern_kind = +| PKind_empty +| PKind_variant of type_constant or_tuple +| PKind_open of type_constant +| PKind_any + +let get_pattern_kind env pl = match pl with +| [] -> PKind_empty +| p :: pl -> + let rec get_kind (p, _) pl = match intern_patexpr env p with + | GPatVar _ -> + begin match pl with + | [] -> PKind_any + | p :: pl -> get_kind p pl + end + | GPatRef (Other kn, pl) -> + let data = Tac2env.interp_constructor kn in + if Option.is_empty data.cdata_indx then PKind_open data.cdata_type + else PKind_variant (Other data.cdata_type) + | GPatRef (Tuple _, tp) -> PKind_variant (Tuple (List.length tp)) + in + get_kind p pl + +(** Internalization *) + +(** Used to generate a fresh tactic variable for pattern-expansion *) +let fresh_var avoid = + let bad id = + Id.Set.mem id avoid || + (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string "p") bad + +let add_name accu = function +| Name id -> Id.Set.add id accu +| Anonymous -> accu + +let rec ids_of_pattern accu {v=pat} = match pat with +| CPatVar Anonymous -> accu +| CPatVar (Name id) -> Id.Set.add id accu +| CPatRef (_, pl) -> + List.fold_left ids_of_pattern accu pl +| CPatCnv (pat, _) -> ids_of_pattern accu pat + +let loc_of_relid = function +| RelId {loc} -> loc +| AbsKn _ -> None + +let extract_pattern_type ({loc;v=p} as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + +(** Expand pattern: [p => t] becomes [x => match x with p => t end] *) +let expand_pattern avoid bnd = + let fold (avoid, bnd) (pat, t) = + let na, expand = match pat.v with + | CPatVar na -> + (* Don't expand variable patterns *) + na, None + | _ -> + let id = fresh_var avoid in + let qid = RelId (qualid_of_ident ?loc:pat.loc id) in + Name id, Some qid + in + let avoid = ids_of_pattern avoid pat in + let avoid = add_name avoid na in + (avoid, (na, pat, expand) :: bnd) + in + let (_, bnd) = List.fold_left fold (avoid, []) bnd in + let fold e (na, pat, expand) = match expand with + | None -> e + | Some qid -> + let loc = loc_of_relid qid in + CAst.make ?loc @@ CTacCse (CAst.make ?loc @@ CTacRef qid, [pat, e]) + in + let expand e = List.fold_left fold e bnd in + let nas = List.rev_map (fun (na, _, _) -> na) bnd in + (nas, expand) + +let is_alias env qid = match get_variable env qid with +| ArgArg (TacAlias _) -> true +| ArgVar _ | (ArgArg (TacConstant _)) -> false + +let rec intern_rec env {loc;v=e} = match e with +| CTacAtm atm -> intern_atm env atm +| CTacRef qid -> + begin match get_variable env qid with + | ArgVar {CAst.v=id} -> + let sch = Id.Map.find id env.env_var in + (GTacVar id, fresh_mix_type_scheme env sch) + | ArgArg (TacConstant kn) -> + let { Tac2env.gdata_type = sch } = + try Tac2env.interp_global kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) + in + (GTacRef kn, fresh_type_scheme env sch) + | ArgArg (TacAlias kn) -> + let e = + try Tac2env.interp_alias kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) + in + intern_rec env e + end +| CTacCst qid -> + let kn = get_constructor env qid in + intern_constructor env loc kn [] +| CTacFun (bnd, e) -> + let bnd = List.map extract_pattern_type bnd in + let map (_, t) = match t with + | None -> GTypVar (fresh_id env) + | Some t -> intern_type env t + in + let tl = List.map map bnd in + let (nas, exp) = expand_pattern (Id.Map.domain env.env_var) bnd in + let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env nas tl in + let (e, t) = intern_rec env (exp e) in + let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in + (GTacFun (nas, e), t) +| CTacApp ({loc;v=CTacCst qid}, args) -> + let kn = get_constructor env qid in + intern_constructor env loc kn args +| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> + let kn = match get_variable env qid with + | ArgArg (TacAlias kn) -> kn + | ArgVar _ | (ArgArg (TacConstant _)) -> assert false + in + let e = Tac2env.interp_alias kn in + let map arg = + (* Thunk alias arguments *) + let loc = arg.loc in + let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in + let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in + CAst.make ?loc @@ CTacFun ([var], arg) + in + let args = List.map map args in + intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) +| CTacApp (f, args) -> + let loc = f.loc in + let (f, ft) = intern_rec env f in + let fold arg (args, t) = + let loc = arg.loc in + let (arg, argt) = intern_rec env arg in + (arg :: args, (loc, argt) :: t) + in + let (args, t) = List.fold_right fold args ([], []) in + let ret = unify_arrow ?loc env ft t in + (GTacApp (f, args), ret) +| CTacLet (is_rec, el, e) -> + let map (pat, e) = + let (pat, ty) = extract_pattern_type pat in + (pat, ty, e) + in + let el = List.map map el in + let fold accu (pat, _, e) = + let ids = ids_of_pattern Id.Set.empty pat in + let common = Id.Set.inter ids accu in + if Id.Set.is_empty common then Id.Set.union ids accu + else + let id = Id.Set.choose common in + user_err ?loc:pat.loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + in + let ids = List.fold_left fold Id.Set.empty el in + if is_rec then intern_let_rec env loc ids el e + else intern_let env loc ids el e +| CTacCnv (e, tc) -> + let (e, t) = intern_rec env e in + let tc = intern_type env tc in + let () = unify ?loc env t tc in + (e, tc) +| CTacSeq (e1, e2) -> + let loc1 = e1.loc in + let (e1, t1) = intern_rec env e1 in + let (e2, t2) = intern_rec env e2 in + let () = check_elt_unit loc1 env t1 in + (GTacLet (false, [Anonymous, e1], e2), t2) +| CTacCse (e, pl) -> + intern_case env loc e pl +| CTacRec fs -> + intern_record env loc fs +| CTacPrj (e, proj) -> + let pinfo = get_projection proj in + let loc = e.loc in + let (e, t) = intern_rec env e in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (Other pinfo.pdata_type, params) in + let () = unify ?loc env t exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) +| CTacSet (e, proj, r) -> + let pinfo = get_projection proj in + let () = + if not pinfo.pdata_mutb then + let loc = match proj with + | RelId {CAst.loc} -> loc + | AbsKn _ -> None + in + user_err ?loc (str "Field is not mutable") + in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (Other pinfo.pdata_type, params) in + let e = intern_rec_with_constraint env e exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + let r = intern_rec_with_constraint env r ret in + (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) +| CTacExt (tag, arg) -> + let open Genintern in + let self ist e = + let env = match Store.get ist.extra ltac2_env with + | None -> empty_env () + | Some env -> env + in + intern_rec env e + in + let obj = interp_ml_object tag in + (* External objects do not have access to the named context because this is + not stable by dynamic semantics. *) + let genv = Global.env_of_context Environ.empty_named_context_val in + let ist = empty_glob_sign genv in + let ist = { ist with extra = Store.set ist.extra ltac2_env env } in + let arg, tpe = + if env.env_str then + let arg () = obj.ml_intern self ist arg in + Flags.with_option Ltac_plugin.Tacintern.strict_check arg () + else + obj.ml_intern self ist arg + in + let e = match arg with + | GlbVal arg -> GTacExt (tag, arg) + | GlbTacexpr e -> e + in + (e, tpe) + +and intern_rec_with_constraint env e exp = + let (er, t) = intern_rec env e in + let () = unify ?loc:e.loc env t exp in + er + +and intern_let env loc ids el e = + let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in + let fold (pat, t, e) (avoid, accu) = + let nas, exp = expand_pattern avoid [pat, t] in + let na = match nas with [x] -> x | _ -> assert false in + let avoid = List.fold_left add_name avoid nas in + (avoid, (na, exp, t, e) :: accu) + in + let (_, el) = List.fold_right fold el (avoid, []) in + let fold (na, exp, tc, e) (body, el, p) = + let (e, t) = match tc with + | None -> intern_rec env e + | Some tc -> + let tc = intern_type env tc in + (intern_rec_with_constraint env e tc, tc) + in + let t = if is_value e then abstract_var env t else monomorphic t in + (exp body, (na, e) :: el, (na, t) :: p) + in + let (e, el, p) = List.fold_right fold el (e, [], []) in + let env = List.fold_left (fun accu (na, t) -> push_name na t accu) env p in + let (e, t) = intern_rec env e in + (GTacLet (false, el, e), t) + +and intern_let_rec env loc ids el e = + let map env (pat, t, e) = + let na = match pat.v with + | CPatVar na -> na + | CPatRef _ | CPatCnv _ -> + user_err ?loc:pat.loc (str "This kind of pattern is forbidden in let-rec bindings") + in + let id = fresh_id env in + let env = push_name na (monomorphic (GTypVar id)) env in + (env, (loc, na, t, e, id)) + in + let (env, el) = List.fold_left_map map env el in + let fold (loc, na, tc, e, id) (el, tl) = + let loc_e = e.loc in + let (e, t) = intern_rec env e in + let () = + if not (is_rec_rhs e) then + user_err ?loc:loc_e (str "This kind of expression is not allowed as \ + right-hand side of a recursive binding") + in + let () = unify ?loc env t (GTypVar id) in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify ?loc env t tc + in + ((na, e) :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + let (e, t) = intern_rec env e in + (GTacLet (true, el, e), t) + +(** For now, patterns recognized by the pattern-matching compiling are limited + to depth-one where leaves are either variables or catch-all *) +and intern_case env loc e pl = + let (e', t) = intern_rec env e in + let todo ?loc () = user_err ?loc (str "Pattern not handled yet") in + match get_pattern_kind env pl with + | PKind_any -> + let (pat, b) = List.hd pl in + let na = match intern_patexpr env pat with + | GPatVar na -> na + | _ -> assert false + in + let () = check_redundant_clause (List.tl pl) in + let env = push_name na (monomorphic t) env in + let (b, tb) = intern_rec env b in + (GTacLet (false, [na, e'], b), tb) + | PKind_empty -> + let kn = check_elt_empty loc env t in + let r = fresh_id env in + (GTacCse (e', Other kn, [||], [||]), GTypVar r) + | PKind_variant kn -> + let subst, tc = fresh_reftype env kn in + let () = unify ?loc:e.loc env t tc in + let (nconst, nnonconst, arities) = match kn with + | Tuple 0 -> 1, 0, [0] + | Tuple n -> 0, 1, [n] + | Other kn -> + let (_, def) = Tac2env.interp_type kn in + let galg = match def with | GTydAlg c -> c | _ -> assert false in + let arities = List.map (fun (_, args) -> List.length args) galg.galg_constructors in + galg.galg_nconst, galg.galg_nnonconst, arities + in + let const = Array.make nconst None in + let nonconst = Array.make nnonconst None in + let ret = GTypVar (fresh_id env) in + let rec intern_branch = function + | [] -> () + | (pat, br) :: rem -> + let tbr = match pat.v with + | CPatVar (Name _) -> + let loc = pat.loc in + todo ?loc () + | CPatVar Anonymous -> + let () = check_redundant_clause rem in + let (br', brT) = intern_rec env br in + (* Fill all remaining branches *) + let fill (ncst, narg) arity = + if Int.equal arity 0 then + let () = + if Option.is_empty const.(ncst) then const.(ncst) <- Some br' + in + (succ ncst, narg) + else + let () = + if Option.is_empty nonconst.(narg) then + let ids = Array.make arity Anonymous in + nonconst.(narg) <- Some (ids, br') + in + (ncst, succ narg) + in + let _ = List.fold_left fill (0, 0) arities in + brT + | CPatRef (qid, args) -> + let loc = pat.loc in + let knc = get_constructor env qid in + let kn', index, arity = match knc with + | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) + | Other knc -> + let data = Tac2env.interp_constructor knc in + let index = Option.get data.cdata_indx in + Other data.cdata_type, index, data.cdata_args + in + let () = + if not (eq_or_tuple KerName.equal kn kn') then + invalid_pattern ?loc kn kn' + in + let get_id pat = match pat with + | {v=CPatVar na} -> na + | {loc} -> todo ?loc () + in + let ids = List.map get_id args in + let nids = List.length ids in + let nargs = List.length arity in + let () = match knc with + | Tuple n -> assert (n == nids) + | Other knc -> + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids + in + let fold env id tpe = + (* Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids arity in + let (br', brT) = intern_rec nenv br in + let () = + if List.is_empty args then + if Option.is_empty const.(index) then const.(index) <- Some br' + else warn_redundant_clause ?loc () + else + let ids = Array.of_list ids in + if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') + else warn_redundant_clause ?loc () + in + brT + | CPatCnv _ -> + user_err ?loc (str "Pattern not handled yet") + in + let () = unify ?loc:br.loc env tbr ret in + intern_branch rem + in + let () = intern_branch pl in + let map n is_const = function + | None -> + let kn = match kn with Other kn -> kn | _ -> assert false in + let cstr = pr_internal_constructor kn n is_const in + user_err ?loc (str "Unhandled match case for constructor " ++ cstr) + | Some x -> x + in + let const = Array.mapi (fun i o -> map i true o) const in + let nonconst = Array.mapi (fun i o -> map i false o) nonconst in + let ce = GTacCse (e', kn, const, nonconst) in + (ce, ret) + | PKind_open kn -> + let subst, tc = fresh_reftype env (Other kn) in + let () = unify ?loc:e.loc env t tc in + let ret = GTypVar (fresh_id env) in + let rec intern_branch map = function + | [] -> + user_err ?loc (str "Missing default case") + | (pat, br) :: rem -> + match intern_patexpr env pat with + | GPatVar na -> + let () = check_redundant_clause rem in + let nenv = push_name na (monomorphic tc) env in + let br' = intern_rec_with_constraint nenv br ret in + let def = (na, br') in + (map, def) + | GPatRef (knc, args) -> + let get = function + | GPatVar na -> na + | GPatRef _ -> + user_err ?loc (str "TODO: Unhandled match case") (* FIXME *) + in + let loc = pat.loc in + let knc = match knc with + | Other knc -> knc + | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) + in + let ids = List.map get args in + let data = Tac2env.interp_constructor knc in + let () = + if not (KerName.equal kn data.cdata_type) then + invalid_pattern ?loc (Other kn) (Other data.cdata_type) + in + let nids = List.length ids in + let nargs = List.length data.cdata_args in + let () = + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids + in + let fold env id tpe = + (* Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids data.cdata_args in + let br' = intern_rec_with_constraint nenv br ret in + let map = + if KNmap.mem knc map then + let () = warn_redundant_clause ?loc () in + map + else + KNmap.add knc (Anonymous, Array.of_list ids, br') map + in + intern_branch map rem + in + let (map, def) = intern_branch KNmap.empty pl in + (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) + +and intern_constructor env loc kn args = match kn with +| Other kn -> + let cstr = interp_constructor kn in + let nargs = List.length cstr.cdata_args in + if Int.equal nargs (List.length args) then + let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in + let targs = List.init cstr.cdata_prms (fun i -> GTypVar subst.(i)) in + let ans = GTypRef (Other cstr.cdata_type, targs) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + match cstr.cdata_indx with + | Some idx -> + (GTacCst (Other cstr.cdata_type, idx, args), ans) + | None -> + (GTacOpn (kn, args), ans) + else + error_nargs_mismatch ?loc kn nargs (List.length args) +| Tuple n -> + assert (Int.equal n (List.length args)); + let types = List.init n (fun i -> GTypVar (fresh_id env)) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + let ans = GTypRef (Tuple n, types) in + GTacCst (Tuple n, 0, args), ans + +and intern_record env loc fs = + let map (proj, e) = + let loc = match proj with + | RelId {CAst.loc} -> loc + | AbsKn _ -> None + in + let proj = get_projection proj in + (loc, proj, e) + in + let fs = List.map map fs in + let kn = match fs with + | [] -> user_err ?loc (str "Cannot infer the corresponding record type") + | (_, proj, _) :: _ -> proj.pdata_type + in + let params, typdef = match Tac2env.interp_type kn with + | n, GTydRec def -> n, def + | _ -> assert false + in + let subst = Array.init params (fun _ -> fresh_id env) in + (* Set the answer [args] imperatively *) + let args = Array.make (List.length typdef) None in + let iter (loc, pinfo, e) = + if KerName.equal kn pinfo.pdata_type then + let index = pinfo.pdata_indx in + match args.(index) with + | None -> + let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in + let e = intern_rec_with_constraint env e exp in + args.(index) <- Some e + | Some _ -> + let (name, _, _) = List.nth typdef pinfo.pdata_indx in + user_err ?loc (str "Field " ++ Id.print name ++ str " is defined \ + several times") + else + user_err ?loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ + pertain to record definition " ++ pr_typref pinfo.pdata_type) + in + let () = List.iter iter fs in + let () = match Array.findi (fun _ o -> Option.is_empty o) args with + | None -> () + | Some i -> + let (field, _, _) = List.nth typdef i in + user_err ?loc (str "Field " ++ Id.print field ++ str " is undefined") + in + let args = Array.map_to_list Option.get args in + let tparam = List.init params (fun i -> GTypVar subst.(i)) in + (GTacCst (Other kn, 0, args), GTypRef (Other kn, tparam)) + +let normalize env (count, vars) (t : UF.elt glb_typexpr) = + let get_var id = + try UF.Map.find id !vars + with Not_found -> + let () = assert env.env_opn in + let n = GTypVar !count in + let () = incr count in + let () = vars := UF.Map.add id n !vars in + n + in + let rec subst id = match UF.find id env.env_cst with + | id, None -> get_var id + | _, Some t -> subst_type subst t + in + subst_type subst t + +let intern ~strict e = + let env = empty_env () in + let env = if strict then env else { env with env_str = false } in + let (e, t) = intern_rec env e in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (e, (!count, t)) + +let intern_typedef self (ids, t) : glb_quant_typedef = + let env = { (empty_env ()) with env_rec = self } in + (* Initialize type parameters *) + let map id = get_alias id env in + let ids = List.map map ids in + let count = ref (List.length ids) in + let vars = ref UF.Map.empty in + let iter n id = vars := UF.Map.add id (GTypVar n) !vars in + let () = List.iteri iter ids in + (* Do not accept unbound type variables *) + let env = { env with env_opn = false } in + let intern t = + let t = intern_type env t in + normalize env (count, vars) t + in + let count = !count in + match t with + | CTydDef None -> (count, GTydDef None) + | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) + | CTydAlg constrs -> + let map (c, t) = (c, List.map intern t) in + let constrs = List.map map constrs in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) constrs in + let galg = { + galg_constructors = constrs; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + (count, GTydAlg galg) + | CTydRec fields -> + let map (c, mut, t) = (c, mut, intern t) in + let fields = List.map map fields in + (count, GTydRec fields) + | CTydOpn -> (count, GTydOpn) + +let intern_open_type t = + let env = empty_env () in + let t = intern_type env t in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (!count, t) + +(** Subtyping *) + +let check_subtype t1 t2 = + let env = empty_env () in + let t1 = fresh_type_scheme env t1 in + (* We build a substitution mimicking rigid variable by using dummy tuples *) + let rigid i = GTypRef (Tuple (i + 1), []) in + let (n, t2) = t2 in + let subst = Array.init n rigid in + let substf i = subst.(i) in + let t2 = subst_type substf t2 in + try unify0 env t1 t2; true with CannotUnify _ -> false + +(** Globalization *) + +let get_projection0 var = match var with +| RelId qid -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") + in + kn +| AbsKn kn -> kn + +let rec globalize ids ({loc;v=er} as e) = match er with +| CTacAtm _ -> e +| CTacRef ref -> + let mem id = Id.Set.mem id ids in + begin match get_variable0 mem ref with + | ArgVar _ -> e + | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) + end +| CTacCst qid -> + let knc = get_constructor () qid in + CAst.make ?loc @@ CTacCst (AbsKn knc) +| CTacFun (bnd, e) -> + let fold (pats, accu) pat = + let accu = ids_of_pattern accu pat in + let pat = globalize_pattern ids pat in + (pat :: pats, accu) + in + let bnd, ids = List.fold_left fold ([], ids) bnd in + let bnd = List.rev bnd in + let e = globalize ids e in + CAst.make ?loc @@ CTacFun (bnd, e) +| CTacApp (e, el) -> + let e = globalize ids e in + let el = List.map (fun e -> globalize ids e) el in + CAst.make ?loc @@ CTacApp (e, el) +| CTacLet (isrec, bnd, e) -> + let fold accu (pat, _) = ids_of_pattern accu pat in + let ext = List.fold_left fold Id.Set.empty bnd in + let eids = Id.Set.union ext ids in + let e = globalize eids e in + let map (qid, e) = + let ids = if isrec then eids else ids in + let qid = globalize_pattern ids qid in + (qid, globalize ids e) + in + let bnd = List.map map bnd in + CAst.make ?loc @@ CTacLet (isrec, bnd, e) +| CTacCnv (e, t) -> + let e = globalize ids e in + CAst.make ?loc @@ CTacCnv (e, t) +| CTacSeq (e1, e2) -> + let e1 = globalize ids e1 in + let e2 = globalize ids e2 in + CAst.make ?loc @@ CTacSeq (e1, e2) +| CTacCse (e, bl) -> + let e = globalize ids e in + let bl = List.map (fun b -> globalize_case ids b) bl in + CAst.make ?loc @@ CTacCse (e, bl) +| CTacRec r -> + let map (p, e) = + let p = get_projection0 p in + let e = globalize ids e in + (AbsKn p, e) + in + CAst.make ?loc @@ CTacRec (List.map map r) +| CTacPrj (e, p) -> + let e = globalize ids e in + let p = get_projection0 p in + CAst.make ?loc @@ CTacPrj (e, AbsKn p) +| CTacSet (e, p, e') -> + let e = globalize ids e in + let p = get_projection0 p in + let e' = globalize ids e' in + CAst.make ?loc @@ CTacSet (e, AbsKn p, e') +| CTacExt (tag, arg) -> + let arg = str (Tac2dyn.Arg.repr tag) in + CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) + +and globalize_case ids (p, e) = + (globalize_pattern ids p, globalize ids e) + +and globalize_pattern ids ({loc;v=pr} as p) = match pr with +| CPatVar _ -> p +| CPatRef (cst, pl) -> + let knc = get_constructor () cst in + let cst = AbsKn knc in + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CAst.make ?loc @@ CPatRef (cst, pl) +| CPatCnv (pat, ty) -> + let pat = globalize_pattern ids pat in + CAst.make ?loc @@ CPatCnv (pat, ty) + +(** Kernel substitution *) + +open Mod_subst + +let subst_or_tuple f subst o = match o with +| Tuple _ -> o +| Other v -> + let v' = f subst v in + if v' == v then o else Other v' + +let rec subst_type subst t = match t with +| GTypVar _ -> t +| GTypArrow (t1, t2) -> + let t1' = subst_type subst t1 in + let t2' = subst_type subst t2 in + if t1' == t1 && t2' == t2 then t + else GTypArrow (t1', t2') +| GTypRef (kn, tl) -> + let kn' = subst_or_tuple subst_kn subst kn in + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in + if kn' == kn && tl' == tl then t else GTypRef (kn', tl') + +let rec subst_expr subst e = match e with +| GTacAtm _ | GTacVar _ | GTacPrm _ -> e +| GTacRef kn -> GTacRef (subst_kn subst kn) +| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) +| GTacApp (f, args) -> + GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) +| GTacLet (r, bs, e) -> + let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in + GTacLet (r, bs, subst_expr subst e) +| GTacCst (t, n, el) as e0 -> + let t' = subst_or_tuple subst_kn subst t in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in + if t' == t && el' == el then e0 else GTacCst (t', n, el') +| GTacCse (e, ci, cse0, cse1) -> + let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in + let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in + let ci' = subst_or_tuple subst_kn subst ci in + GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> + let e' = subst_expr subst e in + let def' = subst_expr subst def in + let fold kn (self, vars, p) accu = + let kn' = subst_kn subst kn in + let p' = subst_expr subst p in + if kn' == kn && p' == p then accu + else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) + in + let br' = KNmap.fold fold br br in + if e' == e && br' == br && def' == def then e0 + else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } +| GTacPrj (kn, e, p) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) +| GTacSet (kn, e, p, r) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + let r' = subst_expr subst r in + if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') +| GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + let arg' = tpe.ml_subst subst arg in + if arg' == arg then e else GTacExt (tag, arg') +| GTacOpn (kn, el) as e0 -> + let kn' = subst_kn subst kn in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in + if kn' == kn && el' == el then e0 else GTacOpn (kn', el') + +let subst_typedef subst e = match e with +| GTydDef t -> + let t' = Option.Smart.map (fun t -> subst_type subst t) t in + if t' == t then e else GTydDef t' +| GTydAlg galg -> + let map (c, tl as p) = + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in + if tl' == tl then p else (c, tl') + in + let constrs' = List.Smart.map map galg.galg_constructors in + if constrs' == galg.galg_constructors then e + else GTydAlg { galg with galg_constructors = constrs' } +| GTydRec fields -> + let map (c, mut, t as p) = + let t' = subst_type subst t in + if t' == t then p else (c, mut, t') + in + let fields' = List.Smart.map map fields in + if fields' == fields then e else GTydRec fields' +| GTydOpn -> GTydOpn + +let subst_quant_typedef subst (prm, def as qdef) = + let def' = subst_typedef subst def in + if def' == def then qdef else (prm, def') + +let subst_type_scheme subst (prm, t as sch) = + let t' = subst_type subst t in + if t' == t then sch else (prm, t') + +let subst_or_relid subst ref = match ref with +| RelId _ -> ref +| AbsKn kn -> + let kn' = subst_or_tuple subst_kn subst kn in + if kn' == kn then ref else AbsKn kn' + +let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with +| CTypVar _ -> t +| CTypArrow (t1, t2) -> + let t1' = subst_rawtype subst t1 in + let t2' = subst_rawtype subst t2 in + if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') +| CTypRef (ref, tl) -> + let ref' = subst_or_relid subst ref in + let tl' = List.Smart.map (fun t -> subst_rawtype subst t) tl in + if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') + +let subst_tacref subst ref = match ref with +| RelId _ -> ref +| AbsKn (TacConstant kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstant kn') +| AbsKn (TacAlias kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacAlias kn') + +let subst_projection subst prj = match prj with +| RelId _ -> prj +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then prj else AbsKn kn' + +let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with +| CPatVar _ -> p +| CPatRef (c, pl) -> + let pl' = List.Smart.map (fun p -> subst_rawpattern subst p) pl in + let c' = subst_or_relid subst c in + if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') +| CPatCnv (pat, ty) -> + let pat' = subst_rawpattern subst pat in + let ty' = subst_rawtype subst ty in + if pat' == pat && ty' == ty then p else CAst.make ?loc @@ CPatCnv (pat', ty') + +(** Used for notations *) +let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with +| CTacAtm _ -> t +| CTacRef ref -> + let ref' = subst_tacref subst ref in + if ref' == ref then t else CAst.make ?loc @@ CTacRef ref' +| CTacCst ref -> + let ref' = subst_or_relid subst ref in + if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' +| CTacFun (bnd, e) -> + let map pat = subst_rawpattern subst pat in + let bnd' = List.Smart.map map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') +| CTacApp (e, el) -> + let e' = subst_rawexpr subst e in + let el' = List.Smart.map (fun e -> subst_rawexpr subst e) el in + if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') +| CTacLet (isrec, bnd, e) -> + let map (na, e as p) = + let na' = subst_rawpattern subst na in + let e' = subst_rawexpr subst e in + if na' == na && e' == e then p else (na', e') + in + let bnd' = List.Smart.map map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') +| CTacCnv (e, c) -> + let e' = subst_rawexpr subst e in + let c' = subst_rawtype subst c in + if c' == c && e' == e then t else CAst.make ?loc @@ CTacCnv (e', c') +| CTacSeq (e1, e2) -> + let e1' = subst_rawexpr subst e1 in + let e2' = subst_rawexpr subst e2 in + if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') +| CTacCse (e, bl) -> + let map (p, e as x) = + let p' = subst_rawpattern subst p in + let e' = subst_rawexpr subst e in + if p' == p && e' == e then x else (p', e') + in + let e' = subst_rawexpr subst e in + let bl' = List.Smart.map map bl in + if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') +| CTacRec el -> + let map (prj, e as p) = + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then p else (prj', e') + in + let el' = List.Smart.map map el in + if el' == el then t else CAst.make ?loc @@ CTacRec el' +| CTacPrj (e, prj) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then t else CAst.make ?loc @@ CTacPrj (e', prj') +| CTacSet (e, prj, r) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + let r' = subst_rawexpr subst r in + if prj' == prj && e' == e && r' == r then t else CAst.make ?loc @@ CTacSet (e', prj', r') +| CTacExt _ -> assert false (** Should not be generated by globalization *) + +(** Registering *) + +let () = + let open Genintern in + let intern ist tac = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let loc = tac.loc in + let (tac, t) = intern_rec env tac in + let () = check_elt_unit loc env t in + (ist, tac) + in + Genintern.register_intern0 wit_ltac2 intern +let () = Genintern.register_subst0 wit_ltac2 subst_expr + +let () = + let open Genintern in + let intern ist (loc, id) = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let t = + try Id.Map.find id env.env_var + with Not_found -> + CErrors.user_err ?loc (str "Unbound value " ++ Id.print id) + in + let t = fresh_mix_type_scheme env t in + let () = unify ?loc env t (GTypRef (Other t_constr, [])) in + (ist, id) + in + Genintern.register_intern0 wit_ltac2_quotation intern + +let () = Genintern.register_subst0 wit_ltac2_quotation (fun _ id -> id) diff --git a/vendor/Ltac2/src/tac2intern.mli b/vendor/Ltac2/src/tac2intern.mli new file mode 100644 index 0000000000..d646b5cda5 --- /dev/null +++ b/vendor/Ltac2/src/tac2intern.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_tacexpr -> glb_tacexpr * type_scheme +val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef +val intern_open_type : raw_typexpr -> type_scheme + +(** Check that a term is a value. Only values are safe to marshall between + processes. *) +val is_value : glb_tacexpr -> bool +val check_unit : ?loc:Loc.t -> type_scheme -> unit + +val check_subtype : type_scheme -> type_scheme -> bool +(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] + also have type [t2]. *) + +val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr +val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr +val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef +val subst_type_scheme : substitution -> type_scheme -> type_scheme + +val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr + +(** {5 Notations} *) + +val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr +(** Replaces all qualified identifiers by their corresponding kernel name. The + set represents bound variables in the context. *) + +(** Errors *) + +val error_nargs_mismatch : ?loc:Loc.t -> ltac_constructor -> int -> int -> 'a +val error_nparams_mismatch : ?loc:Loc.t -> int -> int -> 'a + +(** Misc *) + +val drop_ltac2_env : Genintern.Store.t -> Genintern.Store.t diff --git a/vendor/Ltac2/src/tac2interp.ml b/vendor/Ltac2/src/tac2interp.ml new file mode 100644 index 0000000000..b0f8083aeb --- /dev/null +++ b/vendor/Ltac2/src/tac2interp.ml @@ -0,0 +1,227 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* >= fun sigma -> + match Evd.Store.get (Evd.get_extra_data sigma) backtrace with + | None -> Proofview.tclUNIT [] + | Some bt -> Proofview.tclUNIT bt + +let set_backtrace bt = + Proofview.tclEVARMAP >>= fun sigma -> + let store = Evd.get_extra_data sigma in + let store = Evd.Store.set store backtrace bt in + let sigma = Evd.set_extra_data store sigma in + Proofview.Unsafe.tclEVARS sigma + +let with_frame frame tac = + if !print_ltac2_backtrace then + get_backtrace >>= fun bt -> + set_backtrace (frame :: bt) >>= fun () -> + tac >>= fun ans -> + set_backtrace bt >>= fun () -> + Proofview.tclUNIT ans + else tac + +type environment = Tac2env.environment = { + env_ist : valexpr Id.Map.t; +} + +let empty_environment = { + env_ist = Id.Map.empty; +} + +type closure = { + mutable clos_env : valexpr Id.Map.t; + (** Mutable so that we can implement recursive functions imperatively *) + clos_var : Name.t list; + (** Bound variables *) + clos_exp : glb_tacexpr; + (** Body *) + clos_ref : ltac_constant option; + (** Global constant from which the closure originates *) +} + +let push_name ist id v = match id with +| Anonymous -> ist +| Name id -> { env_ist = Id.Map.add id v ist.env_ist } + +let get_var ist id = + try Id.Map.find id ist.env_ist with Not_found -> + anomaly (str "Unbound variable " ++ Id.print id) + +let get_ref ist kn = + try + let data = Tac2env.interp_global kn in + data.Tac2env.gdata_expr + with Not_found -> + anomaly (str "Unbound reference" ++ KerName.print kn) + +let return = Proofview.tclUNIT + +let rec interp (ist : environment) = function +| GTacAtm (AtmInt n) -> return (Tac2ffi.of_int n) +| GTacAtm (AtmStr s) -> return (Tac2ffi.of_string (Bytes.of_string s)) +| GTacVar id -> return (get_var ist id) +| GTacRef kn -> + let data = get_ref ist kn in + return (eval_pure (Some kn) data) +| GTacFun (ids, e) -> + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in + let f = interp_app cls in + return (Tac2ffi.of_closure f) +| GTacApp (f, args) -> + interp ist f >>= fun f -> + Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> + Tac2ffi.apply (Tac2ffi.to_closure f) args +| GTacLet (false, el, e) -> + let fold accu (na, e) = + interp ist e >>= fun e -> + return (push_name accu na e) + in + Proofview.Monad.List.fold_left fold ist el >>= fun ist -> + interp ist e +| GTacLet (true, el, e) -> + let map (na, e) = match e with + | GTacFun (ids, e) -> + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in + let f = Tac2ffi.of_closure (interp_app cls) in + na, cls, f + | _ -> anomaly (str "Ill-formed recursive function") + in + let fixs = List.map map el in + let fold accu (na, _, cls) = match na with + | Anonymous -> accu + | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } + in + let ist = List.fold_left fold ist fixs in + (* Hack to make a cycle imperatively in the environment *) + let iter (_, e, _) = e.clos_env <- ist.env_ist in + let () = List.iter iter fixs in + interp ist e +| GTacCst (_, n, []) -> return (Valexpr.make_int n) +| GTacCst (_, n, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (Valexpr.make_block n (Array.of_list el)) +| GTacCse (e, _, cse0, cse1) -> + interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> + interp ist e >>= fun e -> interp_with ist e cse def +| GTacPrj (_, e, p) -> + interp ist e >>= fun e -> interp_proj ist e p +| GTacSet (_, e, p, r) -> + interp ist e >>= fun e -> + interp ist r >>= fun r -> + interp_set ist e p r +| GTacOpn (kn, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (Tac2ffi.of_open (kn, Array.of_list el)) +| GTacPrm (ml, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) +| GTacExt (tag, e) -> + let tpe = Tac2env.interp_ml_object tag in + with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) + +and interp_app f = + let ans = fun args -> + let { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } = f in + let frame = match kn with + | None -> FrAnon e + | Some kn -> FrLtac kn + in + let ist = { env_ist = ist } in + let ist = List.fold_left2 push_name ist ids args in + with_frame frame (interp ist e) + in + Tac2ffi.abstract (List.length f.clos_var) ans + +and interp_case ist e cse0 cse1 = + if Valexpr.is_int e then + interp ist cse0.(Tac2ffi.to_int e) + else + let (n, args) = Tac2ffi.to_block e in + let (ids, e) = cse1.(n) in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist e + +and interp_with ist e cse def = + let (kn, args) = Tac2ffi.to_open e in + let br = try Some (KNmap.find kn cse) with Not_found -> None in + begin match br with + | None -> + let (self, def) = def in + let ist = push_name ist self e in + interp ist def + | Some (self, ids, p) -> + let ist = push_name ist self e in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist p + end + +and interp_proj ist e p = + return (Valexpr.field e p) + +and interp_set ist e p r = + let () = Valexpr.set_field e p r in + return (Valexpr.make_int 0) + +and eval_pure kn = function +| GTacAtm (AtmInt n) -> Valexpr.make_int n +| GTacRef kn -> + let { Tac2env.gdata_expr = e } = + try Tac2env.interp_global kn + with Not_found -> assert false + in + eval_pure (Some kn) e +| GTacFun (na, e) -> + let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in + let f = interp_app cls in + Tac2ffi.of_closure f +| GTacCst (_, n, []) -> Valexpr.make_int n +| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) +| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) +| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> + anomaly (Pp.str "Term is not a syntactical value") + +and eval_unnamed e = eval_pure None e + + +(** Cross-boundary hacks. *) + +open Geninterp + +let val_env : environment Val.typ = Val.create "ltac2:env" +let env_ref = Id.of_string_soft "@@ltac2_env@@" + +let extract_env (Val.Dyn (tag, v)) : environment = +match Val.eq tag val_env with +| None -> assert false +| Some Refl -> v + +let get_env ist = + try extract_env (Id.Map.find env_ref ist) + with Not_found -> empty_environment + +let set_env env ist = + Id.Map.add env_ref (Val.Dyn (val_env, env)) ist diff --git a/vendor/Ltac2/src/tac2interp.mli b/vendor/Ltac2/src/tac2interp.mli new file mode 100644 index 0000000000..21fdcd03af --- /dev/null +++ b/vendor/Ltac2/src/tac2interp.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glb_tacexpr -> valexpr Proofview.tactic + +(* val interp_app : closure -> ml_tactic *) + +(** {5 Cross-boundary encodings} *) + +val get_env : Ltac_pretype.unbound_ltac_var_map -> environment +val set_env : environment -> Ltac_pretype.unbound_ltac_var_map -> Ltac_pretype.unbound_ltac_var_map + +(** {5 Exceptions} *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) + +(** {5 Backtrace} *) + +val get_backtrace : backtrace Proofview.tactic + +val with_frame : frame -> 'a Proofview.tactic -> 'a Proofview.tactic + +val print_ltac2_backtrace : bool ref diff --git a/vendor/Ltac2/src/tac2match.ml b/vendor/Ltac2/src/tac2match.ml new file mode 100644 index 0000000000..c9e549d47e --- /dev/null +++ b/vendor/Ltac2/src/tac2match.ml @@ -0,0 +1,232 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + Id.Map.merge merge s1 s2 + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> result -> 'r tac) -> result -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + } in + let eval x ctx = Proofview.tclUNIT (x, ctx) in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + let put_subst subst : unit m = + let s = { subst } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** {6 Pattern-matching} *) + + let pattern_match_term pat term = + match pat with + | MatchPattern p -> + begin + try + put_subst (Constr_matching.matches E.env E.sigma p term) <*> + return None + with Constr_matching.PatternMatchingFailure -> fail + end + | MatchContext p -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub = (_, subst); m_ctx }, s) -> + let nctx = { subst } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | Some nctx -> Proofview.tclOR (k (Some (Lazy.force m_ctx)) nctx) (fun e -> (map s e).stream k ctx) + } + in + map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error + + let hyp_match_type pat hyps = + pick hyps >>= fun decl -> + let id = NamedDecl.get_id decl in + pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> + return (id, ctx) + + let _hyp_match_body_and_type bodypat typepat hyps = + pick hyps >>= function + | LocalDef (id,body,hyp) -> + pattern_match_term bodypat body >>= fun ctx_body -> + pattern_match_term typepat hyp >>= fun ctx_typ -> + return (id, ctx_body, ctx_typ) + | LocalAssum (id,hyp) -> fail + + let hyp_match pat hyps = + match pat with + | typepat -> + hyp_match_type typepat hyps +(* | Def ((_,hypname),bodypat,typepat) -> *) +(* hyp_match_body_and_type hypname bodypat typepat hyps *) + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps accu = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun (matched_hyp, hyp_ctx) -> + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in + let hyps = CList.remove_first select_matched_hyp hyps in + hyp_pattern_list_match pats hyps ((matched_hyp, hyp_ctx) :: accu) + | [] -> return accu + + let rule_match_goal hyps concl = function + | (hyppats,conclpat) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term conclpat concl >>= fun ctx_concl -> + hyp_pattern_list_match hyppats hyps [] >>= fun hyps -> + return (hyps, ctx_concl) + +end + +let match_goal env sigma concl ~rev rule = + let open Proofview.Notations in + let hyps = EConstr.named_context env in + let hyps = if rev then List.rev hyps else hyps in + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.rule_match_goal hyps concl rule) >>= fun ((hyps, ctx_concl), subst) -> + Proofview.tclUNIT (hyps, ctx_concl, subst.subst) diff --git a/vendor/Ltac2/src/tac2match.mli b/vendor/Ltac2/src/tac2match.mli new file mode 100644 index 0000000000..c82c40d238 --- /dev/null +++ b/vendor/Ltac2/src/tac2match.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Evd.evar_map -> + constr -> + rev:bool -> + match_rule -> + ((Id.t * context option) list * (* List of hypotheses matching: name + context *) + context option * (* Context for conclusion *) + Ltac_pretype.patvar_map (* Pattern variable substitution *)) Proofview.tactic diff --git a/vendor/Ltac2/src/tac2print.ml b/vendor/Ltac2/src/tac2print.ml new file mode 100644 index 0000000000..f4cb290265 --- /dev/null +++ b/vendor/Ltac2/src/tac2print.ml @@ -0,0 +1,488 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* str "'" ++ str (pr n) + | GTypRef (Other kn, []) -> pr_typref kn + | GTypRef (Other kn, [t]) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (pr_glbtype T1 t ++ spc () ++ pr_typref kn) + | GTypRef (Other kn, tl) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) + | GTypArrow (t1, t2) -> + let paren = match lvl with + | T5_r -> fun x -> x + | T5_l | T2 | T1 | T0 -> paren + in + paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) + | GTypRef (Tuple 0, []) -> + Libnames.pr_qualid (Tac2env.shortest_qualid_of_type t_unit) + | GTypRef (Tuple _, tl) -> + let paren = match lvl with + | T5_r | T5_l -> fun x -> x + | T2 | T1 | T0 -> paren + in + paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) + in + hov 0 (pr_glbtype lvl c) + +let pr_glbtype pr c = pr_glbtype_gen pr T5_r c + +let int_name () = + let vars = ref Int.Map.empty in + fun n -> + if Int.Map.mem n !vars then Int.Map.find n !vars + else + let num = Int.Map.cardinal !vars in + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + let () = vars := Int.Map.add n name !vars in + name + +(** Term printing *) + +let pr_constructor kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_constructor kn) + +let pr_projection kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) + +type exp_level = Tac2expr.exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +let pr_atom = function +| AtmInt n -> Pp.int n +| AtmStr s -> qstring s + +let pr_name = function +| Name id -> Id.print id +| Anonymous -> str "_" + +let find_constructor n empty def = + let rec find n = function + | [] -> assert false + | (id, []) as ans :: rem -> + if empty then + if Int.equal n 0 then ans + else find (pred n) rem + else find n rem + | (id, _ :: _) as ans :: rem -> + if not empty then + if Int.equal n 0 then ans + else find (pred n) rem + else find n rem + in + find n def + +let pr_internal_constructor tpe n is_const = + let data = match Tac2env.interp_type tpe with + | (_, GTydAlg data) -> data + | _ -> assert false + in + let (id, _) = find_constructor n is_const data.galg_constructors in + let kn = change_kn_label tpe id in + pr_constructor kn + +let order_branches cbr nbr def = + let rec order cidx nidx def = match def with + | [] -> [] + | (id, []) :: rem -> + let ans = order (succ cidx) nidx rem in + (id, [], cbr.(cidx)) :: ans + | (id, _ :: _) :: rem -> + let ans = order cidx (succ nidx) rem in + let (vars, e) = nbr.(nidx) in + (id, Array.to_list vars, e) :: ans + in + order 0 0 def + +let pr_glbexpr_gen lvl c = + let rec pr_glbexpr lvl = function + | GTacAtm atm -> pr_atom atm + | GTacVar id -> Id.print id + | GTacRef gr -> + let qid = shortest_qualid_of_ltac (TacConstant gr) in + Libnames.pr_qualid qid + | GTacFun (nas, c) -> + let nas = pr_sequence pr_name nas in + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + paren (hov 0 (hov 2 (str "fun" ++ spc () ++ nas) ++ spc () ++ str "=>" ++ spc () ++ + pr_glbexpr E5 c)) + | GTacApp (c, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (hov 2 (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) + | GTacLet (mut, bnd, e) -> + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + let mut = if mut then str "rec" ++ spc () else mt () in + let pr_bnd (na, e) = + pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () + in + let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in + paren (hv 0 (hov 2 (str "let" ++ spc () ++ mut ++ bnd ++ str "in") ++ spc () ++ pr_glbexpr E5 e)) + | GTacCst (Tuple 0, _, _) -> str "()" + | GTacCst (Tuple _, _, cl) -> + let paren = match lvl with + | E0 | E1 -> paren + | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) + | GTacCst (Other tpe, n, cl) -> + pr_applied_constructor lvl tpe n cl + | GTacCse (e, info, cst_br, ncst_br) -> + let e = pr_glbexpr E5 e in + let br = match info with + | Other kn -> + let def = match Tac2env.interp_type kn with + | _, GTydAlg { galg_constructors = def } -> def + | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false + in + let br = order_branches cst_br ncst_br def in + let pr_branch (cstr, vars, p) = + let cstr = change_kn_label kn cstr in + let cstr = pr_constructor cstr in + let vars = match vars with + | [] -> mt () + | _ -> spc () ++ pr_sequence pr_name vars + in + hov 4 (str "|" ++ spc () ++ hov 0 (cstr ++ vars ++ spc () ++ str "=>") ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + prlist pr_branch br + | Tuple n -> + let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in + let p = pr_glbexpr E5 p in + let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in + hov 4 (str "|" ++ spc () ++ hov 0 (paren vars ++ spc () ++ str "=>") ++ spc () ++ p) + in + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ spc () ++ str "end") + | GTacWth wth -> + let e = pr_glbexpr E5 wth.opn_match in + let pr_pattern c self vars p = + let self = match self with + | Anonymous -> mt () + | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id + in + hov 4 (str "|" ++ spc () ++ hov 0 (c ++ vars ++ self ++ spc () ++ str "=>") ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + let pr_branch (cstr, (self, vars, p)) = + let cstr = pr_constructor cstr in + let vars = match Array.to_list vars with + | [] -> mt () + | vars -> spc () ++ pr_sequence pr_name vars + in + pr_pattern cstr self vars p + in + let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in + let (def_as, def_p) = wth.opn_default in + let def = pr_pattern (str "_") def_as (mt ()) def_p in + let br = br ++ def in + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ str "end") + | GTacPrj (kn, e, n) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + hov 0 (e ++ str "." ++ paren proj) + | GTacSet (kn, e, n, r) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + let r = pr_glbexpr E1 r in + hov 0 (e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r) + | GTacOpn (kn, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let c = pr_constructor kn in + paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) + | GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) + | GTacPrm (prm, args) -> + let args = match args with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args + in + hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ + qstring prm.mltac_tactic ++ args) + and pr_applied_constructor lvl tpe n cl = + let _, data = Tac2env.interp_type tpe in + if KerName.equal tpe t_list then + let rec factorize accu = function + | GTacCst (_, 0, []) -> accu, None + | GTacCst (_, 0, [e; l]) -> factorize (e :: accu) l + | e -> accu, Some e + in + let l, e = factorize [] (GTacCst (Other tpe, n, cl)) in + match e with + | None -> + let pr e = pr_glbexpr E4 e in + hov 2 (str "[" ++ prlist_with_sep pr_semicolon pr (List.rev l) ++ str "]") + | Some e -> + let paren = match lvl with + | E0 | E1 | E2 -> paren + | E3 | E4 | E5 -> fun x -> x + in + let pr e = pr_glbexpr E1 e in + let pr_cons () = spc () ++ str "::" ++ spc () in + paren (hov 2 (prlist_with_sep pr_cons pr (List.rev (e :: l)))) + else match data with + | GTydAlg def -> + let paren = match lvl with + | E0 -> + if List.is_empty cl then fun x -> x else paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let cstr = pr_internal_constructor tpe n (List.is_empty cl) in + let cl = match cl with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl + in + paren (hov 2 (cstr ++ cl)) + | GTydRec def -> + let args = List.combine def cl in + let pr_arg ((id, _, _), arg) = + let kn = change_kn_label tpe id in + pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg + in + let args = prlist_with_sep pr_semicolon pr_arg args in + hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") + | (GTydDef _ | GTydOpn) -> assert false + in + hov 0 (pr_glbexpr lvl c) + + + +let pr_glbexpr c = + pr_glbexpr_gen E5 c + +(** Toplevel printers *) + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst.(id) +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let unfold kn args = + let (nparams, def) = Tac2env.interp_type kn in + match def with + | GTydDef (Some def) -> + let args = Array.of_list args in + Some (subst_type args def) + | _ -> None + +let rec kind t = match t with +| GTypVar id -> GTypVar id +| GTypRef (Other kn, tl) -> + begin match unfold kn tl with + | None -> t + | Some t -> kind t + end +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +let printers = ref KNmap.empty + +let register_val_printer kn pr = + printers := KNmap.add kn pr !printers + +open Tac2ffi + +let rec pr_valexpr env sigma v t = match kind t with +| GTypVar _ -> str "" +| GTypRef (Other kn, params) -> + let pr = try Some (KNmap.find kn !printers) with Not_found -> None in + begin match pr with + | Some pr -> pr.val_printer env sigma v params + | None -> + let n, repr = Tac2env.interp_type kn in + if KerName.equal kn t_list then + pr_val_list env sigma (to_list (fun v -> repr_to valexpr v) v) (List.hd params) + else match repr with + | GTydDef None -> str "" + | GTydDef (Some _) -> + (* Shouldn't happen thanks to kind *) + assert false + | GTydAlg alg -> + if Valexpr.is_int v then + pr_internal_constructor kn (Tac2ffi.to_int v) true + else + let (n, args) = Tac2ffi.to_block v in + let (id, tpe) = find_constructor n false alg.galg_constructors in + let knc = change_kn_label kn id in + let args = pr_constrargs env sigma params args tpe in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + | GTydRec rcd -> + let (_, args) = Tac2ffi.to_block v in + pr_record env sigma params args rcd + | GTydOpn -> + begin match Tac2ffi.to_open v with + | (knc, [||]) -> pr_constructor knc + | (knc, args) -> + let data = Tac2env.interp_constructor knc in + let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + end + end +| GTypArrow _ -> str "" +| GTypRef (Tuple 0, []) -> str "()" +| GTypRef (Tuple _, tl) -> + let blk = Array.to_list (snd (to_block v)) in + if List.length blk == List.length tl then + let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in + hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") + else + str "" + +and pr_constrargs env sigma params args tpe = + let subst = Array.of_list params in + let tpe = List.map (fun t -> subst_type subst t) tpe in + let args = Array.to_list args in + let args = List.combine args tpe in + prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args + +and pr_record env sigma params args rcd = + let subst = Array.of_list params in + let map (id, _, tpe) = (id, subst_type subst tpe) in + let rcd = List.map map rcd in + let args = Array.to_list args in + let fields = List.combine rcd args in + let pr_field ((id, t), arg) = + Id.print id ++ spc () ++ str ":=" ++ spc () ++ pr_valexpr env sigma arg t + in + str "{" ++ spc () ++ prlist_with_sep pr_semicolon pr_field fields ++ spc () ++ str "}" + +and pr_val_list env sigma args tpe = + let pr v = pr_valexpr env sigma v tpe in + str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" + +let register_init n f = + let kn = KerName.make Tac2env.coq_prefix (Label.make n) in + register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } + +let () = register_init "int" begin fun _ _ n -> + let n = to_int n in + Pp.int n +end + +let () = register_init "string" begin fun _ _ s -> + let s = to_string s in + Pp.quote (str (Bytes.to_string s)) +end + +let () = register_init "ident" begin fun _ _ id -> + let id = to_ident id in + str "@" ++ Id.print id +end + +let () = register_init "constr" begin fun env sigma c -> + let c = to_constr c in + let c = try Printer.pr_leconstr_env env sigma c with _ -> str "..." in + str "constr:(" ++ c ++ str ")" +end + +let () = register_init "pattern" begin fun env sigma c -> + let c = to_pattern c in + let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in + str "pattern:(" ++ c ++ str ")" +end + +let () = register_init "message" begin fun _ _ pp -> + str "message:(" ++ to_pp pp ++ str ")" +end + +let () = register_init "err" begin fun _ _ e -> + let e = to_ext val_exn e in + let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in + str "err:(" ++ CErrors.print_no_report e ++ str ")" +end + +let () = + let kn = KerName.make Tac2env.coq_prefix (Label.make "array") in + let val_printer env sigma v arg = match arg with + | [arg] -> + let (_, v) = to_block v in + str "[|" ++ spc () ++ + prvect_with_sep pr_semicolon (fun a -> pr_valexpr env sigma a arg) v ++ + spc () ++ str "|]" + | _ -> assert false + in + register_val_printer kn { val_printer } diff --git a/vendor/Ltac2/src/tac2print.mli b/vendor/Ltac2/src/tac2print.mli new file mode 100644 index 0000000000..9b9db2937d --- /dev/null +++ b/vendor/Ltac2/src/tac2print.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Pp.t +val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> Pp.t +val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t + +(** {5 Printing expressions} *) + +val pr_constructor : ltac_constructor -> Pp.t +val pr_internal_constructor : type_constant -> int -> bool -> Pp.t +val pr_projection : ltac_projection -> Pp.t +val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t +val pr_glbexpr : glb_tacexpr -> Pp.t + +(** {5 Printing values}*) + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +val register_val_printer : type_constant -> val_printer -> unit + +val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp.t + +(** {5 Utilities} *) + +val int_name : unit -> (int -> string) +(** Create a function that give names to integers. The names are generated on + the fly, in the order they are encountered. *) diff --git a/vendor/Ltac2/src/tac2qexpr.mli b/vendor/Ltac2/src/tac2qexpr.mli new file mode 100644 index 0000000000..400ab1a092 --- /dev/null +++ b/vendor/Ltac2/src/tac2qexpr.mli @@ -0,0 +1,173 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0)) +| [e] -> e +| el -> + let len = List.length el in + CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) + +let of_int {loc;v=n} = + CAst.make ?loc @@ CTacAtm (AtmInt n) + +let of_option ?loc f opt = match opt with +| None -> constructor ?loc (coq_core "None") [] +| Some e -> constructor ?loc (coq_core "Some") [f e] + +let inj_wit ?loc wit x = + CAst.make ?loc @@ CTacExt (wit, x) + +let of_variable {loc;v=id} = + let qid = Libnames.qualid_of_ident ?loc id in + if Tac2env.is_constructor qid then + CErrors.user_err ?loc (str "Invalid identifier") + else CAst.make ?loc @@ CTacRef (RelId qid) + +let of_anti f = function +| QExpr x -> f x +| QAnti id -> of_variable id + +let of_ident {loc;v=id} = inj_wit ?loc wit_ident id + +let of_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc wit_constr c + +let of_open_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc wit_open_constr c + +let of_bool ?loc b = + let c = if b then coq_core "true" else coq_core "false" in + constructor ?loc c [] + +let rec of_list ?loc f = function +| [] -> constructor (coq_core "[]") [] +| e :: l -> + constructor ?loc (coq_core "::") [f e; of_list ?loc f l] + +let of_qhyp {loc;v=h} = match h with +| QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] +| QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] + +let of_bindings {loc;v=b} = match b with +| QNoBindings -> + std_constructor ?loc "NoBindings" [] +| QImplicitBindings tl -> + std_constructor ?loc "ImplicitBindings" [of_list ?loc of_open_constr tl] +| QExplicitBindings tl -> + let map e = of_pair (fun q -> of_anti of_qhyp q) of_open_constr e in + std_constructor ?loc "ExplicitBindings" [of_list ?loc map tl] + +let of_constr_with_bindings c = of_pair of_open_constr of_bindings c + +let rec of_intro_pattern {loc;v=pat} = match pat with +| QIntroForthcoming b -> + std_constructor ?loc "IntroForthcoming" [of_bool b] +| QIntroNaming iname -> + std_constructor ?loc "IntroNaming" [of_intro_pattern_naming iname] +| QIntroAction iact -> + std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] + +and of_intro_pattern_naming {loc;v=pat} = match pat with +| QIntroIdentifier id -> + std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] +| QIntroFresh id -> + std_constructor ?loc "IntroFresh" [of_anti of_ident id] +| QIntroAnonymous -> + std_constructor ?loc "IntroAnonymous" [] + +and of_intro_pattern_action {loc;v=pat} = match pat with +| QIntroWildcard -> + std_constructor ?loc "IntroWildcard" [] +| QIntroOrAndPattern pat -> + std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern pat] +| QIntroInjection il -> + std_constructor ?loc "IntroInjection" [of_intro_patterns il] +| QIntroRewrite b -> + std_constructor ?loc "IntroRewrite" [of_bool ?loc b] + +and of_or_and_intro_pattern {loc;v=pat} = match pat with +| QIntroOrPattern ill -> + std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] +| QIntroAndPattern il -> + std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] + +and of_intro_patterns {loc;v=l} = + of_list ?loc of_intro_pattern l + +let of_hyp_location_flag ?loc = function +| Locus.InHyp -> std_constructor ?loc "InHyp" [] +| Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] +| Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] + +let of_occurrences {loc;v=occ} = match occ with +| QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] +| QAllOccurrencesBut occs -> + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in + std_constructor ?loc "AllOccurrencesBut" [occs] +| QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] +| QOnlyOccurrences occs -> + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in + std_constructor ?loc "OnlyOccurrences" [occs] + +let of_hyp_location ?loc ((occs, id), flag) = + of_tuple ?loc [ + of_anti of_ident id; + of_occurrences occs; + of_hyp_location_flag ?loc flag; + ] + +let of_clause {loc;v=cl} = + let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in + let concl = of_occurrences cl.q_concl_occs in + CAst.make ?loc @@ CTacRec ([ + std_proj "on_hyps", hyps; + std_proj "on_concl", concl; + ]) + +let of_destruction_arg {loc;v=arg} = match arg with +| QElimOnConstr c -> + let arg = thunk (of_constr_with_bindings c) in + std_constructor ?loc "ElimOnConstr" [arg] +| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] +| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] + +let of_induction_clause {loc;v=cl} = + let arg = of_destruction_arg cl.indcl_arg in + let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in + let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in + let in_ = of_option ?loc of_clause cl.indcl_in in + CAst.make ?loc @@ CTacRec ([ + std_proj "indcl_arg", arg; + std_proj "indcl_eqn", eqn; + std_proj "indcl_as", as_; + std_proj "indcl_in", in_; + ]) + +let check_pattern_id ?loc id = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) + +let pattern_vars pat = + let rec aux () accu pat = match pat.CAst.v with + | Constrexpr.CPatVar id + | Constrexpr.CEvar (id, []) -> + let () = check_pattern_id ?loc:pat.CAst.loc id in + Id.Set.add id accu + | _ -> + Constrexpr_ops.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat + in + aux () Id.Set.empty pat + +let abstract_vars loc vars tac = + let get_name = function Name id -> Some id | Anonymous -> None in + let def = try Some (List.find_map get_name vars) with Not_found -> None in + let na, tac = match def with + | None -> (Anonymous, tac) + | Some id0 -> + (* Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) + let build_bindings (n, accu) na = match na with + | Anonymous -> (n + 1, accu) + | Name _ -> + let get = global_ref ?loc (kername array_prefix "get") in + let args = [of_variable CAst.(make ?loc id0); of_int CAst.(make ?loc n)] in + let e = CAst.make ?loc @@ CTacApp (get, args) in + let accu = (CAst.make ?loc @@ CPatVar na, e) :: accu in + (n + 1, accu) + in + let (_, bnd) = List.fold_left build_bindings (0, []) vars in + let tac = CAst.make ?loc @@ CTacLet (false, bnd, tac) in + (Name id0, tac) + in + CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], tac) + +let of_pattern p = + inj_wit ?loc:p.CAst.loc wit_pattern p + +let of_conversion {loc;v=c} = match c with +| QConvert c -> + let pat = of_option ?loc of_pattern None in + let c = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar Anonymous], of_constr c) in + of_tuple ?loc [pat; c] +| QConvertWith (pat, c) -> + let vars = pattern_vars pat in + let pat = of_option ?loc of_pattern (Some pat) in + let c = of_constr c in + (* Order is critical here *) + let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in + let c = abstract_vars loc vars c in + of_tuple [pat; c] + +let of_repeat {loc;v=r} = match r with +| QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] +| QUpTo n -> std_constructor ?loc "UpTo" [of_int n] +| QRepeatStar -> std_constructor ?loc "RepeatStar" [] +| QRepeatPlus -> std_constructor ?loc "RepeatPlus" [] + +let of_orient loc b = + if b then std_constructor ?loc "LTR" [] + else std_constructor ?loc "RTL" [] + +let of_rewriting {loc;v=rew} = + let orient = + let {loc;v=orient} = rew.rew_orient in + of_option ?loc (fun b -> of_orient loc b) orient + in + let repeat = of_repeat rew.rew_repeat in + let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in + CAst.make ?loc @@ CTacRec ([ + std_proj "rew_orient", orient; + std_proj "rew_repeat", repeat; + std_proj "rew_equatn", equatn; + ]) + +let of_hyp ?loc id = + let hyp = global_ref ?loc (control_core "hyp") in + CAst.make ?loc @@ CTacApp (hyp, [of_ident id]) + +let of_exact_hyp ?loc id = + let refine = global_ref ?loc (control_core "refine") in + CAst.make ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) + +let of_exact_var ?loc id = + let refine = global_ref ?loc (control_core "refine") in + CAst.make ?loc @@ CTacApp (refine, [thunk (of_variable id)]) + +let of_dispatch tacs = + let loc = tacs.loc in + let default = function + | Some e -> thunk e + | None -> thunk (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0))) + in + let map e = of_pair default (fun l -> of_list ?loc default l) (CAst.make ?loc e) in + of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs + +let make_red_flag l = + let open Genredexpr in + let rec add_flag red = function + | [] -> red + | {v=flag} :: lf -> + let red = match flag with + | QBeta -> { red with rBeta = true } + | QMatch -> { red with rMatch = true } + | QFix -> { red with rFix = true } + | QCofix -> { red with rCofix = true } + | QZeta -> { red with rZeta = true } + | QConst {loc;v=l} -> + if red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l } + | QDeltaBut {loc;v=l} -> + if red.rConst <> [] && not red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l; rDelta = true } + | QIota -> + { red with rMatch = true; rFix = true; rCofix = true } + in + add_flag red lf + in + add_flag + {rBeta = false; rMatch = false; rFix = false; rCofix = false; + rZeta = false; rDelta = false; rConst = []} + l + +let of_reference r = + let of_ref ref = + inj_wit ?loc:ref.loc wit_reference ref + in + of_anti of_ref r + +let of_strategy_flag {loc;v=flag} = + let open Genredexpr in + let flag = make_red_flag flag in + CAst.make ?loc @@ CTacRec ([ + std_proj "rBeta", of_bool ?loc flag.rBeta; + std_proj "rMatch", of_bool ?loc flag.rMatch; + std_proj "rFix", of_bool ?loc flag.rFix; + std_proj "rCofix", of_bool ?loc flag.rCofix; + std_proj "rZeta", of_bool ?loc flag.rZeta; + std_proj "rDelta", of_bool ?loc flag.rDelta; + std_proj "rConst", of_list ?loc of_reference flag.rConst; + ]) + +let of_hintdb {loc;v=hdb} = match hdb with +| QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None +| QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) + +let extract_name ?loc oid = match oid with +| None -> Anonymous +| Some id -> + let () = check_pattern_id ?loc id in + Name id + +(** For every branch in the matching, generate a corresponding term of type + [(match_kind * pattern * (context -> constr array -> 'a))] + where the function binds the names from the pattern to the contents of the + constr array. *) +let of_constr_matching {loc;v=m} = + let map {loc;v=({loc=ploc;v=pat}, tac)} = + let (knd, pat, na) = match pat with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (knd, pat, Anonymous) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (knd, pat, na) + in + let vars = pattern_vars pat in + (* Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let vars = List.map (fun id -> Name id) vars in + let e = abstract_vars loc vars tac in + let e = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], e) in + let pat = inj_wit ?loc:ploc wit_pattern pat in + of_tuple [knd; pat; e] + in + of_list ?loc map m + +(** From the patterns and the body of the branch, generate: + - a goal pattern: (constr_match list * constr_match) + - a branch function (ident array -> context array -> constr array -> context -> 'a) +*) +let of_goal_matching {loc;v=gm} = + let mk_pat {loc;v=p} = match p with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (Anonymous, pat, knd) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (na, pat, knd) + in + let mk_gpat {loc;v=p} = + let concl_pat = p.q_goal_match_concl in + let hyps_pats = p.q_goal_match_hyps in + let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in + let vars = pattern_vars concl_pat in + let map accu (na, pat) = + let (ctx, pat, knd) = mk_pat pat in + let vars = pattern_vars pat in + (Id.Set.union vars accu, (na, ctx, pat, knd)) + in + let (vars, hyps_pats) = List.fold_left_map map vars hyps_pats in + let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in + let concl = of_tuple [concl_knd; of_pattern concl_pat] in + let r = of_tuple [of_list ?loc map hyps_pats; concl] in + let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in + let map (_, na, _, _) = na in + let hctx = List.map map hyps_pats in + (* Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let subst = List.map (fun id -> Name id) vars in + (r, hyps, hctx, subst, concl_ctx) + in + let map {loc;v=(pat, tac)} = + let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in + let tac = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar cctx], tac) in + let tac = abstract_vars loc subst tac in + let tac = abstract_vars loc hctx tac in + let tac = abstract_vars loc hyps tac in + of_tuple ?loc [pat; tac] + in + of_list ?loc map gm + +let of_move_location {loc;v=mv} = match mv with +| QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] +| QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] +| QMoveFirst -> std_constructor ?loc "MoveFirst" [] +| QMoveLast -> std_constructor ?loc "MoveLast" [] + +let of_pose p = + of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p + +let of_assertion {loc;v=ast} = match ast with +| QAssertType (ipat, c, tac) -> + let ipat = of_option of_intro_pattern ipat in + let c = of_constr c in + let tac = of_option thunk tac in + std_constructor ?loc "AssertType" [ipat; c; tac] +| QAssertValue (id, c) -> + let id = of_anti of_ident id in + let c = of_constr c in + std_constructor ?loc "AssertValue" [id; c] diff --git a/vendor/Ltac2/src/tac2quote.mli b/vendor/Ltac2/src/tac2quote.mli new file mode 100644 index 0000000000..1b03dad8ec --- /dev/null +++ b/vendor/Ltac2/src/tac2quote.mli @@ -0,0 +1,102 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ltac_constructor -> raw_tacexpr list -> raw_tacexpr + +val thunk : raw_tacexpr -> raw_tacexpr + +val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr + +val of_int : int CAst.t -> raw_tacexpr + +val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) CAst.t -> raw_tacexpr + +val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr + +val of_variable : Id.t CAst.t -> raw_tacexpr + +val of_ident : Id.t CAst.t -> raw_tacexpr + +val of_constr : Constrexpr.constr_expr -> raw_tacexpr + +val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr + +val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr + +val of_bindings : bindings -> raw_tacexpr + +val of_intro_pattern : intro_pattern -> raw_tacexpr + +val of_intro_patterns : intro_pattern list CAst.t -> raw_tacexpr + +val of_clause : clause -> raw_tacexpr + +val of_destruction_arg : destruction_arg -> raw_tacexpr + +val of_induction_clause : induction_clause -> raw_tacexpr + +val of_conversion : conversion -> raw_tacexpr + +val of_rewriting : rewriting -> raw_tacexpr + +val of_occurrences : occurrences -> raw_tacexpr + +val of_hintdb : hintdb -> raw_tacexpr + +val of_move_location : move_location -> raw_tacexpr + +val of_reference : reference or_anti -> raw_tacexpr + +val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.hyp @id' *) + +val of_exact_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_exact_var : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_dispatch : dispatch -> raw_tacexpr + +val of_strategy_flag : strategy_flag -> raw_tacexpr + +val of_pose : pose -> raw_tacexpr + +val of_assertion : assertion -> raw_tacexpr + +val of_constr_matching : constr_matching -> raw_tacexpr + +val of_goal_matching : goal_matching -> raw_tacexpr + +(** {5 Generic arguments} *) + +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag + +val wit_ident : (Id.t, Id.t) Arg.tag + +val wit_reference : (reference, GlobRef.t) Arg.tag + +val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) + +val wit_ltac1val : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a value-returning expression, with type Ltac1.t. *) diff --git a/vendor/Ltac2/src/tac2stdlib.ml b/vendor/Ltac2/src/tac2stdlib.ml new file mode 100644 index 0000000000..ffef2c05fd --- /dev/null +++ b/vendor/Ltac2/src/tac2stdlib.ml @@ -0,0 +1,578 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false) f + +let return x = Proofview.tclUNIT x +let v_unit = Value.of_unit () +let thaw r f = Tac2ffi.app_fun1 f unit r () +let uthaw r f = Tac2ffi.app_fun1 (to_fun1 unit r f) unit r () +let thunk r = fun1 unit r + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let name = make_to_repr to_name + +let to_occurrences = function +| ValInt 0 -> AllOccurrences +| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list Value.to_int vl) +| ValInt 1 -> NoOccurrences +| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) +| _ -> assert false + +let occurrences = make_to_repr to_occurrences + +let to_hyp_location_flag v = match Value.to_int v with +| 0 -> InHyp +| 1 -> InHypTypeOnly +| 2 -> InHypValueOnly +| _ -> assert false + +let to_clause v = match Value.to_tuple v with +| [| hyps; concl |] -> + let cast v = match Value.to_tuple v with + | [| hyp; occ; flag |] -> + (Value.to_ident hyp, to_occurrences occ, to_hyp_location_flag flag) + | _ -> assert false + in + let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in + { onhyps = hyps; concl_occs = to_occurrences concl; } +| _ -> assert false + +let clause = make_to_repr to_clause + +let to_red_flag v = match Value.to_tuple v with +| [| beta; iota; fix; cofix; zeta; delta; const |] -> + { + rBeta = Value.to_bool beta; + rMatch = Value.to_bool iota; + rFix = Value.to_bool fix; + rCofix = Value.to_bool cofix; + rZeta = Value.to_bool zeta; + rDelta = Value.to_bool delta; + rConst = Value.to_list Value.to_reference const; + } +| _ -> assert false + +let red_flags = make_to_repr to_red_flag + +let pattern_with_occs = pair pattern occurrences + +let constr_with_occs = pair constr occurrences + +let reference_with_occs = pair reference occurrences + +let rec to_intro_pattern v = match Value.to_block v with +| (0, [| b |]) -> IntroForthcoming (Value.to_bool b) +| (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) +| (2, [| act |]) -> IntroAction (to_intro_pattern_action act) +| _ -> assert false + +and to_intro_pattern_naming = function +| ValBlk (0, [| id |]) -> IntroIdentifier (Value.to_ident id) +| ValBlk (1, [| id |]) -> IntroFresh (Value.to_ident id) +| ValInt 0 -> IntroAnonymous +| _ -> assert false + +and to_intro_pattern_action = function +| ValInt 0 -> IntroWildcard +| ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) +| ValBlk (1, [| inj |]) -> + let map ipat = to_intro_pattern ipat in + IntroInjection (Value.to_list map inj) +| ValBlk (2, [| c; ipat |]) -> + let c = Value.to_fun1 Value.unit Value.constr c in + IntroApplyOn (c, to_intro_pattern ipat) +| ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) +| _ -> assert false + +and to_or_and_intro_pattern v = match Value.to_block v with +| (0, [| ill |]) -> + IntroOrPattern (Value.to_list to_intro_patterns ill) +| (1, [| il |]) -> + IntroAndPattern (to_intro_patterns il) +| _ -> assert false + +and to_intro_patterns il = + Value.to_list to_intro_pattern il + +let intro_pattern = make_to_repr to_intro_pattern + +let intro_patterns = make_to_repr to_intro_patterns + +let to_destruction_arg v = match Value.to_block v with +| (0, [| c |]) -> + let c = uthaw constr_with_bindings c in + ElimOnConstr c +| (1, [| id |]) -> ElimOnIdent (Value.to_ident id) +| (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) +| _ -> assert false + +let destruction_arg = make_to_repr to_destruction_arg + +let to_induction_clause v = match Value.to_tuple v with +| [| arg; eqn; as_; in_ |] -> + let arg = to_destruction_arg arg in + let eqn = Value.to_option to_intro_pattern_naming eqn in + let as_ = Value.to_option to_or_and_intro_pattern as_ in + let in_ = Value.to_option to_clause in_ in + (arg, eqn, as_, in_) +| _ -> + assert false + +let induction_clause = make_to_repr to_induction_clause + +let to_assertion v = match Value.to_block v with +| (0, [| ipat; t; tac |]) -> + let to_tac t = Value.to_fun1 Value.unit Value.unit t in + let ipat = Value.to_option to_intro_pattern ipat in + let t = Value.to_constr t in + let tac = Value.to_option to_tac tac in + AssertType (ipat, t, tac) +| (1, [| id; c |]) -> + AssertValue (Value.to_ident id, Value.to_constr c) +| _ -> assert false + +let assertion = make_to_repr to_assertion + +let to_multi = function +| ValBlk (0, [| n |]) -> Precisely (Value.to_int n) +| ValBlk (1, [| n |]) -> UpTo (Value.to_int n) +| ValInt 0 -> RepeatStar +| ValInt 1 -> RepeatPlus +| _ -> assert false + +let to_rewriting v = match Value.to_tuple v with +| [| orient; repeat; c |] -> + let orient = Value.to_option Value.to_bool orient in + let repeat = to_multi repeat in + let c = uthaw constr_with_bindings c in + (orient, repeat, c) +| _ -> assert false + +let rewriting = make_to_repr to_rewriting + +let to_debug v = match Value.to_int v with +| 0 -> Hints.Off +| 1 -> Hints.Info +| 2 -> Hints.Debug +| _ -> assert false + +let debug = make_to_repr to_debug + +let to_strategy v = match Value.to_int v with +| 0 -> Class_tactics.Bfs +| 1 -> Class_tactics.Dfs +| _ -> assert false + +let strategy = make_to_repr to_strategy + +let to_inversion_kind v = match Value.to_int v with +| 0 -> Inv.SimpleInversion +| 1 -> Inv.FullInversion +| 2 -> Inv.FullInversionClear +| _ -> assert false + +let inversion_kind = make_to_repr to_inversion_kind + +let to_move_location = function +| ValInt 0 -> Logic.MoveFirst +| ValInt 1 -> Logic.MoveLast +| ValBlk (0, [|id|]) -> Logic.MoveAfter (Value.to_ident id) +| ValBlk (1, [|id|]) -> Logic.MoveBefore (Value.to_ident id) +| _ -> assert false + +let move_location = make_to_repr to_move_location + +let to_generalize_arg v = match Value.to_tuple v with +| [| c; occs; na |] -> + (Value.to_constr c, to_occurrences occs, to_name na) +| _ -> assert false + +let generalize_arg = make_to_repr to_generalize_arg + +(** Standard tactics sharing their implementation with Ltac1 *) + +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let lift tac = tac <*> return v_unit + +let define_prim0 name tac = + let tac _ = lift tac in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_prim1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_prim2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) + +let define_prim3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) + +let define_prim4 name r0 r1 r2 r3 f = + let tac x y z u = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) + +let define_prim5 name r0 r1 r2 r3 r4 f = + let tac x y z u v = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u) (Value.repr_to r4 v)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) + +(** Tactics from Tacexpr *) + +let () = define_prim2 "tac_intros" bool intro_patterns begin fun ev ipat -> + Tac2tactics.intros_patterns ev ipat +end + +let () = define_prim4 "tac_apply" bool bool (list (thunk constr_with_bindings)) (option (pair ident (option intro_pattern))) begin fun adv ev cb ipat -> + Tac2tactics.apply adv ev cb ipat +end + +let () = define_prim3 "tac_elim" bool constr_with_bindings (option constr_with_bindings) begin fun ev c copt -> + Tac2tactics.elim ev c copt +end + +let () = define_prim2 "tac_case" bool constr_with_bindings begin fun ev c -> + Tac2tactics.general_case_analysis ev c +end + +let () = define_prim1 "tac_generalize" (list generalize_arg) begin fun cl -> + Tac2tactics.generalize cl +end + +let () = define_prim1 "tac_assert" assertion begin fun ast -> + Tac2tactics.assert_ ast +end + +let () = define_prim3 "tac_enough" constr (option (option (thunk unit))) (option intro_pattern) begin fun c tac ipat -> + let tac = Option.map (fun o -> Option.map (fun f -> thaw unit f) o) tac in + Tac2tactics.forward false tac ipat c +end + +let () = define_prim2 "tac_pose" name constr begin fun na c -> + Tactics.letin_tac None na c None Locusops.nowhere +end + +let () = define_prim3 "tac_set" bool (thunk (pair name constr)) clause begin fun ev p cl -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw (pair name constr) p >>= fun (na, c) -> + Tac2tactics.letin_pat_tac ev None na (sigma, c) cl +end + +let () = define_prim5 "tac_remember" bool name (thunk constr) (option intro_pattern) clause begin fun ev na c eqpat cl -> + let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in + match eqpat with + | IntroNaming eqpat -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw constr c >>= fun c -> + Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl + | _ -> + Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") +end + +let () = define_prim3 "tac_destruct" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> + Tac2tactics.induction_destruct false ev ic using +end + +let () = define_prim3 "tac_induction" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> + Tac2tactics.induction_destruct true ev ic using +end + +let () = define_prim1 "tac_red" clause begin fun cl -> + Tac2tactics.reduce (Red false) cl +end + +let () = define_prim1 "tac_hnf" clause begin fun cl -> + Tac2tactics.reduce Hnf cl +end + +let () = define_prim3 "tac_simpl" red_flags (option pattern_with_occs) clause begin fun flags where cl -> + Tac2tactics.simpl flags where cl +end + +let () = define_prim2 "tac_cbv" red_flags clause begin fun flags cl -> + Tac2tactics.cbv flags cl +end + +let () = define_prim2 "tac_cbn" red_flags clause begin fun flags cl -> + Tac2tactics.cbn flags cl +end + +let () = define_prim2 "tac_lazy" red_flags clause begin fun flags cl -> + Tac2tactics.lazy_ flags cl +end + +let () = define_prim2 "tac_unfold" (list reference_with_occs) clause begin fun refs cl -> + Tac2tactics.unfold refs cl +end + +let () = define_prim2 "tac_fold" (list constr) clause begin fun args cl -> + Tac2tactics.reduce (Fold args) cl +end + +let () = define_prim2 "tac_pattern" (list constr_with_occs) clause begin fun where cl -> + Tac2tactics.pattern where cl +end + +let () = define_prim2 "tac_vm" (option pattern_with_occs) clause begin fun where cl -> + Tac2tactics.vm where cl +end + +let () = define_prim2 "tac_native" (option pattern_with_occs) clause begin fun where cl -> + Tac2tactics.native where cl +end + +(** Reduction functions *) + +let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + +let define_red1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_red2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) + +let define_red3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) + +let () = define_red1 "eval_red" constr begin fun c -> + Tac2tactics.eval_red c +end + +let () = define_red1 "eval_hnf" constr begin fun c -> + Tac2tactics.eval_hnf c +end + +let () = define_red3 "eval_simpl" red_flags (option pattern_with_occs) constr begin fun flags where c -> + Tac2tactics.eval_simpl flags where c +end + +let () = define_red2 "eval_cbv" red_flags constr begin fun flags c -> + Tac2tactics.eval_cbv flags c +end + +let () = define_red2 "eval_cbn" red_flags constr begin fun flags c -> + Tac2tactics.eval_cbn flags c +end + +let () = define_red2 "eval_lazy" red_flags constr begin fun flags c -> + Tac2tactics.eval_lazy flags c +end + +let () = define_red2 "eval_unfold" (list reference_with_occs) constr begin fun refs c -> + Tac2tactics.eval_unfold refs c +end + +let () = define_red2 "eval_fold" (list constr) constr begin fun args c -> + Tac2tactics.eval_fold args c +end + +let () = define_red2 "eval_pattern" (list constr_with_occs) constr begin fun where c -> + Tac2tactics.eval_pattern where c +end + +let () = define_red2 "eval_vm" (option pattern_with_occs) constr begin fun where c -> + Tac2tactics.eval_vm where c +end + +let () = define_red2 "eval_native" (option pattern_with_occs) constr begin fun where c -> + Tac2tactics.eval_native where c +end + +let () = define_prim3 "tac_change" (option pattern) (fun1 (array constr) constr) clause begin fun pat c cl -> + Tac2tactics.change pat c cl +end + +let () = define_prim4 "tac_rewrite" bool (list rewriting) clause (option (thunk unit)) begin fun ev rw cl by -> + Tac2tactics.rewrite ev rw cl by +end + +let () = define_prim4 "tac_inversion" inversion_kind destruction_arg (option intro_pattern) (option (list ident)) begin fun knd arg pat ids -> + Tac2tactics.inversion knd arg pat ids +end + +(** Tactics from coretactics *) + +let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity + +let () = define_prim2 "tac_move" ident move_location begin fun id mv -> + Tactics.move_hyp id mv +end + +let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> + let mv = Option.default Logic.MoveLast mv in + Tactics.intro_move id mv +end + +(* + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + +*) + +let () = define_prim0 "tac_assumption" Tactics.assumption + +let () = define_prim1 "tac_transitivity" constr begin fun c -> + Tactics.intros_transitivity (Some c) +end + +let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) + +let () = define_prim1 "tac_cut" constr begin fun c -> + Tactics.cut c +end + +let () = define_prim2 "tac_left" bool bindings begin fun ev bnd -> + Tac2tactics.left_with_bindings ev bnd +end +let () = define_prim2 "tac_right" bool bindings begin fun ev bnd -> + Tac2tactics.right_with_bindings ev bnd +end + +let () = define_prim1 "tac_introsuntil" qhyp begin fun h -> + Tactics.intros_until h +end + +let () = define_prim1 "tac_exactnocheck" constr begin fun c -> + Tactics.exact_no_check c +end + +let () = define_prim1 "tac_vmcastnocheck" constr begin fun c -> + Tactics.vm_cast_no_check c +end + +let () = define_prim1 "tac_nativecastnocheck" constr begin fun c -> + Tactics.native_cast_no_check c +end + +let () = define_prim1 "tac_constructor" bool begin fun ev -> + Tactics.any_constructor ev None +end + +let () = define_prim3 "tac_constructorn" bool int bindings begin fun ev n bnd -> + Tac2tactics.constructor_tac ev None n bnd +end + +let () = define_prim2 "tac_specialize" constr_with_bindings (option intro_pattern) begin fun c ipat -> + Tac2tactics.specialize c ipat +end + +let () = define_prim1 "tac_symmetry" clause begin fun cl -> + Tac2tactics.symmetry cl +end + +let () = define_prim2 "tac_split" bool bindings begin fun ev bnd -> + Tac2tactics.split_with_bindings ev bnd +end + +let () = define_prim1 "tac_rename" (list (pair ident ident)) begin fun ids -> + Tactics.rename_hyp ids +end + +let () = define_prim1 "tac_revert" (list ident) begin fun ids -> + Tactics.revert ids +end + +let () = define_prim0 "tac_admit" Proofview.give_up + +let () = define_prim2 "tac_fix" ident int begin fun ident n -> + Tactics.fix ident n +end + +let () = define_prim1 "tac_cofix" ident begin fun ident -> + Tactics.cofix ident +end + +let () = define_prim1 "tac_clear" (list ident) begin fun ids -> + Tactics.clear ids +end + +let () = define_prim1 "tac_keep" (list ident) begin fun ids -> + Tactics.keep ids +end + +let () = define_prim1 "tac_clearbody" (list ident) begin fun ids -> + Tactics.clear_body ids +end + +(** Tactics from extratactics *) + +let () = define_prim2 "tac_discriminate" bool (option destruction_arg) begin fun ev arg -> + Tac2tactics.discriminate ev arg +end + +let () = define_prim3 "tac_injection" bool (option intro_patterns) (option destruction_arg) begin fun ev ipat arg -> + Tac2tactics.injection ev ipat arg +end + +let () = define_prim1 "tac_absurd" constr begin fun c -> + Contradiction.absurd c +end + +let () = define_prim1 "tac_contradiction" (option constr_with_bindings) begin fun c -> + Tac2tactics.contradiction c +end + +let () = define_prim4 "tac_autorewrite" bool (option (thunk unit)) (list ident) clause begin fun all by ids cl -> + Tac2tactics.autorewrite ~all by ids cl +end + +let () = define_prim1 "tac_subst" (list ident) begin fun ids -> + Equality.subst ids +end + +let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) + +(** Auto *) + +let () = define_prim3 "tac_trivial" debug (list (thunk constr)) (option (list ident)) begin fun dbg lems dbs -> + Tac2tactics.trivial dbg lems dbs +end + +let () = define_prim5 "tac_eauto" debug (option int) (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n p lems dbs -> + Tac2tactics.eauto dbg n p lems dbs +end + +let () = define_prim4 "tac_auto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> + Tac2tactics.auto dbg n lems dbs +end + +let () = define_prim4 "tac_newauto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> + Tac2tactics.new_auto dbg n lems dbs +end + +let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> + Tac2tactics.typeclasses_eauto str n dbs +end + +(** Firstorder *) + +let () = define_prim3 "tac_firstorder" (option (thunk unit)) (list reference) (list ident) begin fun tac refs ids -> + Tac2tactics.firstorder tac refs ids +end diff --git a/vendor/Ltac2/src/tac2stdlib.mli b/vendor/Ltac2/src/tac2stdlib.mli new file mode 100644 index 0000000000..927b57074d --- /dev/null +++ b/vendor/Ltac2/src/tac2stdlib.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tactypes.ImplicitBindings l +| ExplicitBindings l -> + let l = List.map CAst.make l in + Tactypes.ExplicitBindings l +| NoBindings -> Tactypes.NoBindings + +let mk_with_bindings (x, b) = (x, mk_bindings b) + +let rec mk_intro_pattern = function +| IntroForthcoming b -> CAst.make @@ Tactypes.IntroForthcoming b +| IntroNaming ipat -> CAst.make @@ Tactypes.IntroNaming (mk_intro_pattern_naming ipat) +| IntroAction ipat -> CAst.make @@ Tactypes.IntroAction (mk_intro_pattern_action ipat) + +and mk_intro_pattern_naming = function +| IntroIdentifier id -> Namegen.IntroIdentifier id +| IntroFresh id -> Namegen.IntroFresh id +| IntroAnonymous -> Namegen.IntroAnonymous + +and mk_intro_pattern_action = function +| IntroWildcard -> Tactypes.IntroWildcard +| IntroOrAndPattern ipat -> Tactypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) +| IntroInjection ipats -> Tactypes.IntroInjection (List.map mk_intro_pattern ipats) +| IntroApplyOn (c, ipat) -> + let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in + Tactypes.IntroApplyOn (c, mk_intro_pattern ipat) +| IntroRewrite b -> Tactypes.IntroRewrite b + +and mk_or_and_intro_pattern = function +| IntroOrPattern ipatss -> + Tactypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) +| IntroAndPattern ipats -> + Tactypes.IntroAndPattern (List.map mk_intro_pattern ipats) + +let mk_intro_patterns ipat = List.map mk_intro_pattern ipat + +let mk_occurrences f = function +| AllOccurrences -> Locus.AllOccurrences +| AllOccurrencesBut l -> Locus.AllOccurrencesBut (List.map f l) +| NoOccurrences -> Locus.NoOccurrences +| OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) + +let mk_occurrences_expr occ = + mk_occurrences (fun i -> Locus.ArgArg i) occ + +let mk_hyp_location (id, occs, h) = + ((mk_occurrences_expr occs, id), h) + +let mk_clause cl = { + Locus.onhyps = Option.map (fun l -> List.map mk_hyp_location l) cl.onhyps; + Locus.concl_occs = mk_occurrences_expr cl.concl_occs; +} + +let intros_patterns ev ipat = + let ipat = mk_intro_patterns ipat in + Tactics.intros_patterns ev ipat + +let apply adv ev cb cl = + let map c = + let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in + None, CAst.make (delayed_of_tactic c) + in + let cb = List.map map cb in + match cl with + | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb + | Some (id, cl) -> + let cl = Option.map mk_intro_pattern cl in + Tactics.apply_delayed_in adv ev id cb cl + +let mk_destruction_arg = function +| ElimOnConstr c -> + let c = c >>= fun c -> return (mk_with_bindings c) in + Tactics.ElimOnConstr (delayed_of_tactic c) +| ElimOnIdent id -> Tactics.ElimOnIdent CAst.(make id) +| ElimOnAnonHyp n -> Tactics.ElimOnAnonHyp n + +let mk_induction_clause (arg, eqn, as_, occ) = + let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in + let as_ = Option.map (fun ipat -> CAst.make @@ mk_or_and_intro_pattern ipat) as_ in + let occ = Option.map mk_clause occ in + ((None, mk_destruction_arg arg), (eqn, as_), occ) + +let induction_destruct isrec ev (ic : induction_clause list) using = + let ic = List.map mk_induction_clause ic in + let using = Option.map mk_with_bindings using in + Tactics.induction_destruct isrec ev (ic, using) + +let elim ev c copt = + let c = mk_with_bindings c in + let copt = Option.map mk_with_bindings copt in + Tactics.elim ev None c copt + +let generalize pl = + let mk_occ occs = mk_occurrences (fun i -> i) occs in + let pl = List.map (fun (c, occs, na) -> (mk_occ occs, c), na) pl in + Tactics.new_generalize_gen pl + +let general_case_analysis ev c = + let c = mk_with_bindings c in + Tactics.general_case_analysis ev None c + +let constructor_tac ev n i bnd = + let bnd = mk_bindings bnd in + Tactics.constructor_tac ev n i bnd + +let left_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.left_with_bindings ev bnd + +let right_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.right_with_bindings ev bnd + +let split_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.split_with_bindings ev [bnd] + +let specialize c pat = + let c = mk_with_bindings c in + let pat = Option.map mk_intro_pattern pat in + Tactics.specialize c pat + +let change pat c cl = + let open Tac2ffi in + Proofview.Goal.enter begin fun gl -> + let c subst env sigma = + let subst = Array.map_of_list snd (Id.Map.bindings subst) in + delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma + in + let cl = mk_clause cl in + Tactics.change pat c cl + end + +let rewrite ev rw cl by = + let map_rw (orient, repeat, c) = + let c = c >>= fun c -> return (mk_with_bindings c) in + (Option.default true orient, repeat, None, delayed_of_tactic c) + in + let rw = List.map map_rw rw in + let cl = mk_clause cl in + let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE (thaw Tac2ffi.unit tac), Equality.Naive) by in + Equality.general_multi_rewrite ev rw cl by + +let symmetry cl = + let cl = mk_clause cl in + Tactics.intros_symmetry cl + +let forward fst tac ipat c = + let ipat = Option.map mk_intro_pattern ipat in + Tactics.forward fst tac ipat c + +let assert_ = function +| AssertValue (id, c) -> + let ipat = CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id) in + Tactics.forward true None (Some ipat) c +| AssertType (ipat, c, tac) -> + let ipat = Option.map mk_intro_pattern ipat in + let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in + Tactics.forward true (Some tac) ipat c + +let letin_pat_tac ev ipat na c cl = + let ipat = Option.map (fun (b, ipat) -> (b, CAst.make @@ mk_intro_pattern_naming ipat)) ipat in + let cl = mk_clause cl in + Tactics.letin_pat_tac ev ipat na c cl + +(** Ltac interface treats differently global references than other term + arguments in reduction expressions. In Ltac1, this is done at parsing time. + Instead, we parse indifferently any pattern and dispatch when the tactic is + called. *) +let map_pattern_with_occs (pat, occ) = match pat with +| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) +| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| _ -> (mk_occurrences_expr occ, Inr pat) + +let get_evaluable_reference = function +| VarRef id -> Proofview.tclUNIT (EvalVarRef id) +| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| r -> + Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ + Nametab.pr_global_env Id.Set.empty r ++ spc () ++ + str "to an evaluable reference.") + +let reduce r cl = + let cl = mk_clause cl in + Tactics.reduce r cl + +let simpl flags where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Simpl (flags, where)) cl + +let cbv flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbv flags) cl + +let cbn flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbn flags) cl + +let lazy_ flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Lazy flags) cl + +let unfold occs cl = + let cl = mk_clause cl in + let map (gr, occ) = + let occ = mk_occurrences_expr occ in + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + Tactics.reduce (Unfold occs) cl + +let pattern where cl = + let where = List.map (fun (c, occ) -> (mk_occurrences_expr occ, c)) where in + let cl = mk_clause cl in + Tactics.reduce (Pattern where) cl + +let vm where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Tactics.reduce (CbvVm where) cl + +let native where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Tactics.reduce (CbvNative where) cl + +let eval_fun red c = + Tac2core.pf_apply begin fun env sigma -> + let (redfun, _) = Redexpr.reduction_of_red_expr env red in + let (sigma, ans) = redfun env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT ans + end + +let eval_red c = + eval_fun (Red false) c + +let eval_hnf c = + eval_fun Hnf c + +let eval_simpl flags where c = + let where = Option.map map_pattern_with_occs where in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Simpl (flags, where)) c + +let eval_cbv flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbv flags) c + +let eval_cbn flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbn flags) c + +let eval_lazy flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Lazy flags) c + +let eval_unfold occs c = + let map (gr, occ) = + let occ = mk_occurrences_expr occ in + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + eval_fun (Unfold occs) c + +let eval_fold cl c = + eval_fun (Fold cl) c + +let eval_pattern where c = + let where = List.map (fun (pat, occ) -> (mk_occurrences_expr occ, pat)) where in + eval_fun (Pattern where) c + +let eval_vm where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvVm where) c + +let eval_native where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvNative where) c + +let on_destruction_arg tac ev arg = + Proofview.Goal.enter begin fun gl -> + match arg with + | None -> tac ev None + | Some (clear, arg) -> + let arg = match arg with + | ElimOnConstr c -> + let env = Proofview.Goal.env gl in + Proofview.tclEVARMAP >>= fun sigma -> + c >>= fun (c, lbind) -> + let lbind = mk_bindings lbind in + Proofview.tclEVARMAP >>= fun sigma' -> + let flags = tactic_infer_flags ev in + let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in + Proofview.tclUNIT (Some sigma', Tactics.ElimOnConstr (c, lbind)) + | ElimOnIdent id -> Proofview.tclUNIT (None, Tactics.ElimOnIdent CAst.(make id)) + | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Tactics.ElimOnAnonHyp n) + in + arg >>= fun (sigma', arg) -> + let arg = Some (clear, arg) in + match sigma' with + | None -> tac ev arg + | Some sigma' -> + Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' + end + +let discriminate ev arg = + let arg = Option.map (fun arg -> None, arg) arg in + on_destruction_arg Equality.discr_tac ev arg + +let injection ev ipat arg = + let arg = Option.map (fun arg -> None, arg) arg in + let ipat = Option.map mk_intro_patterns ipat in + let tac ev arg = Equality.injClause None ipat ev arg in + on_destruction_arg tac ev arg + +let autorewrite ~all by ids cl = + let conds = if all then Some Equality.AllMatches else None in + let ids = List.map Id.to_string ids in + let cl = mk_clause cl in + match by with + | None -> Autorewrite.auto_multi_rewrite ?conds ids cl + | Some by -> + let by = thaw Tac2ffi.unit by in + Autorewrite.auto_multi_rewrite_with ?conds by ids cl + +(** Auto *) + +let trivial debug lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_trivial ~debug lems dbs + +let auto debug n lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_auto ~debug n lems dbs + +let new_auto debug n lems dbs = + let make_depth n = snd (Eauto.make_dimension n None) in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + match dbs with + | None -> Auto.new_full_auto ~debug (make_depth n) lems + | Some dbs -> + let dbs = List.map Id.to_string dbs in + Auto.new_auto ~debug (make_depth n) lems dbs + +let eauto debug n p lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs + +let typeclasses_eauto strategy depth dbs = + let only_classes, dbs = match dbs with + | None -> + true, [Class_tactics.typeclasses_db] + | Some dbs -> + let dbs = List.map Id.to_string dbs in + false, dbs + in + Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs + +(** Inversion *) + +let inversion knd arg pat ids = + let ids = match ids with + | None -> [] + | Some l -> l + in + begin match pat with + | None -> Proofview.tclUNIT None + | Some (IntroAction (IntroOrAndPattern p)) -> + Proofview.tclUNIT (Some (CAst.make @@ mk_or_and_intro_pattern p)) + | Some _ -> + Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") + end >>= fun pat -> + let inversion _ arg = + begin match arg with + | None -> assert false + | Some (_, Tactics.ElimOnAnonHyp n) -> + Inv.inv_clause knd pat ids (AnonHyp n) + | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> + Inv.inv_clause knd pat ids (NamedHyp id) + | Some (_, Tactics.ElimOnConstr c) -> + let open Tactypes in + let anon = CAst.make @@ IntroNaming Namegen.IntroAnonymous in + Tactics.specialize c (Some anon) >>= fun () -> + Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) + end + in + on_destruction_arg inversion true (Some (None, arg)) + +let contradiction c = + let c = Option.map mk_with_bindings c in + Contradiction.contradiction c + +(** Firstorder *) + +let firstorder tac refs ids = + let open Ground_plugin in + let ids = List.map Id.to_string ids in + let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in + G_ground.gen_ground_tac true tac refs ids diff --git a/vendor/Ltac2/src/tac2tactics.mli b/vendor/Ltac2/src/tac2tactics.mli new file mode 100644 index 0000000000..026673acbf --- /dev/null +++ b/vendor/Ltac2/src/tac2tactics.mli @@ -0,0 +1,124 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* intro_pattern list -> unit tactic + +val apply : advanced_flag -> evars_flag -> + constr_with_bindings thunk list -> + (Id.t * intro_pattern option) option -> unit tactic + +val induction_destruct : rec_flag -> evars_flag -> + induction_clause list -> constr_with_bindings option -> unit tactic + +val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> + unit tactic + +val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic + +val generalize : (constr * occurrences * Name.t) list -> unit tactic + +val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic + +val left_with_bindings : evars_flag -> bindings -> unit tactic +val right_with_bindings : evars_flag -> bindings -> unit tactic +val split_with_bindings : evars_flag -> bindings -> unit tactic + +val specialize : constr_with_bindings -> intro_pattern option -> unit tactic + +val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic + +val rewrite : + evars_flag -> rewriting list -> clause -> unit thunk option -> unit tactic + +val symmetry : clause -> unit tactic + +val forward : bool -> unit tactic option option -> + intro_pattern option -> constr -> unit tactic + +val assert_ : assertion -> unit tactic + +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> + Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic + +val reduce : Redexpr.red_expr -> clause -> unit tactic + +val simpl : GlobRef.t glob_red_flag -> + (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val cbv : GlobRef.t glob_red_flag -> clause -> unit tactic + +val cbn : GlobRef.t glob_red_flag -> clause -> unit tactic + +val lazy_ : GlobRef.t glob_red_flag -> clause -> unit tactic + +val unfold : (GlobRef.t * occurrences) list -> clause -> unit tactic + +val pattern : (constr * occurrences) list -> clause -> unit tactic + +val vm : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val native : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val eval_red : constr -> constr tactic + +val eval_hnf : constr -> constr tactic + +val eval_simpl : GlobRef.t glob_red_flag -> + (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val eval_cbv : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_cbn : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_lazy : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_unfold : (GlobRef.t * occurrences) list -> constr -> constr tactic + +val eval_fold : constr list -> constr -> constr tactic + +val eval_pattern : (EConstr.t * occurrences) list -> constr -> constr tactic + +val eval_vm : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val eval_native : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val discriminate : evars_flag -> destruction_arg option -> unit tactic + +val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic + +val autorewrite : all:bool -> unit thunk option -> Id.t list -> clause -> unit tactic + +val trivial : Hints.debug -> constr thunk list -> Id.t list option -> + unit Proofview.tactic + +val auto : Hints.debug -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val new_auto : Hints.debug -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val eauto : Hints.debug -> int option -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> + Id.t list option -> unit Proofview.tactic + +val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic + +val contradiction : constr_with_bindings option -> unit tactic + +val firstorder : unit thunk option -> GlobRef.t list -> Id.t list -> unit tactic diff --git a/vendor/Ltac2/src/tac2types.mli b/vendor/Ltac2/src/tac2types.mli new file mode 100644 index 0000000000..fa31153a27 --- /dev/null +++ b/vendor/Ltac2/src/tac2types.mli @@ -0,0 +1,92 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* $@ + if [ $$? = 0 ]; then \ + echo " $<... OK"; \ + else \ + echo " $<... FAIL!"; \ + fi; \ + +clean: + rm -f *.log diff --git a/vendor/Ltac2/tests/compat.v b/vendor/Ltac2/tests/compat.v new file mode 100644 index 0000000000..489fa638e4 --- /dev/null +++ b/vendor/Ltac2/tests/compat.v @@ -0,0 +1,58 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +(** Test calls to Ltac1 from Ltac2 *) + +Ltac2 foo () := ltac1:(discriminate). + +Goal true = false -> False. +Proof. +foo (). +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(match goal with [ H : ?P |- _ ] => rewrite H end); reflexivity. +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(rewrite H); reflexivity. +Abort. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac2 bar nay := ltac1:(discriminate nay). + +Fail Ltac2 pose1 (v : constr) := + ltac1:(pose $v). + +(** Test calls to Ltac2 from Ltac1 *) + +Set Default Proof Mode "Classic". + +Ltac foo := ltac2:(foo ()). + +Goal true = false -> False. +Proof. +ltac2:(foo ()). +Qed. + +Goal true = false -> False. +Proof. +foo. +Qed. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac bar x := ltac2:(foo x). + +Ltac mytac tac := idtac "wow". + +Goal True. +Proof. +(** Fails because quotation is evaluated eagerly *) +Fail mytac ltac2:(fail). +(** One has to thunk thanks to the idtac trick *) +let t := idtac; ltac2:(fail) in mytac t. +constructor. +Qed. diff --git a/vendor/Ltac2/tests/errors.v b/vendor/Ltac2/tests/errors.v new file mode 100644 index 0000000000..c677f6af5d --- /dev/null +++ b/vendor/Ltac2/tests/errors.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Ltac2. + +Goal True. +Proof. +let x := Control.plus + (fun () => let _ := constr:(nat -> 0) in 0) + (fun e => match e with Not_found => 1 | _ => 2 end) in +match Int.equal x 2 with +| true => () +| false => Control.throw (Tactic_failure None) +end. +Abort. diff --git a/vendor/Ltac2/tests/example1.v b/vendor/Ltac2/tests/example1.v new file mode 100644 index 0000000000..023791050f --- /dev/null +++ b/vendor/Ltac2/tests/example1.v @@ -0,0 +1,27 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Control. + +(** Alternative implementation of the hyp primitive *) +Ltac2 get_hyp_by_name x := + let h := hyps () in + let rec find x l := match l with + | [] => zero Not_found + | p :: l => + match p with + | (id, _, t) => + match Ident.equal x id with + | true => t + | false => find x l + end + end + end in + find x h. + +Print Ltac2 get_hyp_by_name. + +Goal forall n m, n + m = 0 -> n = 0. +Proof. +refine (fun () => '(fun n m H => _)). +let t := get_hyp_by_name @H in Message.print (Message.of_constr t). +Abort. diff --git a/vendor/Ltac2/tests/example2.v b/vendor/Ltac2/tests/example2.v new file mode 100644 index 0000000000..c953d25061 --- /dev/null +++ b/vendor/Ltac2/tests/example2.v @@ -0,0 +1,281 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Set Default Goal Selector "all". + +Goal exists n, n = 0. +Proof. +split with (x := 0). +reflexivity. +Qed. + +Goal exists n, n = 0. +Proof. +split with 0. +split. +Qed. + +Goal exists n, n = 0. +Proof. +let myvar := Std.NamedHyp @x in split with ($myvar := 0). +split. +Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +eelim &H. +split. +Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +elim &H with 0. +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +Fail apply &H. +apply &H with (m := 0). +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> (0 = 1) -> P 0. +Proof. +intros P H e. +apply &H with (m := 1) in e. +exact e. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +eapply &H. +split. +Qed. + +Goal exists n, n = 0. +Proof. +Fail constructor 1. +constructor 1 with (x := 0). +split. +Qed. + +Goal exists n, n = 0. +Proof. +econstructor 1. +split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +induction &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +induction &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +destruct &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +destruct &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall b1 b2, andb b1 b2 = andb b2 b1. +Proof. +intros b1 b2. +destruct &b1 as [|], &b2 as [|]; split. +Qed. + +Goal forall n m, n = 0 -> n + m = m. +Proof. +intros n m Hn. +rewrite &Hn; split. +Qed. + +Goal forall n m p, n = m -> p = m -> 0 = n -> p = 0. +Proof. +intros n m p He He' Hn. +rewrite &He, <- &He' in Hn. +rewrite &Hn. +split. +Qed. + +Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. +Proof. +intros n m He He' He''. +rewrite <- &He by assumption. +Control.refine (fun () => &He''). +Qed. + +Goal forall n (r := if true then n else 0), r = n. +Proof. +intros n r. +hnf in r. +split. +Qed. + +Goal 1 = 0 -> 0 = 0. +Proof. +intros H. +pattern 0 at 1. +let occ := 2 in pattern 1 at 1, 0 at $occ in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +vm_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +native_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2 - 0 -> True. +Proof. +intros H. +vm_compute plus in H. +reflexivity. +Qed. + +Goal 1 = 0 -> True /\ True. +Proof. +intros H. +split; fold (1 + 0) (1 + 0) in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +cbv [ Nat.add ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +let x := reference:(Nat.add) in +cbn beta iota delta [ $x ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +simpl beta. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +lazy. +reflexivity. +Qed. + +Goal let x := 1 + 1 - 1 in x = x. +Proof. +intros x. +unfold &x at 1. +let x := reference:(Nat.sub) in unfold Nat.add, $x in x. +reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +exists 0, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +eexists _, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +refine '(let x := 0 in _). +eexists; exists &x; reflexivity. +Qed. + +Goal True. +Proof. +pose (X := True). +constructor. +Qed. + +Goal True. +Proof. +pose True as X. +constructor. +Qed. + +Goal True. +Proof. +let x := @foo in +set ($x := True) in * |-. +constructor. +Qed. + +Goal 0 = 0. +Proof. +remember 0 as n eqn: foo at 1. +rewrite foo. +reflexivity. +Qed. + +Goal True. +Proof. +assert (H := 0 + 0). +constructor. +Qed. + +Goal True. +Proof. +assert (exists n, n = 0) as [n Hn]. ++ exists 0; reflexivity. ++ exact I. +Qed. + +Goal True -> True. +Proof. +assert (H : 0 + 0 = 0) by reflexivity. +intros x; exact x. +Qed. + +Goal 1 + 1 = 2. +Proof. +change (?a + 1 = 2) with (2 = $a + 1). +reflexivity. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl). +destruct H. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl) as []. +Qed. diff --git a/vendor/Ltac2/tests/matching.v b/vendor/Ltac2/tests/matching.v new file mode 100644 index 0000000000..4338cbd32f --- /dev/null +++ b/vendor/Ltac2/tests/matching.v @@ -0,0 +1,71 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 Type exn ::= [ Nope ]. + +Ltac2 check_id id id' := match Ident.equal id id' with +| true => () +| false => Control.throw Nope +end. + +Goal True -> False. +Proof. +Fail +let b := { contents := true } in +let f c := + match b.(contents) with + | true => Message.print (Message.of_constr c); b.(contents) := false; fail + | false => () + end +in +(** This fails because the matching is not allowed to backtrack once + it commits to a branch*) +lazy_match! '(nat -> bool) with context [?a] => f a end. +lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. + +(** This one works by taking the second match context, i.e. ?a := nat *) +let b := { contents := true } in +let f c := + match b.(contents) with + | true => b.(contents) := false; fail + | false => Message.print (Message.of_constr c) + end +in +match! '(nat -> bool) with context [?a] => f a end. +Abort. + +Goal forall (i j : unit) (x y : nat) (b : bool), True. +Proof. +Fail match! goal with +| [ h : ?t, h' : ?t |- _ ] => () +end. +intros i j x y b. +match! goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @x; + check_id h' @y +end. +match! reverse goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @j; + check_id h' @i +end. +Abort. + +(* Check #79 *) +Goal 2 = 3. + Control.plus + (fun () + => lazy_match! goal with + | [ |- 2 = 3 ] => Control.zero (Tactic_failure None) + | [ |- 2 = _ ] => Control.zero (Tactic_failure (Some (Message.of_string "should not be printed"))) + end) + (fun e + => match e with + | Tactic_failure c + => match c with + | None => () + | _ => Control.zero e + end + | e => Control.zero e + end). +Abort. diff --git a/vendor/Ltac2/tests/quot.v b/vendor/Ltac2/tests/quot.v new file mode 100644 index 0000000000..624c4ad0c1 --- /dev/null +++ b/vendor/Ltac2/tests/quot.v @@ -0,0 +1,26 @@ +Require Import Ltac2.Ltac2. + +(** Test for quotations *) + +Ltac2 ref0 () := reference:(&x). +Ltac2 ref1 () := reference:(nat). +Ltac2 ref2 () := reference:(Datatypes.nat). +Fail Ltac2 ref () := reference:(i_certainly_dont_exist). +Fail Ltac2 ref () := reference:(And.Me.neither). + +Goal True. +Proof. +let x := constr:(I) in +let y := constr:((fun z => z) $x) in +Control.refine (fun _ => y). +Qed. + +Goal True. +Proof. +(** Here, Ltac2 should not put its variables in the same environment as + Ltac1 otherwise the second binding fails as x is bound but not an + ident. *) +let x := constr:(I) in +let y := constr:((fun x => x) $x) in +Control.refine (fun _ => y). +Qed. diff --git a/vendor/Ltac2/tests/rebind.v b/vendor/Ltac2/tests/rebind.v new file mode 100644 index 0000000000..e1c20a2059 --- /dev/null +++ b/vendor/Ltac2/tests/rebind.v @@ -0,0 +1,34 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 mutable foo () := constructor. + +Goal True. +Proof. +foo (). +Qed. + +Ltac2 Set foo := fun _ => fail. + +Goal True. +Proof. +Fail foo (). +constructor. +Qed. + +(** Not the right type *) +Fail Ltac2 Set foo := 0. + +Ltac2 bar () := (). + +(** Cannot redefine non-mutable tactics *) +Fail Ltac2 Set bar := fun _ => (). + +(** Subtype check *) + +Ltac2 mutable rec f x := f x. + +Fail Ltac2 Set f := fun x => x. + +Ltac2 mutable g x := x. + +Ltac2 Set g := f. diff --git a/vendor/Ltac2/tests/stuff/ltac2.v b/vendor/Ltac2/tests/stuff/ltac2.v new file mode 100644 index 0000000000..370bc70d15 --- /dev/null +++ b/vendor/Ltac2/tests/stuff/ltac2.v @@ -0,0 +1,143 @@ +Require Import Ltac2.Ltac2. + +Ltac2 foo (_ : int) := + let f (x : int) := x in + let _ := f 0 in + f 1. + +Print Ltac2 foo. + +Import Control. + +Ltac2 exact x := refine (fun () => x). + +Print Ltac2 refine. +Print Ltac2 exact. + +Ltac2 foo' () := ident:(bla). + +Print Ltac2 foo'. + +Ltac2 bar x h := match x with +| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) +| Some x => x +end. + +Print Ltac2 bar. + +Ltac2 qux := Some 0. + +Print Ltac2 qux. + +Ltac2 Type foo := [ Foo (int) ]. + +Fail Ltac2 qux0 := Foo None. + +Ltac2 Type 'a ref := { mutable contents : 'a }. + +Fail Ltac2 qux0 := { contents := None }. +Ltac2 foo0 () := { contents := None }. + +Print Ltac2 foo0. + +Ltac2 qux0 x := x.(contents). +Ltac2 qux1 x := x.(contents) := x.(contents). + +Ltac2 qux2 := ([1;2], true). + +Print Ltac2 qux0. +Print Ltac2 qux1. +Print Ltac2 qux2. + +Import Control. + +Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). + +Print Ltac2 qux3. + +Ltac2 Type rec nat := [ O | S (nat) ]. + +Ltac2 message_of_nat n := +let rec aux n := +match n with +| O => Message.of_string "O" +| S n => Message.concat (Message.of_string "S") (aux n) +end in aux n. + +Print Ltac2 message_of_nat. + +Ltac2 numgoals () := + let r := { contents := O } in + enter (fun () => r.(contents) := S (r.(contents))); + r.(contents). + +Print Ltac2 numgoals. + +Goal True /\ False. +Proof. +let n := numgoals () in Message.print (message_of_nat n). +refine (fun () => open_constr:((fun x => conj _ _) 0)); (). +let n := numgoals () in Message.print (message_of_nat n). + +Fail (hyp ident:(x)). +Fail (enter (fun () => hyp ident:(There_is_no_spoon); ())). + +enter (fun () => Message.print (Message.of_string "foo")). + +enter (fun () => Message.print (Message.of_constr (goal ()))). +Fail enter (fun () => Message.print (Message.of_constr (qux3 ident:(x)))). +enter (fun () => plus (fun () => constr:(_); ()) (fun _ => ())). +plus + (fun () => enter (fun () => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). +let x := { contents := 0 } in +let x := x.(contents) := x.(contents) in x. +Abort. + +Ltac2 Type exn ::= [ Foo ]. + +Goal True. +Proof. +plus (fun () => zero Foo) (fun _ => ()). +Abort. + +Ltac2 Type exn ::= [ Bar (string) ]. + +Goal True. +Proof. +Fail zero (Bar "lol"). +Abort. + +Ltac2 Notation "refine!" c(thunk(constr)) := refine c. + +Goal True. +Proof. +refine! I. +Abort. + +Goal True. +Proof. +let x () := plus (fun () => 0) (fun _ => 1) in +match case x with +| Val x => + match x with + | (x, k) => Message.print (Message.of_int (k Not_found)) + end +| Err x => Message.print (Message.of_string "Err") +end. +Abort. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +refine (fun () => '(fun H => _)). +Std.case true (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). +refine (fun () => 'eq_refl). +Qed. + +Goal forall x, 1 + x = x + 1. +Proof. +refine (fun () => '(fun x => _)). +Std.cbv { + Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; + Std.rZeta := true; Std.rDelta := true; Std.rConst := []; +} { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. +Abort. diff --git a/vendor/Ltac2/tests/tacticals.v b/vendor/Ltac2/tests/tacticals.v new file mode 100644 index 0000000000..1a2fbcbb37 --- /dev/null +++ b/vendor/Ltac2/tests/tacticals.v @@ -0,0 +1,34 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Goal True. +Proof. +Fail fail. +Fail solve [ () ]. +try fail. +repeat fail. +repeat (). +solve [ constructor ]. +Qed. + +Goal True. +Proof. +first [ + Message.print (Message.of_string "Yay"); fail +| constructor +| Message.print (Message.of_string "I won't be printed") +]. +Qed. + +Goal True /\ True. +Proof. +Fail split > [ split | |]. +split > [split | split]. +Qed. + +Goal True /\ (True -> True) /\ True. +Proof. +split > [ | split] > [split | .. | split]. +intros H; refine &H. +Qed. diff --git a/vendor/Ltac2/tests/typing.v b/vendor/Ltac2/tests/typing.v new file mode 100644 index 0000000000..9f18292716 --- /dev/null +++ b/vendor/Ltac2/tests/typing.v @@ -0,0 +1,72 @@ +Require Import Ltac2.Ltac2. + +(** Ltac2 is typed à la ML. *) + +Ltac2 test0 n := Int.add n 1. + +Print Ltac2 test0. + +Ltac2 test1 () := test0 0. + +Print Ltac2 test1. + +Fail Ltac2 test2 () := test0 true. + +Fail Ltac2 test2 () := test0 0 0. + +Ltac2 test3 f x := x, (f x, x). + +Print Ltac2 test3. + +(** Polymorphism *) + +Ltac2 rec list_length l := +match l with +| [] => 0 +| x :: l => Int.add 1 (list_length l) +end. + +Print Ltac2 list_length. + +(** Pattern-matching *) + +Ltac2 ifb b f g := match b with +| true => f () +| false => g () +end. + +Print Ltac2 ifb. + +Ltac2 if_not_found e f g := match e with +| Not_found => f () +| _ => g () +end. + +Fail Ltac2 ifb' b f g := match b with +| true => f () +end. + +Fail Ltac2 if_not_found' e f g := match e with +| Not_found => f () +end. + +(** Reimplementing 'do'. Return value of the function useless. *) + +Ltac2 rec do n tac := match Int.equal n 0 with +| true => () +| false => tac (); do (Int.sub n 1) tac +end. + +Print Ltac2 do. + +(** Non-function pure values are OK. *) + +Ltac2 tuple0 := ([1; 2], true, (fun () => "yay")). + +Print Ltac2 tuple0. + +(** Impure values are not. *) + +Fail Ltac2 not_a_value := { contents := 0 }. +Fail Ltac2 not_a_value := "nope". +Fail Ltac2 not_a_value := list_length []. diff --git a/vendor/Ltac2/theories/Array.v b/vendor/Ltac2/theories/Array.v new file mode 100644 index 0000000000..11b64e3515 --- /dev/null +++ b/vendor/Ltac2/theories/Array.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'a array := "ltac2" "array_make". +Ltac2 @external length : 'a array -> int := "ltac2" "array_length". +Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". +Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/vendor/Ltac2/theories/Char.v b/vendor/Ltac2/theories/Char.v new file mode 100644 index 0000000000..29fef60f2c --- /dev/null +++ b/vendor/Ltac2/theories/Char.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char := "ltac2" "char_of_int". +Ltac2 @external to_int : char -> int := "ltac2" "char_to_int". diff --git a/vendor/Ltac2/theories/Constr.v b/vendor/Ltac2/theories/Constr.v new file mode 100644 index 0000000000..d8d222730e --- /dev/null +++ b/vendor/Ltac2/theories/Constr.v @@ -0,0 +1,72 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr := "ltac2" "constr_type". +(** Return the type of a term *) + +Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". +(** Strict syntactic equality: only up to α-conversion and evar expansion *) + +Module Unsafe. + +(** Low-level access to kernel terms. Use with care! *) + +Ltac2 Type case. + +Ltac2 Type kind := [ +| Rel (int) +| Var (ident) +| Meta (meta) +| Evar (evar, constr array) +| Sort (sort) +| Cast (constr, cast, constr) +| Prod (ident option, constr, constr) +| Lambda (ident option, constr, constr) +| LetIn (ident option, constr, constr, constr) +| App (constr, constr array) +| Constant (constant, instance) +| Ind (inductive, instance) +| Constructor (constructor, instance) +| Case (case, constr, constr, constr array) +| Fix (int array, int, ident option array, constr array, constr array) +| CoFix (int, ident option array, constr array, constr array) +| Proj (projection, constr) +]. + +Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". + +Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". + +Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". +(** Checks that a constr generated by unsafe means is indeed safe in the + current environment, and returns it, or the error otherwise. Panics if + not focussed. *) + +Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". +(** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with + [r₁;...;rₙ] in [c]. *) + +Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "constr_closenl". +(** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with + [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) + +Ltac2 @ external case : inductive -> case := "ltac2" "constr_case". +(** Generate the case information for a given inductive type. *) + +Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "constr_constructor". +(** Generate the i-th constructor for a given inductive type. Indexing starts + at 0. Panics if there is no such constructor. *) + +End Unsafe. + +Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". +(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a + focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is + the proof built by the tactic. *) diff --git a/vendor/Ltac2/theories/Control.v b/vendor/Ltac2/theories/Control.v new file mode 100644 index 0000000000..071c2ea8ce --- /dev/null +++ b/vendor/Ltac2/theories/Control.v @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a := "ltac2" "throw". +(** Fatal exception throwing. This does not induce backtracking. *) + +(** Generic backtracking control *) + +Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". +Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". +Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". +Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". +Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". +Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". +Ltac2 @ external case : (unit -> 'a) -> ('a * (exn -> 'a)) result := "ltac2" "case". + +(** Proof state manipulation *) + +Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". +Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". +Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". + +Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". +(** Adds the given evar to the list of goals as the last one. If it is + already defined in the current state, don't do anything. Panics if the + evar is not in the current state. *) + +Ltac2 @ external progress : (unit -> 'a) -> 'a := "ltac2" "progress". + +(** Goal inspection *) + +Ltac2 @ external goal : unit -> constr := "ltac2" "goal". +(** Panics if there is not exactly one goal under focus. Otherwise returns + the conclusion of this goal. *) + +Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, looks for the section variable with the given name. + If there is one, looks for the hypothesis with the given name. *) + +Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" "hyps". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, returns the list of section variables. + If there is one, returns the list of hypotheses. In both cases, the + list is ordered with rightmost values being last introduced. *) + +(** Refinement *) + +Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". + +(** Evars *) + +Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_holes". +(** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if + all evars generated by the call to [x] have not been solved when [f] + returns. *) + +(** Misc *) + +Ltac2 @ external time : string option -> (unit -> 'a) -> 'a := "ltac2" "time". +(** Displays the time taken by a tactic to evaluate. *) + +Ltac2 @ external abstract : ident option -> (unit -> unit) -> unit := "ltac2" "abstract". +(** Abstract a subgoal. *) + +Ltac2 @ external check_interrupt : unit -> unit := "ltac2" "check_interrupt". +(** For internal use. *) diff --git a/vendor/Ltac2/theories/Env.v b/vendor/Ltac2/theories/Env.v new file mode 100644 index 0000000000..c9b250f4ba --- /dev/null +++ b/vendor/Ltac2/theories/Env.v @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Std.reference option := "ltac2" "env_get". +(** Returns the global reference corresponding to the absolute name given as + argument if it exists. *) + +Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". +(** Returns the list of all global references whose absolute name contains + the argument list as a prefix. *) + +Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". +(** Returns the absolute name of the given reference. Panics if the reference + does not exist. *) + +Ltac2 @ external instantiate : Std.reference -> constr := "ltac2" "env_instantiate". +(** Returns a fresh instance of the corresponding reference, in particular + generating fresh universe variables and constraints when this reference is + universe-polymorphic. *) diff --git a/vendor/Ltac2/theories/Fresh.v b/vendor/Ltac2/theories/Fresh.v new file mode 100644 index 0000000000..5e876bb077 --- /dev/null +++ b/vendor/Ltac2/theories/Fresh.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> t := "ltac2" "fresh_free_union". + +Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". + +Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". + +End Free. + +Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". +(** Generate a fresh identifier with the given base name which is not a + member of the provided set of free variables. *) diff --git a/vendor/Ltac2/theories/Ident.v b/vendor/Ltac2/theories/Ident.v new file mode 100644 index 0000000000..55456afbe2 --- /dev/null +++ b/vendor/Ltac2/theories/Ident.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> bool := "ltac2" "ident_equal". + +Ltac2 @ external of_string : string -> t option := "ltac2" "ident_of_string". + +Ltac2 @ external to_string : t -> string := "ltac2" "ident_to_string". diff --git a/vendor/Ltac2/theories/Init.v b/vendor/Ltac2/theories/Init.v new file mode 100644 index 0000000000..16e7d7a6f9 --- /dev/null +++ b/vendor/Ltac2/theories/Init.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> bool := "ltac2" "int_equal". +Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". +Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". +Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". +Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". +Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/vendor/Ltac2/theories/Ltac1.v b/vendor/Ltac2/theories/Ltac1.v new file mode 100644 index 0000000000..c4e0b606d0 --- /dev/null +++ b/vendor/Ltac2/theories/Ltac1.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t := "ltac2" "ltac1_ref". +(** Returns the Ltac1 definition with the given absolute name. *) + +Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". +(** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning + anything. *) + +Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". +(** Applies an Ltac1 value to a list of arguments, and provides the result in + CPS style. It does **not** run the returned value. *) + +(** Conversion functions *) + +Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". +Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". + +Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". +Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/vendor/Ltac2/theories/Ltac2.v b/vendor/Ltac2/theories/Ltac2.v new file mode 100644 index 0000000000..ac90f63560 --- /dev/null +++ b/vendor/Ltac2/theories/Ltac2.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit := "ltac2" "print". + +Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". + +Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". + +Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". + +Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/vendor/Ltac2/theories/Notations.v b/vendor/Ltac2/theories/Notations.v new file mode 100644 index 0000000000..f4621656d6 --- /dev/null +++ b/vendor/Ltac2/theories/Notations.v @@ -0,0 +1,568 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* f e +| Val ans => + let (x, k) := ans in + Control.plus (fun _ => x) k +end. + +Ltac2 ifcatch t s f := +match Control.case t with +| Err e => f e +| Val ans => + let (x, k) := ans in + Control.plus (fun _ => s x) (fun e => s (k e)) +end. + +Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero (Tactic_failure None)). + +Ltac2 Notation fail := fail0 (). + +Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). + +Ltac2 Notation try := try0. + +Ltac2 rec repeat0 (t : unit -> unit) := + Control.enter (fun () => + ifcatch (fun _ => Control.progress t) + (fun _ => Control.check_interrupt (); repeat0 t) (fun _ => ())). + +Ltac2 Notation repeat := repeat0. + +Ltac2 dispatch0 t (head, tail) := + match tail with + | None => Control.enter (fun _ => t (); Control.dispatch head) + | Some tacs => + let (def, rem) := tacs in + Control.enter (fun _ => t (); Control.extend head def rem) + end. + +Ltac2 Notation t(thunk(self)) ">" "[" l(dispatch) "]" : 4 := dispatch0 t l. + +Ltac2 do0 n t := + let rec aux n t := match Int.equal n 0 with + | true => () + | false => t (); aux (Int.sub n 1) t + end in + aux (n ()) t. + +Ltac2 Notation do := do0. + +Ltac2 Notation once := Control.once. + +Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). + +Ltac2 Notation progress := progress0. + +Ltac2 rec first0 tacs := +match tacs with +| [] => Control.zero (Tactic_failure None) +| tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) +end. + +Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs. + +Ltac2 complete tac := + let ans := tac () in + Control.enter (fun () => Control.zero (Tactic_failure None)); + ans. + +Ltac2 rec solve0 tacs := +match tacs with +| [] => Control.zero (Tactic_failure None) +| tac :: tacs => + Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) +end. + +Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. + +Ltac2 time0 tac := Control.time None tac. + +Ltac2 Notation time := time0. + +Ltac2 abstract0 tac := Control.abstract None tac. + +Ltac2 Notation abstract := abstract0. + +(** Base tactics *) + +(** Note that we redeclare notations that can be parsed as mere identifiers + as abbreviations, so that it allows to parse them as function arguments + without having to write them within parentheses. *) + +(** Enter and check evar resolution *) +Ltac2 enter_h ev f arg := +match ev with +| true => Control.enter (fun () => f ev (arg ())) +| false => + Control.enter (fun () => + Control.with_holes arg (fun x => f ev x)) +end. + +Ltac2 intros0 ev p := + Control.enter (fun () => Std.intros false p). + +Ltac2 Notation "intros" p(intropatterns) := intros0 false p. +Ltac2 Notation intros := intros. + +Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. +Ltac2 Notation eintros := eintros. + +Ltac2 split0 ev bnd := + enter_h ev Std.split bnd. + +Ltac2 Notation "split" bnd(thunk(with_bindings)) := split0 false bnd. +Ltac2 Notation split := split. + +Ltac2 Notation "esplit" bnd(thunk(with_bindings)) := split0 true bnd. +Ltac2 Notation esplit := esplit. + +Ltac2 exists0 ev bnds := match bnds with +| [] => split0 ev (fun () => Std.NoBindings) +| _ => + let rec aux bnds := match bnds with + | [] => () + | bnd :: bnds => split0 ev bnd; aux bnds + end in + aux bnds +end. + +Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. +(* Ltac2 Notation exists := exists. *) + +Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. +Ltac2 Notation eexists := eexists. + +Ltac2 left0 ev bnd := enter_h ev Std.left bnd. + +Ltac2 Notation "left" bnd(thunk(with_bindings)) := left0 false bnd. +Ltac2 Notation left := left. + +Ltac2 Notation "eleft" bnd(thunk(with_bindings)) := left0 true bnd. +Ltac2 Notation eleft := eleft. + +Ltac2 right0 ev bnd := enter_h ev Std.right bnd. + +Ltac2 Notation "right" bnd(thunk(with_bindings)) := right0 false bnd. +Ltac2 Notation right := right. + +Ltac2 Notation "eright" bnd(thunk(with_bindings)) := right0 true bnd. +Ltac2 Notation eright := eright. + +Ltac2 constructor0 ev n bnd := + enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. + +Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). +Ltac2 Notation constructor := constructor. +Ltac2 Notation "constructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 false n bnd. + +Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). +Ltac2 Notation econstructor := econstructor. +Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. + +Ltac2 specialize0 c pat := + enter_h false (fun _ c => Std.specialize c pat) c. + +Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("as", intropattern))) := + specialize0 c ipat. + +Ltac2 elim0 ev c bnd use := + let f ev (c, bnd, use) := Std.elim ev (c, bnd) use in + enter_h ev f (fun () => c (), bnd (), use ()). + +Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := + elim0 false c bnd use. + +Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := + elim0 true c bnd use. + +Ltac2 apply0 adv ev cb cl := + Std.apply adv ev cb cl. + +Ltac2 Notation "eapply" + cb(list1(thunk(seq(constr, with_bindings)), ",")) + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := + apply0 true true cb cl. + +Ltac2 Notation "apply" + cb(list1(thunk(seq(constr, with_bindings)), ",")) + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := + apply0 true false cb cl. + +Ltac2 default_on_concl cl := +match cl with +| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 pose0 ev p := + enter_h ev (fun ev (na, p) => Std.pose na p) p. + +Ltac2 Notation "pose" p(thunk(pose)) := + pose0 false p. + +Ltac2 Notation "epose" p(thunk(pose)) := + pose0 true p. + +Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := + Std.set false p (default_on_concl cl). + +Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := + Std.set true p (default_on_concl cl). + +Ltac2 assert0 ev ast := + enter_h ev (fun _ ast => Std.assert ast) ast. + +Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. + +Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. + +Ltac2 default_everywhere cl := +match cl with +| None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 Notation "remember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember false na c pat (default_everywhere cl). + +Ltac2 Notation "eremember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember true na c pat (default_everywhere cl). + +Ltac2 induction0 ev ic use := + let f ev use := Std.induction ev ic use in + enter_h ev f use. + +Ltac2 Notation "induction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + induction0 false ic use. + +Ltac2 Notation "einduction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + induction0 true ic use. + +Ltac2 generalize0 gen := + enter_h false (fun _ gen => Std.generalize gen) gen. + +Ltac2 Notation "generalize" + gen(thunk(list1(seq (open_constr, occurrences, opt(seq("as", ident))), ","))) := + generalize0 gen. + +Ltac2 destruct0 ev ic use := + let f ev use := Std.destruct ev ic use in + enter_h ev f use. + +Ltac2 Notation "destruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + destruct0 false ic use. + +Ltac2 Notation "edestruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + destruct0 true ic use. + +Ltac2 Notation "simple" "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.SimpleInversion arg pat ids. + +Ltac2 Notation "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversion arg pat ids. + +Ltac2 Notation "inversion_clear" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversionClear arg pat ids. + +Ltac2 Notation "red" cl(opt(clause)) := + Std.red (default_on_concl cl). +Ltac2 Notation red := red. + +Ltac2 Notation "hnf" cl(opt(clause)) := + Std.hnf (default_on_concl cl). +Ltac2 Notation hnf := hnf. + +Ltac2 Notation "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.simpl s pl (default_on_concl cl). +Ltac2 Notation simpl := simpl. + +Ltac2 Notation "cbv" s(strategy) cl(opt(clause)) := + Std.cbv s (default_on_concl cl). +Ltac2 Notation cbv := cbv. + +Ltac2 Notation "cbn" s(strategy) cl(opt(clause)) := + Std.cbn s (default_on_concl cl). +Ltac2 Notation cbn := cbn. + +Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := + Std.lazy s (default_on_concl cl). +Ltac2 Notation lazy := lazy. + +Ltac2 Notation "unfold" pl(list1(seq(reference, occurrences), ",")) cl(opt(clause)) := + Std.unfold pl (default_on_concl cl). + +Ltac2 fold0 pl cl := + let cl := default_on_concl cl in + Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). + +Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := + fold0 pl cl. + +Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := + Std.pattern pl (default_on_concl cl). + +Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.vm pl (default_on_concl cl). +Ltac2 Notation vm_compute := vm_compute. + +Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.native pl (default_on_concl cl). +Ltac2 Notation native_compute := native_compute. + +Ltac2 change0 p cl := + let (pat, c) := p in + Std.change pat c (default_on_concl cl). + +Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. + +Ltac2 rewrite0 ev rw cl tac := + let cl := default_on_concl cl in + Std.rewrite ev rw cl tac. + +Ltac2 Notation "rewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 false rw cl tac. + +Ltac2 Notation "erewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 true rw cl tac. + +(** coretactics *) + +Ltac2 exact0 ev c := + Control.enter (fun _ => + match ev with + | true => + let c := c () in + Control.refine (fun _ => c) + | false => + Control.with_holes c (fun c => Control.refine (fun _ => c)) + end + ). + +Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. +Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. + +Ltac2 Notation "intro" id(opt(ident)) mv(opt(move_location)) := Std.intro id mv. +Ltac2 Notation intro := intro. + +Ltac2 Notation "move" id(ident) mv(move_location) := Std.move id mv. + +Ltac2 Notation reflexivity := Std.reflexivity (). + +Ltac2 symmetry0 cl := + Std.symmetry (default_on_concl cl). + +Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. +Ltac2 Notation symmetry := symmetry. + +Ltac2 Notation "revert" ids(list1(ident)) := Std.revert ids. + +Ltac2 Notation assumption := Std.assumption (). + +Ltac2 Notation etransitivity := Std.etransitivity (). + +Ltac2 Notation admit := Std.admit (). + +Ltac2 clear0 ids := match ids with +| [] => Std.keep [] +| _ => Std.clear ids +end. + +Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. +Ltac2 Notation "clear" "-" ids(list1(ident)) := Std.keep ids. +Ltac2 Notation clear := clear. + +Ltac2 Notation refine := Control.refine. + +(** extratactics *) + +Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). + +Ltac2 Notation "absurd" c(thunk(open_constr)) := absurd0 c. + +Ltac2 subst0 ids := match ids with +| [] => Std.subst_all () +| _ => Std.subst ids +end. + +Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. +Ltac2 Notation subst := subst. + +Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := + Std.discriminate false arg. +Ltac2 Notation discriminate := discriminate. + +Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := + Std.discriminate true arg. +Ltac2 Notation ediscriminate := ediscriminate. + +Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection false ipat arg. + +Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection true ipat arg. + +(** Auto *) + +Ltac2 default_db dbs := match dbs with +| None => Some [] +| Some dbs => + match dbs with + | None => None + | Some l => Some l + end +end. + +Ltac2 default_list use := match use with +| None => [] +| Some use => use +end. + +Ltac2 trivial0 use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.trivial Std.Off use dbs. + +Ltac2 Notation "trivial" + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := trivial0 use dbs. + +Ltac2 Notation trivial := trivial. + +Ltac2 auto0 n use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.auto Std.Off n use dbs. + +Ltac2 Notation "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := auto0 n use dbs. + +Ltac2 Notation auto := auto. + +Ltac2 new_eauto0 n use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.new_auto Std.Off n use dbs. + +Ltac2 Notation "new" "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := new_eauto0 n use dbs. + +Ltac2 eauto0 n p use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.eauto Std.Off n p use dbs. + +Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := eauto0 n p use dbs. + +Ltac2 Notation eauto := eauto. + +Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto None n dbs. + +Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto (Some Std.BFS) n dbs. + +Ltac2 Notation typeclasses_eauto := typeclasses_eauto. + +(** Congruence *) + +Ltac2 f_equal0 () := ltac1:(f_equal). +Ltac2 Notation f_equal := f_equal0 (). + +(** Firstorder *) + +Ltac2 firstorder0 tac refs ids := + let refs := default_list refs in + let ids := default_list ids in + Std.firstorder tac refs ids. + +Ltac2 Notation "firstorder" + tac(opt(thunk(tactic))) + refs(opt(seq("using", list1(reference, ",")))) + ids(opt(seq("with", list1(ident)))) := firstorder0 tac refs ids. + +(** now *) + +Ltac2 now0 t := t (); ltac1:(easy). +Ltac2 Notation "now" t(thunk(self)) := now0 t. diff --git a/vendor/Ltac2/theories/Pattern.v b/vendor/Ltac2/theories/Pattern.v new file mode 100644 index 0000000000..8d1fb0cd8a --- /dev/null +++ b/vendor/Ltac2/theories/Pattern.v @@ -0,0 +1,145 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* context := + "ltac2" "pattern_empty_context". +(** A trivial context only made of the hole. *) + +Ltac2 @ external matches : t -> constr -> (ident * constr) list := + "ltac2" "pattern_matches". +(** If the term matches the pattern, returns the bound variables. If it doesn't, + fail with [Match_failure]. Panics if not focussed. *) + +Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := + "ltac2" "pattern_matches_subterm". +(** Returns a stream of results corresponding to all of the subterms of the term + that matches the pattern as in [matches]. The stream is encoded as a + backtracking value whose last exception is [Match_failure]. The additional + value compared to [matches] is the context of the match, to be filled with + the instantiate function. *) + +Ltac2 @ external matches_vect : t -> constr -> constr array := + "ltac2" "pattern_matches_vect". +(** Internal version of [matches] that does not return the identifiers. *) + +Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := + "ltac2" "pattern_matches_subterm_vect". +(** Internal version of [matches_subterms] that does not return the identifiers. *) + +Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t) -> + ident array * context array * constr array * context := + "ltac2" "pattern_matches_goal". +(** Given a list of patterns [hpats] for hypotheses and one pattern [cpat] for the + conclusion, [matches_goal rev hpats cpat] produces (a stream of) tuples of: + - An array of idents, whose size is the length of [hpats], corresponding to the + name of matched hypotheses. + - An array of contexts, whose size is the length of [hpats], corresponding to + the contexts matched for every hypothesis pattern. In case the match kind of + a hypothesis was [MatchPattern], the corresponding context is ensured to be empty. + - An array of terms, whose size is the total number of pattern variables without + duplicates. Terms are ordered by identifier order, e.g. ?a comes before ?b. + - A context corresponding to the conclusion, which is ensured to be empty if + the kind of [cpat] was [MatchPattern]. + This produces a backtracking stream of results containing all the possible + result combinations. The order of considered hypotheses is reversed if [rev] + is true. +*) + +Ltac2 @ external instantiate : context -> constr -> constr := + "ltac2" "pattern_instantiate". +(** Fill the hole of a context with the given term. *) + +(** Implementation of Ltac matching over terms and goals *) + +Ltac2 lazy_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (knd, pat, f) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + fun _ => f context bind) + | MatchContext => + (fun _ => + let (context, bind) := matches_subterm_vect pat t in + fun _ => f context bind) + end in + Control.plus p next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (knd, pat, f) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + f context bind) + | MatchContext => + (fun _ => + let (context, bind) := matches_subterm_vect pat t in + f context bind) + end in + Control.plus p next + end in + interp pats. + +Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). + +Ltac2 lazy_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (pat, f) := p in + let (phyps, pconcl) := pat in + let cur _ := + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in + fun _ => f hids hctx subst cctx + in + Control.plus cur next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (pat, f) := p in + let (phyps, pconcl) := pat in + let cur _ := + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in + f hids hctx subst cctx + in + Control.plus cur next + end in + interp pats. + +Ltac2 one_goal_match0 rev pats := Control.once (fun _ => multi_goal_match0 rev pats). diff --git a/vendor/Ltac2/theories/Std.v b/vendor/Ltac2/theories/Std.v new file mode 100644 index 0000000000..73b2ba02c4 --- /dev/null +++ b/vendor/Ltac2/theories/Std.v @@ -0,0 +1,263 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr), intro_pattern) +| IntroRewrite (bool) +] +with or_and_intro_pattern := [ +| IntroOrPattern (intro_pattern list list) +| IntroAndPattern (intro_pattern list) +]. + +Ltac2 Type destruction_arg := [ +| ElimOnConstr (unit -> constr_with_bindings) +| ElimOnIdent (ident) +| ElimOnAnonHyp (int) +]. + +Ltac2 Type induction_clause := { + indcl_arg : destruction_arg; + indcl_eqn : intro_pattern_naming option; + indcl_as : or_and_intro_pattern option; + indcl_in : clause option; +}. + +Ltac2 Type assertion := [ +| AssertType (intro_pattern option, constr, (unit -> unit) option) +| AssertValue (ident, constr) +]. + +Ltac2 Type repeat := [ +| Precisely (int) +| UpTo (int) +| RepeatStar +| RepeatPlus +]. + +Ltac2 Type orientation := [ LTR | RTL ]. + +Ltac2 Type rewriting := { + rew_orient : orientation option; + rew_repeat : repeat; + rew_equatn : (unit -> constr_with_bindings); +}. + +Ltac2 Type evar_flag := bool. +Ltac2 Type advanced_flag := bool. + +Ltac2 Type move_location := [ +| MoveAfter (ident) +| MoveBefore (ident) +| MoveFirst +| MoveLast +]. + +Ltac2 Type inversion_kind := [ +| SimpleInversion +| FullInversion +| FullInversionClear +]. + +(** Standard, built-in tactics. See Ltac1 for documentation. *) + +Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". + +Ltac2 @ external apply : advanced_flag -> evar_flag -> + (unit -> constr_with_bindings) list -> (ident * (intro_pattern option)) option -> unit := "ltac2" "tac_apply". + +Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". +Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". + +Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". + +Ltac2 @ external assert : assertion -> unit := "ltac2" "tac_assert". +Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". + +Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". +Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". + +Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". + +Ltac2 @ external destruct : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external induction : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". +Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". +Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_simpl". +Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". +Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". +Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". +Ltac2 @ external unfold : (reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". +Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". +Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". +Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". +Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". + +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_hnf : constr -> constr := "ltac2" "eval_hnf". +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_simpl : red_flags -> (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_simpl". +Ltac2 @ external eval_cbv : red_flags -> constr -> constr := "ltac2" "eval_cbv". +Ltac2 @ external eval_cbn : red_flags -> constr -> constr := "ltac2" "eval_cbn". +Ltac2 @ external eval_lazy : red_flags -> constr -> constr := "ltac2" "eval_lazy". +Ltac2 @ external eval_unfold : (reference * occurrences) list -> constr -> constr := "ltac2" "eval_unfold". +Ltac2 @ external eval_fold : constr list -> constr -> constr := "ltac2" "eval_fold". +Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr := "ltac2" "eval_pattern". +Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". +Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". + +Ltac2 @ external change : pattern option -> (constr array -> constr) -> clause -> unit := "ltac2" "tac_change". + +Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". + +Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". + +Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". + +Ltac2 @ external transitivity : constr -> unit := "ltac2" "tac_transitivity". + +Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". + +Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". + +Ltac2 @ external left : evar_flag -> bindings -> unit := "ltac2" "tac_left". +Ltac2 @ external right : evar_flag -> bindings -> unit := "ltac2" "tac_right". + +Ltac2 @ external constructor : evar_flag -> unit := "ltac2" "tac_constructor". +Ltac2 @ external split : evar_flag -> bindings -> unit := "ltac2" "tac_split". + +Ltac2 @ external constructor_n : evar_flag -> int -> bindings -> unit := "ltac2" "tac_constructorn". + +Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". + +Ltac2 @ external symmetry : clause -> unit := "ltac2" "tac_symmetry". + +Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". + +Ltac2 @ external revert : ident list -> unit := "ltac2" "tac_revert". + +Ltac2 @ external admit : unit -> unit := "ltac2" "tac_admit". + +Ltac2 @ external fix_ : ident option -> int -> unit := "ltac2" "tac_fix". +Ltac2 @ external cofix_ : ident option -> unit := "ltac2" "tac_cofix". + +Ltac2 @ external clear : ident list -> unit := "ltac2" "tac_clear". +Ltac2 @ external keep : ident list -> unit := "ltac2" "tac_keep". + +Ltac2 @ external clearbody : ident list -> unit := "ltac2" "tac_clearbody". + +Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". +Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". +Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". + +Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern option -> ident list option -> unit := "ltac2" "tac_inversion". + +(** coretactics *) + +Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". + +Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". + +Ltac2 @ external specialize : constr_with_bindings -> intro_pattern option -> unit := "ltac2" "tac_specialize". + +(** extratactics *) + +Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". +Ltac2 @ external injection : evar_flag -> intro_pattern list option -> destruction_arg option -> unit := "ltac2" "tac_injection". + +Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". +Ltac2 @ external contradiction : constr_with_bindings option -> unit := "ltac2" "tac_contradiction". + +Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> clause -> unit := "ltac2" "tac_autorewrite". + +Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". +Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". + +(** auto *) + +Ltac2 Type debug := [ Off | Info | Debug ]. + +Ltac2 Type strategy := [ BFS | DFS ]. + +Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". + +Ltac2 @ external auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_auto". + +Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_newauto". + +Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". + +Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". + +(** firstorder *) + +Ltac2 @ external firstorder : (unit -> unit) option -> reference list -> ident list -> unit := "ltac2" "tac_firstorder". diff --git a/vendor/Ltac2/theories/String.v b/vendor/Ltac2/theories/String.v new file mode 100644 index 0000000000..99e1dab76b --- /dev/null +++ b/vendor/Ltac2/theories/String.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char -> string := "ltac2" "string_make". +Ltac2 @external length : string -> int := "ltac2" "string_length". +Ltac2 @external get : string -> int -> char := "ltac2" "string_get". +Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/vendor/Ltac2/theories/dune b/vendor/Ltac2/theories/dune new file mode 100644 index 0000000000..1fe3ba28fe --- /dev/null +++ b/vendor/Ltac2/theories/dune @@ -0,0 +1,6 @@ +(coqlib + (name Ltac2) ; This determines the -R flag + (public_name ltac2.Ltac2) + (synopsis "Ltac 2 Plugin") + (libraries ltac2.plugin)) + -- cgit v1.2.3 From 7461f18cbe722610613bdd8c729665ac48395b6e Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 5 Apr 2019 21:21:53 +0200 Subject: [vernac] [ast] Make location info an attribute of vernaculars. This has been a mess for quite a while, we try to improve it. --- ide/idetop.ml | 12 ++--- plugins/funind/g_indfun.mlg | 2 +- plugins/funind/glob_term_to_relation.ml | 4 +- stm/proofBlockDelimiter.ml | 4 +- stm/stm.ml | 88 +++++++++++++++++---------------- stm/stm.mli | 4 +- stm/vernac_classifier.ml | 10 ++-- toplevel/coqloop.ml | 10 ++-- toplevel/g_toplevel.mlg | 10 ++-- toplevel/vernac.ml | 11 ++--- toplevel/vernac.mli | 2 +- vernac/g_vernac.mlg | 13 ++--- vernac/ppvernac.ml | 10 ++-- vernac/pvernac.ml | 2 +- vernac/pvernac.mli | 4 +- vernac/topfmt.ml | 4 +- vernac/topfmt.mli | 2 +- vernac/vernacentries.ml | 2 +- vernac/vernacentries.mli | 2 +- vernac/vernacexpr.ml | 11 +++-- vernac/vernacprop.ml | 35 ++++++------- 21 files changed, 120 insertions(+), 122 deletions(-) diff --git a/ide/idetop.ml b/ide/idetop.ml index 543ff924bd..d022200511 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -64,7 +64,7 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = +let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = let user_error s = try CErrors.user_err ?loc ~hdr:"IDE" (str s) with e -> @@ -72,14 +72,14 @@ let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = let info = Stateid.add info ~valid:last_valid Stateid.dummy in Exninfo.raise ~info e in - if is_debug ast then + if is_debug cmd then user_error "Debug mode not available in the IDE" -let ide_cmd_warns ~id {CAst.loc;v=ast} = +let ide_cmd_warns ~id ({ CAst.loc; _ } as cmd) = let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in - if is_known_option ast then + if is_known_option cmd then warn "Set this option from the IDE menu instead"; - if is_navigation_vernac ast || is_undo ast then + if is_navigation_vernac cmd || is_undo cmd then warn "Use IDE navigation instead" (** Interpretation (cf. [Ide_intf.interp]) *) @@ -137,7 +137,7 @@ let annotate phrase = | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) | Some ast -> (* XXX: Width should be a parameter of annotate... *) - Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast.CAst.v) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) (** Goal display *) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index a3973732ad..dbfc0fc91d 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -185,7 +185,7 @@ VERNAC COMMAND EXTEND Function | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) + (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacextend.VtSideff ids, _ when hard -> Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 45a4e61846..e15e167ff3 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1518,7 +1518,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1533,7 +1533,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index d13763cdec..2b32838964 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -99,7 +99,7 @@ let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) + recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) } | `Not -> `Leaks @@ -128,7 +128,7 @@ let dynamic_curly_brace doc { dynamic_switch = id } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) + recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) } | `Not -> `Leaks diff --git a/stm/stm.ml b/stm/stm.ml index e1ab45163a..3eade34448 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -119,7 +119,6 @@ let async_proofs_workers_extra_env = ref [||] type aast = { verbose : bool; - loc : Loc.t option; indentation : int; strlen : int; mutable expr : vernac_control; (* mutable: Proof using hinted by aux file *) @@ -1147,12 +1146,12 @@ end (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly reduced... *) -let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t = +let stm_vernac_interp ?proof ?route id st { verbose; expr } : Vernacstate.t = (* The Stm will gain the capability to interpret commmads affecting the whole document state, such as backtrack, etc... so we start to design the stm command interpreter now *) set_id_for_feedback ?route dummy_doc id; - Aux_file.record_in_aux_set_at ?loc (); + Aux_file.record_in_aux_set_at ?loc:expr.CAst.loc (); (* We need to check if a command should be filtered from * vernac_entries, as it cannot handle it. This should go away in * future refactorings. @@ -1173,7 +1172,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t | VernacShow ShowScript -> ShowScript.show_script (); st (* XX we are ignoring control here *) | _ -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (CAst.make ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st expr with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) @@ -1628,8 +1627,8 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_vernac_interp stop ~proof:(pobject, terminator) st - { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in + { verbose = false; indentation = 0; strlen = 0; + expr = CAst.make ?loc @@ VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1778,8 +1777,8 @@ end = struct (* {{{ *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp stop ~proof st - { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); + { verbose = false; indentation = 0; strlen = 0; + expr = CAst.make ?loc @@ VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); `OK proof end with e -> @@ -1791,10 +1790,11 @@ end = struct (* {{{ *) spc () ++ iprint (e, info)) | Some (_, cur) -> match VCS.visit cur with - | { step = `Cmd { cast = { loc } } } - | { step = `Fork (( { loc }, _, _, _), _) } - | { step = `Qed ( { qast = { loc } }, _) } - | { step = `Sideff (ReplayCommand { loc }, _) } -> + | { step = `Cmd { cast } } + | { step = `Fork (( cast, _, _, _), _) } + | { step = `Qed ( { qast = cast }, _) } + | { step = `Sideff (ReplayCommand cast, _) } -> + let loc = cast.expr.CAst.loc in let start, stop = Option.cata Loc.unloc (0,0) loc in msg_warning Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ @@ -2071,14 +2071,14 @@ end = struct (* {{{ *) f () let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id - { indentation; verbose; loc; expr = e; strlen } : unit + { indentation; verbose; expr = e; strlen } : unit = let e, time, batch, fail = - let rec find ~time ~batch ~fail = function - | VernacTime (batch,{CAst.v=e}) -> find ~time:true ~batch ~fail e - | VernacRedirect (_,{CAst.v=e}) -> find ~time ~batch ~fail e - | VernacFail {CAst.v=e} -> find ~time ~batch ~fail:true e - | e -> e, time, batch, fail in + let rec find ~time ~batch ~fail v = CAst.with_loc_val (fun ?loc -> function + | VernacTime (batch,e) -> find ~time:true ~batch ~fail e + | VernacRedirect (_,e) -> find ~time ~batch ~fail e + | VernacFail e -> find ~time ~batch ~fail:true e + | e -> CAst.make ?loc e, time, batch, fail) v in find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> @@ -2092,7 +2092,7 @@ end = struct (* {{{ *) Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in - let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in + let t_ast = (i, { indentation; verbose; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue { t_state = safe_id; t_state_fb = id; @@ -2241,7 +2241,7 @@ let collect_proof keep cur hd brkind id = let name = function | [] -> no_name | id :: _ -> Names.Id.to_string id in - let loc = (snd cur).loc in + let loc = (snd cur).expr.CAst.loc in let is_defined_expr = function | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true | _ -> false in @@ -2307,7 +2307,7 @@ let collect_proof keep cur hd brkind id = (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in - v.expr <- VernacExpr([], VernacProof(t, Some hint)); + v.expr <- CAst.map (fun _ -> VernacExpr([], VernacProof(t, Some hint))) v.expr; `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in @@ -2410,7 +2410,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* STATE: We use an updated state with proof *) let st = Vernacstate.freeze_interp_state ~marshallable:false in Option.iter (fun expr -> ignore(stm_vernac_interp id st { - verbose = true; loc = None; expr; indentation = 0; + verbose = true; expr; indentation = 0; strlen = 0 } )) recovery_command | _ -> assert false @@ -2530,7 +2530,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `ASync (block_start, nodes, name, delegate) -> (fun () -> let keep' = get_vtkeep keep in let drop_pt = keep' == VtKeepAxiom in - let block_stop, exn_info, loc = eop, (id, eop), x.loc in + let block_stop, exn_info, loc = eop, (id, eop), x.expr.CAst.loc in log_processing_async id name; VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with @@ -2590,7 +2590,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in - record_pb_time name ?loc:x.loc (wall_clock -. !wall_clock_last_fork); + record_pb_time name ?loc:x.expr.CAst.loc (wall_clock -. !wall_clock_last_fork); let proof = match keep with | VtDrop -> None @@ -2612,7 +2612,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ?proof st x); let wall_clock3 = Unix.gettimeofday () in - Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" + Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); Vernacstate.Proof_global.discard_all () ), true, true @@ -2932,7 +2932,7 @@ let get_allow_nested_proofs = (** [process_transaction] adds a node in the document *) let process_transaction ~doc ?(newtip=Stateid.fresh ()) - ({ verbose; loc; expr } as x) c = + ({ verbose; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in try @@ -3118,11 +3118,11 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let get_ast ~doc id = match VCS.visit id with - | { step = `Cmd { cast = { loc; expr } } } - | { step = `Fork (({ loc; expr }, _, _, _), _) } - | { step = `Sideff ((ReplayCommand {loc; expr}) , _) } - | { step = `Qed ({ qast = { loc; expr } }, _) } -> - Some (Loc.tag ?loc expr) + | { step = `Cmd { cast = { expr } } } + | { step = `Fork (({ expr }, _, _, _), _) } + | { step = `Sideff ((ReplayCommand { expr }) , _) } + | { step = `Qed ({ qast = { expr } }, _) } -> + Some expr | _ -> None let stop_worker n = Slaves.cancel_worker n @@ -3139,8 +3139,8 @@ let parse_sentence ~doc sid ~entry pa = let ind_len_loc_of_id sid = if Stateid.equal sid Stateid.initial then None else match (VCS.visit sid).step with - | `Cmd { ctac = true; cast = { indentation; strlen; loc } } -> - Some (indentation, strlen, loc) + | `Cmd { ctac = true; cast = { indentation; strlen; expr } } -> + Some (indentation, strlen, expr.CAst.loc) | _ -> None (* the indentation logic works like this: if the beginning of the @@ -3167,7 +3167,8 @@ let compute_indentation ?loc sid = Option.cata (fun loc -> eff_indent, len ) (0, 0) loc -let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = +let add ~doc ~ontop ?newtip verb ast = + let loc = ast.CAst.loc in let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then user_err ?loc ~hdr:"Stm.add" @@ -3177,7 +3178,7 @@ let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = let indentation, strlen = compute_indentation ?loc ontop in (* XXX: Classifiy vernac should be moved inside process transaction *) let clas = Vernac_classifier.classify_vernac ast in - let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in + let aast = { verbose = verb; indentation; strlen; expr = ast } in match process_transaction ~doc ?newtip aast clas with | `Ok -> doc, VCS.cur_tip (), `NewTip | `Unfocus qed_id -> doc, qed_id, `Unfocus (VCS.cur_tip ()) @@ -3197,14 +3198,15 @@ let query ~doc ~at ~route s = let rec loop () = match parse_sentence ~doc at ~entry:Pvernac.main_entry s with | None -> () - | Some {CAst.loc; v=ast} -> - let indentation, strlen = compute_indentation ?loc at in - let st = State.get_cached at in - let aast = { - verbose = true; indentation; strlen; - loc; expr = ast } in - ignore(stm_vernac_interp ~route at st aast); - loop () + | Some ast -> + let loc = ast.CAst.loc in + let indentation, strlen = compute_indentation ?loc at in + let st = State.get_cached at in + let aast = { + verbose = true; indentation; strlen; + expr = ast } in + ignore(stm_vernac_interp ~route at st aast); + loop () in loop () ) diff --git a/stm/stm.mli b/stm/stm.mli index 91651e3534..9d2bf56629 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -111,7 +111,7 @@ val parse_sentence : If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> - bool -> Vernacexpr.vernac_control CAst.t -> + bool -> Vernacexpr.vernac_control -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* Returns the proof state before the last tactic that was applied at or before @@ -175,7 +175,7 @@ val get_current_state : doc:doc -> Stateid.t val get_ldir : doc:doc -> Names.DirPath.t (* This returns the node at that position *) -val get_ast : doc:doc -> Stateid.t -> (Vernacexpr.vernac_control Loc.located) option +val get_ast : doc:doc -> Stateid.t -> Vernacexpr.vernac_control option (* Filename *) val set_compilation_hints : string -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 243b5c333d..674b4285d2 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -200,20 +200,20 @@ let classify_vernac e = try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let rec static_control_classifier = function + let rec static_control_classifier v = v |> CAst.with_val (function | VernacExpr (f, e) -> let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in static_classifier ~poly e - | VernacTimeout (_,{v=e}) -> static_control_classifier e - | VernacTime (_,{v=e}) | VernacRedirect (_, {v=e}) -> + | VernacTimeout (_,e) -> static_control_classifier e + | VernacTime (_,e) | VernacRedirect (_, e) -> static_control_classifier e - | VernacFail {v=e} -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ | VtMeta), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtLater - | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater) + | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater)) in static_control_classifier e diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 4129562065..ffdc6580de 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -278,7 +278,7 @@ let extract_default_loc loc doc_id sid : Loc.t option = | None -> try let doc = Stm.get_doc doc_id in - Option.cata fst None Stm.(get_ast ~doc sid) + Option.cata (fun {CAst.loc} -> loc) None Stm.(get_ast ~doc sid) with _ -> loc (** Coqloop Console feedback handler *) @@ -381,22 +381,22 @@ let rec vernac_loop ~state = try let input = top_buffer.tokens in match read_sentence ~state input with - | Some { v = VernacBacktrack(bid,_,_) } -> + | Some (VernacBacktrack(bid,_,_)) -> let bid = Stateid.of_int bid in let doc, res = Stm.edit_at ~doc:state.doc bid in assert (res = `NewTip); let state = { state with doc; sid = bid } in vernac_loop ~state - | Some { v = VernacQuit } -> + | Some VernacQuit -> exit 0 - | Some { v = VernacDrop } -> + | Some VernacDrop -> if Mltop.is_ocaml_top() then (drop_last_doc := Some state; state) else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) - | Some { v = VernacControl c; loc } -> + | Some VernacControl { loc; v=c } -> let nstate = Vernac.process_expr ~state (make ?loc c) in top_goal_print ~doc:state.doc c state.proof nstate.proof; vernac_loop ~state:nstate diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index f2025858d7..0cac024300 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -21,7 +21,7 @@ type vernac_toplevel = | VernacControl of vernac_control module Toplevel_ : sig - val vernac_toplevel : vernac_toplevel CAst.t option Entry.t + val vernac_toplevel : vernac_toplevel option Entry.t end = struct let gec_vernac s = Entry.create ("toplevel:" ^ s) let vernac_toplevel = gec_vernac "vernac_toplevel" @@ -34,14 +34,14 @@ open Toplevel_ GRAMMAR EXTEND Gram GLOBAL: vernac_toplevel; vernac_toplevel: FIRST - [ [ IDENT "Drop"; "." -> { Some (CAst.make VernacDrop) } - | IDENT "Quit"; "." -> { Some (CAst.make VernacQuit) } + [ [ IDENT "Drop"; "." -> { Some VernacDrop } + | IDENT "Quit"; "." -> { Some VernacQuit } | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> - { Some (CAst.make (VernacBacktrack (n,m,p))) } + { Some (VernacBacktrack (n,m,p)) } | cmd = Pvernac.Vernac_.main_entry -> { match cmd with | None -> None - | Some {CAst.loc; v} -> Some (CAst.make ?loc (VernacControl v)) } + | Some v -> Some (VernacControl v) } ] ] ; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 038ff54bf6..4e0ddebca2 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -20,12 +20,12 @@ open Vernacprop Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let checknav_simple {CAst.loc;v=cmd} = +let checknav_simple ({ CAst.loc; _ } as cmd) = if is_navigation_vernac cmd && not (is_reset cmd) then CErrors.user_err ?loc (str "Navigation commands forbidden in files.") -let checknav_deep {CAst.loc;v=ast} = - if is_deep_navigation_vernac ast then +let checknav_deep ({ CAst.loc; _ } as cmd) = + if is_deep_navigation_vernac cmd then CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") (* Echo from a buffer based on position. @@ -163,10 +163,7 @@ let beautify_pass ~doc ~comments ~ids ~filename = set the comments, then we call print. This has to be done for each file. *) Pputils.beautify_comments := comments; - List.iter (fun id -> - Option.iter (fun (loc,ast) -> - pr_new_syntax ?loc ft_beautify (Some ast)) - (Stm.get_ast ~doc id)) ids; + List.iter (fun id -> pr_new_syntax ft_beautify (Stm.get_ast ~doc id)) ids; (* Is this called so comments at EOF are printed? *) pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) ft_beautify None; diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 1269540235..197891707c 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -24,7 +24,7 @@ end expected to handle and print errors in form of exceptions, however care is taken so the state machine is left in a consistent state. *) -val process_expr : state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t +val process_expr : state:State.t -> Vernacexpr.vernac_control -> State.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3f491d1dd4..d97fb523f7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -77,11 +77,11 @@ let parse_compat_version = let open Flags in function GRAMMAR EXTEND Gram GLOBAL: vernac_control gallina_ext noedit_mode subprf; vernac_control: FIRST - [ [ IDENT "Time"; c = located_vernac -> { VernacTime (false,c) } - | IDENT "Redirect"; s = ne_string; c = located_vernac -> { VernacRedirect (s, c) } - | IDENT "Timeout"; n = natural; v = located_vernac -> { VernacTimeout(n,v) } - | IDENT "Fail"; v = located_vernac -> { VernacFail v } - | v = decorated_vernac -> { let (f, v) = v in VernacExpr(f, v) } ] + [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } + | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } + | IDENT "Timeout"; n = natural; v = vernac_control -> { CAst.make ~loc @@ VernacTimeout(n,v) } + | IDENT "Fail"; v = vernac_control -> { CAst.make ~loc @@ VernacFail v } + | v = decorated_vernac -> { let (f, v) = v in CAst.make ~loc @@ VernacExpr(f, v) } ] ] ; decorated_vernac: @@ -147,9 +147,6 @@ GRAMMAR EXTEND Gram ] ] ; - located_vernac: - [ [ v = vernac_control -> { CAst.make ~loc v } ] ] - ; END { diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 4e4d431e89..327efcda2b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1262,15 +1262,15 @@ let pr_vernac_attributes = let rec pr_vernac_control v = let return = tag_vernac v in - match v with + match v.v with | VernacExpr (f, v') -> pr_vernac_attributes f ++ pr_vernac_expr v' ++ sep_end v' - | VernacTime (_,{v}) -> + | VernacTime (_,v) -> return (keyword "Time" ++ spc() ++ pr_vernac_control v) - | VernacRedirect (s, {v}) -> + | VernacRedirect (s, v) -> return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) - | VernacTimeout(n,{v}) -> + | VernacTimeout(n,v) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) - | VernacFail {v} -> + | VernacFail v-> return (keyword "Fail" ++ spc() ++ pr_vernac_control v) let pr_vernac v = diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index d474ef8637..4d9157089c 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,7 +52,7 @@ module Vernac_ = let () = let open Extend in - let act_vernac v loc = Some CAst.(make ~loc v) in + let act_vernac v loc = Some v in let act_eoi _ loc = None in let rule = [ Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 4bf7c9f7bd..41a2e7fd6f 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -26,7 +26,7 @@ module Vernac_ : val rec_definition : (fixpoint_expr * decl_notation list) Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t - val main_entry : vernac_control CAst.t option Entry.t + val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t val hint_info : Hints.hint_info_expr Entry.t end @@ -40,7 +40,7 @@ module Unsafe : sig end (** The main entry: reads an optional vernac command *) -val main_entry : proof_mode option -> vernac_control CAst.t option Entry.t +val main_entry : proof_mode option -> vernac_control option Entry.t (** Grammar entry for tactics: proof mode(s). By default Coq's grammar has an empty entry (non-terminal) for diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 60b0bdc7e7..fffa51f0b4 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -413,7 +413,7 @@ let with_output_to_file fname func input = (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) -let pr_cmd_header {CAst.loc;v=com} = +let pr_cmd_header com = let shorten s = if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s in @@ -423,7 +423,7 @@ let pr_cmd_header {CAst.loc;v=com} = | x -> x ) s in - let (start,stop) = Option.cata Loc.unloc (0,0) loc in + let (start,stop) = Option.cata Loc.unloc (0,0) com.CAst.loc in let safe_pr_vernac x = try Ppvernac.pr_vernac x with e -> str (Printexc.to_string e) in diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index b0e3b3772c..dd6194168a 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -72,4 +72,4 @@ val print_err_exn : exn -> unit redirected to a file [file] *) val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b -val pr_cmd_header : Vernacexpr.vernac_control CAst.t -> Pp.t +val pr_cmd_header : Vernacexpr.vernac_control -> Pp.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3a305c3b61..2e060e97f7 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2599,7 +2599,7 @@ and vernac_load ?proof ~verbosely ~st fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); pstate -and interp_control ?proof ~st = function +and interp_control ?proof ~st v = match v with | { v=VernacExpr (atts, cmd) } -> interp_expr ?proof ~atts ~st cmd | { v=VernacFail v } -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 71cc29b6e1..12451370c8 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -23,7 +23,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - st:Vernacstate.t -> Vernacexpr.vernac_control CAst.t -> Vernacstate.t + st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d0dae1aa53..99b457effe 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -398,11 +398,12 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_control = +type vernac_control_r = | VernacExpr of Attributes.vernac_flags * vernac_expr (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) - | VernacTime of bool * vernac_control CAst.t - | VernacRedirect of string * vernac_control CAst.t - | VernacTimeout of int * vernac_control CAst.t - | VernacFail of vernac_control CAst.t + | VernacTime of bool * vernac_control + | VernacRedirect of string * vernac_control + | VernacTimeout of int * vernac_control + | VernacFail of vernac_control +and vernac_control = vernac_control_r CAst.t diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 704c5b2170..b3490c7dc6 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -13,19 +13,20 @@ open Vernacexpr -let rec under_control = function +let rec under_control v = v |> CAst.with_val (function | VernacExpr (_, c) -> c - | VernacRedirect (_,{CAst.v=c}) - | VernacTime (_,{CAst.v=c}) - | VernacFail {CAst.v=c} - | VernacTimeout (_,{CAst.v=c}) -> under_control c + | VernacRedirect (_,c) + | VernacTime (_,c) + | VernacFail c + | VernacTimeout (_,c) -> under_control c + ) -let rec has_Fail = function +let rec has_Fail v = v |> CAst.with_val (function | VernacExpr _ -> false - | VernacRedirect (_,{CAst.v=c}) - | VernacTime (_,{CAst.v=c}) - | VernacTimeout (_,{CAst.v=c}) -> has_Fail c - | VernacFail _ -> true + | VernacRedirect (_,c) + | VernacTime (_,c) + | VernacTimeout (_,c) -> has_Fail c + | VernacFail _ -> true) (* Navigation commands are allowed in a coqtop session but not in a .v file *) let is_navigation_vernac_expr = function @@ -38,17 +39,17 @@ let is_navigation_vernac_expr = function let is_navigation_vernac c = is_navigation_vernac_expr (under_control c) -let rec is_deep_navigation_vernac = function - | VernacTime (_,{CAst.v=c}) -> is_deep_navigation_vernac c - | VernacRedirect (_, {CAst.v=c}) - | VernacTimeout (_,{CAst.v=c}) | VernacFail {CAst.v=c} -> is_navigation_vernac c - | VernacExpr _ -> false +let rec is_deep_navigation_vernac v = v |> CAst.with_val (function + | VernacTime (_,c) -> is_deep_navigation_vernac c + | VernacRedirect (_, c) + | VernacTimeout (_, c) | VernacFail c -> is_navigation_vernac c + | VernacExpr _ -> false) (* NB: Reset is now allowed again as asked by A. Chlipala *) -let is_reset = function +let is_reset = CAst.with_val (function | VernacExpr ( _, VernacResetInitial) | VernacExpr (_, VernacResetName _) -> true - | _ -> false + | _ -> false) let is_debug cmd = match under_control cmd with | VernacSetOption (_, ["Ltac";"Debug"], _) -> true -- cgit v1.2.3 From 53438d636ddd4f05249ef13e89306759bfe3499f Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Sun, 28 Apr 2019 15:21:00 +0200 Subject: [test-suite] Remove a test with a Timeout that fails frequently on CI. --- test-suite/success/ROmega3.v | 35 ----------------------------------- 1 file changed, 35 deletions(-) delete mode 100644 test-suite/success/ROmega3.v diff --git a/test-suite/success/ROmega3.v b/test-suite/success/ROmega3.v deleted file mode 100644 index ef9cb17b4b..0000000000 --- a/test-suite/success/ROmega3.v +++ /dev/null @@ -1,35 +0,0 @@ - -Require Import ZArith Lia. -Local Open Scope Z_scope. - -(** Benchmark provided by Chantal Keller, that romega used to - solve far too slowly (compared to omega or lia). *) - -(* In Coq 8.9 (end of 2018), the `romega` tactics are deprecated. - The tests in this file remain but now call the `lia` tactic. *) - - -Parameter v4 : Z. -Parameter v3 : Z. -Parameter o4 : Z. -Parameter s5 : Z. -Parameter v2 : Z. -Parameter o5 : Z. -Parameter s6 : Z. -Parameter v1 : Z. -Parameter o6 : Z. -Parameter s7 : Z. -Parameter v0 : Z. -Parameter o7 : Z. - -Lemma lemma_5833 : - ~ 16 * v4 + (8 * v3 + (-8192 * o4 + (-4096 * s5 + (4 * v2 + - (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + - (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 8192 -\/ - 16 * v4 + (8 * v3 + (-8192 * o4 + (-4096 * s5 + (4 * v2 + - (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + - (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 1024. -Proof. -Timeout 1 lia. (* should take a few milliseconds, not seconds *) -Timeout 1 Qed. (* ditto *) -- cgit v1.2.3 From 6ef5a36a69e9116344af7fae4434a487be9c3b0e Mon Sep 17 00:00:00 2001 From: Jim Fehrle Date: Tue, 23 Apr 2019 17:23:58 -0700 Subject: Update behavior of -emacs to support showing diffs in ProofGeneral (master branch) Adds XML-like tags in output to mark diffs --- toplevel/coqargs.ml | 4 ++-- toplevel/coqargs.mli | 2 +- toplevel/coqtop.ml | 12 ++++++++---- vernac/topfmt.ml | 16 ++++++++++++++-- vernac/topfmt.mli | 1 + 5 files changed, 26 insertions(+), 9 deletions(-) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 319f5c8ad6..9a18baa0bc 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -34,7 +34,7 @@ let set_type_in_type () = (******************************************************************************) -type color = [`ON | `AUTO | `OFF] +type color = [`ON | `AUTO | `EMACS | `OFF] type native_compiler = NativeOff | NativeOn of { ondemand : bool } @@ -171,7 +171,7 @@ let add_load_vernacular opts verb s = (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; - { opts with color = `OFF; print_emacs = true } + { opts with color = `EMACS; print_emacs = true } let set_color opts = function | "yes" | "on" -> { opts with color = `ON } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 9bcfdca332..d7f9819bee 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type color = [`ON | `AUTO | `OFF] +type color = [`ON | `AUTO | `EMACS | `OFF] val default_toplevel : Names.DirPath.t diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8fae561be8..c4d7333dfa 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -113,6 +113,7 @@ let fatal_error_exn exn = let init_color opts = let has_color = match opts.color with | `OFF -> false + | `EMACS -> false | `ON -> true | `AUTO -> Terminal.has_style Unix.stdout && @@ -133,10 +134,13 @@ let init_color opts = Topfmt.default_styles (); false (* textual markers, no color *) end in - if not term_color then - Proof_diffs.write_color_enabled term_color; - if Proof_diffs.show_diffs () && not term_color then - (prerr_endline "Error: -diffs requires enabling -color"; exit 1); + if opts.color = `EMACS then + Topfmt.set_emacs_print_strings () + else if not term_color then begin + Proof_diffs.write_color_enabled term_color; + if Proof_diffs.show_diffs () then + (prerr_endline "Error: -diffs requires enabling -color"; exit 1) + end; Topfmt.init_terminal_output ~color:term_color let print_style_tags opts = diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 60b0bdc7e7..7bc3264968 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -196,6 +196,18 @@ let init_tag_map styles = let default_styles () = init_tag_map (default_tag_map ()) +let set_emacs_print_strings () = + let open Terminal in + let diff = "diff." in + List.iter (fun b -> + let (name, attrs) = b in + if diff = (String.sub name 0 (String.length diff)) then + tag_map := CString.Map.add name + { attrs with prefix = Some (Printf.sprintf "<%s>" name); + suffix = Some (Printf.sprintf "" name) } + !tag_map) + (CString.Map.bindings !tag_map) + let parse_color_config str = let styles = Terminal.parse str in init_tag_map styles @@ -264,13 +276,13 @@ let make_printing_functions () = let (tpfx, ttag) = split_tag tag in if tpfx <> end_pfx then let style = get_style ttag in - match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () in + match style.Terminal.prefix with Some s -> Format.pp_print_as ft 0 s | None -> () in let print_suffix ft tag = let (tpfx, ttag) = split_tag tag in if tpfx <> start_pfx then let style = get_style ttag in - match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () in + match style.Terminal.suffix with Some s -> Format.pp_print_as ft 0 s | None -> () in print_prefix, print_suffix diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index b0e3b3772c..a1e289cd5a 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -46,6 +46,7 @@ val emacs_logger : ?pre_hdr:Pp.t -> Feedback.level -> Pp.t -> unit val default_styles : unit -> unit val parse_color_config : string -> unit val dump_tags : unit -> (string * Terminal.style) list +val set_emacs_print_strings : unit -> unit (** Initialization of interpretation of tags *) val init_terminal_output : color:bool -> unit -- cgit v1.2.3 From af3673b08204cb4d3d6994aa3a5bd6363bfd7459 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Thu, 17 Jan 2019 11:44:38 +0000 Subject: Fix #9344, #9348: incorrect unsafe to_constr in vnorm --- pretyping/vnorm.ml | 2 +- test-suite/bugs/closed/bug_9344.v | 1 + test-suite/bugs/closed/bug_9348.v | 3 +++ 3 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/bug_9344.v create mode 100644 test-suite/bugs/closed/bug_9348.v diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 62e9e477f7..1fe6545ce4 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -202,7 +202,7 @@ and nf_univ_args ~nb_univs mk env sigma stk = and nf_evar env sigma evk stk = let evi = try Evd.find sigma evk with Not_found -> assert false in let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in - let concl = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in + let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then nf_stk env sigma (mkEvar (evk, [||])) concl stk else match stk with diff --git a/test-suite/bugs/closed/bug_9344.v b/test-suite/bugs/closed/bug_9344.v new file mode 100644 index 0000000000..fbf86b2dad --- /dev/null +++ b/test-suite/bugs/closed/bug_9344.v @@ -0,0 +1 @@ +Compute _ I. diff --git a/test-suite/bugs/closed/bug_9348.v b/test-suite/bugs/closed/bug_9348.v new file mode 100644 index 0000000000..a4673b5ffc --- /dev/null +++ b/test-suite/bugs/closed/bug_9348.v @@ -0,0 +1,3 @@ +Set Primitive Projections. +Record r {A} := R {f : A -> A}. +Compute f _ I. -- cgit v1.2.3 From cb02d26b3cb5fba749a80b13e822d9a95ec0b5e8 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Mon, 29 Apr 2019 17:36:36 +0200 Subject: [toplevel] Only print welcome header in standard coqtop. Closes #8410 (adapted from fix by @silene in the 8.9 branch) --- toplevel/coqtop.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8fae561be8..15172b30f8 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -220,7 +220,6 @@ let init_toplevel ~help ~init custom_init arglist = let top_lp = Coqinit.toplevel_init_load_path () in List.iter Mltop.add_coq_path top_lp; let opts, extras = custom_init ~opts extras in - Flags.if_verbose print_header (); Mltop.init_known_plugins (); Global.set_engagement opts.impredicative_set; @@ -296,6 +295,7 @@ let rec coqc_deprecated_check args acc extras = let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); + Flags.if_verbose print_header (); opts, extra let coqtop_toplevel = -- cgit v1.2.3 From ace68d056551a4a2834d1d4908375dba7a1fbc44 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 29 Apr 2019 17:35:06 +0200 Subject: Fix variant of #9344 for native_compute --- pretyping/nativenorm.ml | 2 +- test-suite/bugs/closed/bug_9344.v | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index e694502231..0fcd6a9e9d 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -415,7 +415,7 @@ and nf_predicate env sigma ind mip params v pT = and nf_evar env sigma evk args = let evi = try Evd.find sigma evk with Not_found -> assert false in let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in - let ty = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in + let ty = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then begin assert (Int.equal (Array.length args) 0); mkEvar (evk, [||]), ty diff --git a/test-suite/bugs/closed/bug_9344.v b/test-suite/bugs/closed/bug_9344.v index fbf86b2dad..0d44c9721a 100644 --- a/test-suite/bugs/closed/bug_9344.v +++ b/test-suite/bugs/closed/bug_9344.v @@ -1 +1,2 @@ Compute _ I. +Eval native_compute in _ I. -- cgit v1.2.3 From b913a79738fee897bc298e0804617da8abcb4cf5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 28 Apr 2019 16:29:16 +0200 Subject: Exposing a change_no_check tactic. --- plugins/ltac/g_tactic.mlg | 6 +++++- plugins/ltac/pptactic.ml | 5 +++-- plugins/ltac/tacexpr.ml | 3 ++- plugins/ltac/tacexpr.mli | 3 ++- plugins/ltac/tacintern.ml | 8 ++++---- plugins/ltac/tacinterp.ml | 8 ++++---- plugins/ltac/tacsubst.ml | 4 ++-- tactics/tactics.ml | 33 ++++++++++++++++++++------------- tactics/tactics.mli | 8 ++++---- 9 files changed, 46 insertions(+), 32 deletions(-) diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index a2dd51643b..c23240b782 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -703,7 +703,11 @@ GRAMMAR EXTEND Gram | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (true,p,c,cl)) } + | IDENT "change_no_check"; c = conversion; cl = clause_dft_concl -> + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in + TacAtom (CAst.make ~loc @@ TacChange (false,p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 80070a7493..79f0f521cc 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -833,9 +833,10 @@ let pr_goal_selector ~toplevel s = pr_red_expr r ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) - | TacChange (op,c,h) -> + | TacChange (check,op,c,h) -> + let name = if check then "change_no_check" else "change" in hov 1 ( - primitive "change" ++ brk (1,1) + primitive name ++ brk (1,1) ++ ( match op with None -> diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 30e316b36d..0eb7726a18 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -125,7 +126,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8b6b14322b..fd303f5d94 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -124,7 +125,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 543d4de0fe..c1f7fab123 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -551,7 +551,7 @@ let rec intern_atomic lf ist x = | TacReduce (r,cl) -> dump_glob_red_expr r; TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -560,17 +560,17 @@ let rec intern_atomic lf ist x = | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in - TacChange (None, + TacChange (check,None, (if is_onhyps && is_onconcl then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) - | TacChange (Some p,c,cl) -> + | TacChange (check,Some p,c,cl) -> let { ltacvars } = ist in let metas,pat = intern_typed_pattern ist ~as_type:false ~ltacvars p in let fold accu x = Id.Set.add x accu in let ltacvars = List.fold_left fold ltacvars metas in let ist' = { ist with ltacvars } in - TacChange (Some pat,intern_constr ist' c, + TacChange (check,Some pat,intern_constr ist' c, clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 4398fb14ab..800be2565d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1770,7 +1770,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) end - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"") begin Proofview.Goal.enter begin fun gl -> @@ -1792,10 +1792,10 @@ and interp_atomic ist tac : unit Proofview.tactic = then interp_type ist env sigma c else interp_constr ist env sigma c in - Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) + Tactics.change ~check None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end end - | TacChange (Some op,c,cl) -> + | TacChange (check,Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"") begin Proofview.Goal.enter begin fun gl -> @@ -1815,7 +1815,7 @@ and interp_atomic ist tac : unit Proofview.tactic = with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in - Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) + Tactics.change ~check (Some op) c_interp (interp_clause ist env sigma cl) end end diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index e617f3d45e..a3eeca2267 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -158,8 +158,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (op,c,cl) -> - TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + | TacChange (check,op,c,cl) -> + TacChange (check,Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) (* Equality and inversion *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b70dd63211..16bede0d1b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -802,15 +802,21 @@ let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = | Some sigma -> (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where env sigma c = +let change_on_subterm check cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in let (sigma, c) = match where with - | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + | None -> + if check then + change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + else + t Id.Map.empty env sigma | Some occl -> e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) - env sigma c in + if check then + change_and_check Reduction.CONV mayneedglobalcheck true (t subst) + else + fun env sigma _c -> t subst env sigma) env sigma c in if !mayneedglobalcheck then begin try ignore (Typing.unsafe_type_of env sigma c) @@ -819,14 +825,15 @@ let change_on_subterm cv_pb deep t where env sigma c = end; (sigma, c) -let change_in_concl occl t = - e_change_in_concl ~check:false ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) +let change_in_concl ?(check=true) occl t = + (* No need to check in e_change_in_concl, the check is done in change_on_subterm *) + e_change_in_concl ~check:false ((change_on_subterm check Reduction.CUMUL false t occl),DEFAULTcast) -let change_in_hyp occl t id = +let change_in_hyp ?(check=true) occl t id = (* FIXME: we set the [check] flag only to reorder hypotheses in case of introduction of dependencies in new variables. We should separate this check from the conversion function. *) - e_change_in_hyp ~check:true (fun x -> change_on_subterm Reduction.CONV x t occl) id + e_change_in_hyp ~check:true (fun x -> change_on_subterm check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -835,24 +842,24 @@ let concrete_clause_of enum_hyps cl = match cl.onhyps with | Some l -> List.map (fun ((occs, id), w) -> (id, occs, w)) l -let change chg c cls = +let change ?(check=true) chg c cls = Proofview.Goal.enter begin fun gl -> let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in begin match cls.concl_occs with | NoOccurrences -> Proofview.tclUNIT () - | occs -> change_in_concl (bind_change_occurrences occs chg) c + | occs -> change_in_concl ~check (bind_change_occurrences occs chg) c end <*> let f (id, occs, where) = let occl = bind_change_occurrences occs chg in - let redfun deep env sigma t = change_on_subterm Reduction.CONV deep c occl env sigma t in + let redfun deep env sigma t = change_on_subterm check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in e_change_in_hyps ~check:true f hyps end let change_concl t = - change_in_concl None (make_change_arg t) + change_in_concl ~check:true None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) let red_in_concl = reduct_in_concl (red_product,REVERTcast) @@ -3280,7 +3287,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN - (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) + (change_in_hyp ~check:false None (make_change_arg t) (hyp0,InHypTypeOnly)) (tac avoid) else let c = List.nth argl (i-1) in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index e7b95a820e..b3914816ac 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -155,10 +155,10 @@ val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic val reduct_in_concl : ?check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic -val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic -val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic +val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val change_in_concl : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic -val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> +val change_in_hyp : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic val red_in_concl : unit Proofview.tactic val red_in_hyp : hyp_location -> unit Proofview.tactic @@ -180,7 +180,7 @@ val unfold_in_hyp : val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : - constr_pattern option -> change_arg -> clause -> unit Proofview.tactic + ?check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic -- cgit v1.2.3 From 7875955f513f55c1fcef90becdaaa572baa3e5ae Mon Sep 17 00:00:00 2001 From: Georges Gonthier Date: Wed, 24 Apr 2019 23:02:08 +0200 Subject: fix `simpl_rel` and notations, `{pred T}` alias, `nonPropType` interface ** Changed definition of `simpl_rel` to `T -> `simpl_pred T`, so that `inE` will now expand `a \in r b`, when `r := [rel x y | R]` to `R{b/x, a/y}`, as the expanding coercion is now only inserted in the _last_ application. The old definition made it possible to have a `simpl_rel >-> rel` coercion that does not block expansion, but this can now be achieved more economically with the `Arguments … /.` annotation. ** Deleted the `[rel of P]` notation which is no longer needed with the new `simpl_rel` definition, and was broken anyway. ** Added `relpre f R` definition of functional preimage of a notation. ** `comp` and `idfun` are now proper definitions, using the `Arguments … /.` annotation to specify simplification on application. ** Added `{pred T}` syntax for the alias of `pred T` in the `pred_sort` coercion class; deleted the `pred_class` alias: one should either use `pred_sort` in `Coercion` declarations, or `{pred T}` in type casts. Used `{pred T}` as appropriate in localised predicate (`{in …, …}`) theory. Extended and corrected `pred` coercion internal documentation. ** Simplified the `predType` structure by removing the redundant explicit `mem_pred` subfield, and replacing it with an interlocked projection; deleted `mkPredType`, now replaced by `PredType`. ** Added (and extensively documented) a `nonPropType` interface matching types that do _not_ have sort `Prop`, and used it to remove the non-standard maximal implicits annotation on `Some_inj` introduced in #6911 by @anton-trumov; included `test-suite` entry for `nonPropType`. ** Documented the design of the four structures used to control the matching of `inE` and related predicate rewriting lemmas; added `test-suite` entry covering the `pred` rewriting control idioms. ** Used `only printing` annotations to get rid of token concatenation hacks. ** Fixed boolean and general `if b return t then …` notation so that `b` is bound in `t`. This is a minor source of incompatibility for misuses of this syntax when `b` is _not_ bound in `t`, and `(if b then …) : t` should have been used instead. ** Reserved all `ssreflect`, `ssrfun` and `ssrbool` notation at the top of the file, adding some printing boxes, and removing some spurious `[pred .. => ..]` reserved notation. ** Fixed parsing precedence and format of `` notation, and declared and put it in an explicit `ssr_scope`. ** Used module-and-functor idiom to ensure that the `simpl_pred T >- pred T` _and_ `simpl_pred T >-> {pred T}` coercions are realised by the _same_ Gallina constant. ** Updated `CREDITS`. The policy implied by this PR: that `{pred T}` should systematically be used as the generic collective predicate type, was implemented in MathComp math-comp/math-comp#237. As a result `simpl_pred >-> pred_sort` coercions became more frequent, as it turned out they were not, as incorrectly stated in `ssrbool` internal comments, impossible: while the `simplPredType` canonical instance does solve all `simpl_pred T =~= pred_sort ?pT` instances, it does _not_ solve `simpl_pred T =~= {pred T}`, and so the coercion will be used in that case. However it appeared that having two different coercion constants confused the SSReflect keyed matching heuristic, hence the fix introduced here. This has entailed some rearrangement of `ssrbool`: the large `Predicates` section had to be broken up as the module-functor idiom for aliasing coercions cannot be used inside a section. --- CHANGES.md | 12 + CREDITS | 4 +- plugins/ssr/ssrbool.v | 916 ++++++++++++++++------------ plugins/ssr/ssreflect.v | 222 +++++-- plugins/ssr/ssrfun.v | 307 +++++----- test-suite/prerequisite/ssr_mini_mathcomp.v | 4 +- test-suite/ssr/nonPropType.v | 23 + test-suite/ssr/predRewrite.v | 28 + 8 files changed, 917 insertions(+), 599 deletions(-) create mode 100644 test-suite/ssr/nonPropType.v create mode 100644 test-suite/ssr/predRewrite.v diff --git a/CHANGES.md b/CHANGES.md index 2f58bfb825..51583639ca 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -322,6 +322,18 @@ SSReflect - `=> {x..} /H` -> `=> /v {x..H}` - `rewrite {x..} H` -> `rewrite E {x..H}` +- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + +- New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + +- `if c return t then ...` now expects `c` to be a variable bound in `t`. + +- New `nonPropType` interface matching types that do _not_ have sort `Prop`. + +- New `relpre R f` definition for the preimage of a relation R under f. + Diffs - Some error messages that show problems with a pair of non-matching values will now diff --git a/CREDITS b/CREDITS index 37eb4e4455..f871dba8b3 100644 --- a/CREDITS +++ b/CREDITS @@ -59,10 +59,10 @@ plugins/setoid_ring Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) and Bruno Barras (INRIA LogiCal, 2005-2006), plugins/ssreflect - developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011), + developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2013, Inria, 2013-now), Assia Mahboubi and Enrico Tassi (Inria, 2011-now). plugins/ssrmatching - developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011), + developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011, Inria, 2013-now), and Enrico Tassi (Inria-Marelle, 2011-now) plugins/subtac developed by Matthieu Sozeau (LRI, 2005-2008) diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index d6b7371647..49d729bd6c 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -94,20 +94,31 @@ Require Import ssreflect ssrfun. like terms from boolean equalities (can fail). This file provides a theory of boolean predicates and relations: pred T == the type of bool predicates (:= T -> bool). - simpl_pred T == the type of simplifying bool predicates, using - the simpl_fun from ssrfun.v. + simpl_pred T == the type of simplifying bool predicates, based on + the simpl_fun type from ssrfun.v. + mem_pred T == a specialized form of simpl_pred for "collective" + predicates (see below). rel T == the type of bool relations. := T -> pred T or T -> T -> bool. simpl_rel T == type of simplifying relations. + := T -> simpl_pred T predType == the generic predicate interface, supported for for lists and sets. - pred_class == a coercion class for the predType projection to - pred; declaring a coercion to pred_class is an - alternative way of equipping a type with a - predType structure, which interoperates better - with coercion subtyping. This is used, e.g., - for finite sets, so that finite groups inherit - the membership operation by coercing to sets. + pred_sort == the predType >-> Type projection; pred_sort is + itself a Coercion target class. Declaring a + coercion to pred_sort is an alternative way of + equiping a type with a predType structure, which + interoperates better with coercion subtyping. + This is used, e.g., for finite sets, so that finite + groups inherit the membership operation by + coercing to sets. + {pred T} == a type convertible to pred T, but whose head + constant is pred_sort. This type should be used + for parameters that can be used as collective + predicates (see below), as this will allow passing + in directly collections that implement predType + by coercion as described above, e.g., finite sets. + := pred_sort (predPredType T) If P is a predicate the proposition "x satisfies P" can be written applicatively as (P x), or using an explicit connective as (x \in P); in the latter case we say that P is a "collective" predicate. We use A, B @@ -119,8 +130,14 @@ Require Import ssreflect ssrfun. pred T value of one type needs to be passed as the other the following conversions should be used explicitly: SimplPred P == a (simplifying) applicative equivalent of P. - mem A == an applicative equivalent of A: - mem A x simplifies to x \in A. + mem A == an applicative equivalent of collective predicate A: + mem A x simplifies to x \in A, as mem A has in + fact type mem_pred T. + --> In user notation collective predicates _only_ occur as arguments to mem: + A only appears as (mem A). This is hidden by notation, e.g., + x \in A := in_mem x (mem A) here, enum A := enum_mem (mem A) in fintype. + This makes it possible to unify the various ways in which A can be + interpreted as a predicate, for both pattern matching and display. Alternatively one can use the syntax for explicit simplifying predicates and relations (in the following x is bound in E): #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. @@ -135,11 +152,11 @@ Require Import ssreflect ssrfun. #[#predD A & B#]# == difference of collective predicates A and B. #[#predC A#]# == complement of the collective predicate A. #[#preim f of A#]# == preimage under f of the collective predicate A. - predU P Q, ... == union, etc of applicative predicates. - pred0 == the empty predicate. - predT == the total (always true) predicate. - if T : predArgType, then T coerces to predT. - {: T} == T cast to predArgType (e.g., {: bool * nat}) + predU P Q, ..., preim f P == union, etc of applicative predicates. + pred0 == the empty predicate. + predT == the total (always true) predicate. + if T : predArgType, then T coerces to predT. + {: T} == T cast to predArgType (e.g., {: bool * nat}). In the following, x and y are bound in E: #[#rel x y | E#]# == simplifying relation x, y => E. #[#rel x y : T | E#]# == simplifying relation with arguments cast. @@ -147,7 +164,9 @@ Require Import ssreflect ssrfun. #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. #[#rel x y in A#]# == #[#rel x y in A & A#]#. - relU R S == union of relations R and S. + relU R S == union of relations R and S. + relpre f R == preimage of relation R under f. + xpredU, ..., xrelpre == lambda terms implementing predU, ..., etc. Explicit values of type pred T (i.e., lamdba terms) should always be used applicatively, while values of collection types implementing the predType interface, such as sequences or sets should always be used as collective @@ -177,7 +196,7 @@ Require Import ssreflect ssrfun. applicative and collective styles. Purely for aesthetics, we provide a subtype of collective predicates: qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T - coerces to pred_class and thus behaves as a collective + coerces to pred_sort and thus behaves as a collective predicate, but x \in A and x \notin A are displayed as: x \is A and x \isn't A when q = 0, x \is a A and x \isn't a A when q = 1, @@ -189,11 +208,11 @@ Require Import ssreflect ssrfun. We provide an internal interface to support attaching properties (such as being multiplicative) to predicates: pred_key p == phantom type that will serve as a support for properties - to be attached to p : pred_class; instances should be + to be attached to p : {pred _}; instances should be created with Fact/Qed so as to be opaque. KeyedPred k_p == an instance of the interface structure that attaches (k_p : pred_key P) to P; the structure projection is a - coercion to pred_class. + coercion to pred_sort. KeyedQualifier k_q == an instance of the interface structure that attaches (k_q : pred_key q) to (q : qualifier n T). DefaultPredKey p == a default value for pred_key p; the vernacular command @@ -235,17 +254,20 @@ Require Import ssreflect ssrfun. {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. {in A1 & A2 & A3, Q3} <-> forall x y z, x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. - {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. - {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. - {in A &&, Q3} == {in A & A & A, Q3}. - {in A, bijective f} == f has a right inverse in A. - {on C, P1} == forall x, (f x) \in C -> Qx - when P1 is also convertible to Pf f. + {in A1 & A2 &, Q3} := {in A1 & A2 & A2, Q3}. + {in A1 && A3, Q3} := {in A1 & A1 & A3, Q3}. + {in A &&, Q3} := {in A & A & A, Q3}. + {in A, bijective f} <-> f has a right inverse in A. + {on C, P1} <-> forall x, (f x) \in C -> Qx + when P1 is also convertible to Pf f, e.g., + {on C, involutive f}. {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy - when P2 is also convertible to Pf f. + when P2 is also convertible to Pf f, e.g., + {on C &, injective f}. {on C, P1' & g} == forall x, (f x) \in cd -> Qx when P1' is convertible to Pf f - and P1' g is convertible to forall x, Qx. + and P1' g is convertible to forall x, Qx, e.g., + {on C, cancel f & g}. {on C, bijective f} == f has a right inverse on C. This file extends the lemma name suffix conventions of ssrfun as follows: A -- associativity, as in andbA : associative andb. @@ -282,13 +304,119 @@ Notation ReflectF := Bool.ReflectF. Reserved Notation "~~ b" (at level 35, right associativity). Reserved Notation "b ==> c" (at level 55, right associativity). -Reserved Notation "b1 (+) b2" (at level 50, left associativity). -Reserved Notation "x \in A" - (at level 70, format "'[hv' x '/ ' \in A ']'", no associativity). -Reserved Notation "x \notin A" - (at level 70, format "'[hv' x '/ ' \notin A ']'", no associativity). -Reserved Notation "p1 =i p2" - (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). + +Reserved Notation "x \in A" (at level 70, no associativity, + format "'[hv' x '/ ' \in A ']'"). +Reserved Notation "x \notin A" (at level 70, no associativity, + format "'[hv' x '/ ' \notin A ']'"). +Reserved Notation "x \is A" (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'"). +Reserved Notation "x \isn't A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'"). +Reserved Notation "x \is 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'"). +Reserved Notation "x \isn't 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'"). +Reserved Notation "x \is 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'"). +Reserved Notation "x \isn't 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'"). +Reserved Notation "p1 =i p2" (at level 70, no associativity, + format "'[hv' p1 '/ ' =i p2 ']'"). +Reserved Notation "{ 'subset' A <= B }" (at level 0, A, B at level 69, + format "'[hv' { 'subset' A '/ ' <= B } ']'"). + +Reserved Notation "{ : T }" (at level 0, format "{ : T }"). +Reserved Notation "{ 'pred' T }" (at level 0, format "{ 'pred' T }"). +Reserved Notation "[ 'predType' 'of' T ]" (at level 0, + format "[ 'predType' 'of' T ]"). + +Reserved Notation "[ 'pred' : T | E ]" (at level 0, + format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). +Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). +Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). + +Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). + +Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A ] ']'"). + +Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). +Reserved Notation "[ 'predI' A & B ]" (at level 0, + format "[ 'predI' A & B ]"). +Reserved Notation "[ 'predU' A & B ]" (at level 0, + format "[ 'predU' A & B ]"). +Reserved Notation "[ 'predD' A & B ]" (at level 0, + format "[ 'predD' A & B ]"). +Reserved Notation "[ 'predC' A ]" (at level 0, + format "[ 'predC' A ]"). +Reserved Notation "[ 'preim' f 'of' A ]" (at level 0, + format "[ 'preim' f 'of' A ]"). + +Reserved Notation "\unless C , P" (at level 200, C at level 100, + format "'[hv' \unless C , '/ ' P ']'"). + +Reserved Notation "{ 'for' x , P }" (at level 0, + format "'[hv' { 'for' x , '/ ' P } ']'"). +Reserved Notation "{ 'in' d , P }" (at level 0, + format "'[hv' { 'in' d , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & , P }" (at level 0, + format "'[hv' { 'in' d & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & & , P }" (at level 0, + format "'[hv' { 'in' d & & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P }" (at level 0, + format "'[hv' { 'on' cd , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd & , P }" (at level 0, + format "'[hv' { 'on' cd & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P & g }" (at level 0, g at level 8, + format "'[hv' { 'on' cd , '/ ' P & g } ']'"). +Reserved Notation "{ 'in' d , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'in' d , '/ ' 'bijective' f } ']'"). +Reserved Notation "{ 'on' cd , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'on' cd , '/ ' 'bijective' f } ']'"). + (** We introduce a number of n-ary "list-style" notations that share a common @@ -335,18 +463,6 @@ Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). -Reserved Notation "[ 'pred' : T => E ]" (at level 0, format - "'[hv' [ 'pred' : T => '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x => E ]" (at level 0, x at level 8, format - "'[hv' [ 'pred' x => '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x : T => E ]" (at level 0, x at level 8, format - "'[hv' [ 'pred' x : T => '/ ' E ] ']'"). - -Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format - "'[hv' [ 'rel' x y => '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format - "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). - (** Shorter delimiter **) Delimit Scope bool_scope with B. Open Scope bool_scope. @@ -622,9 +738,7 @@ Hint View for apply/ impliesPn|2 impliesP|2. Definition unless condition property : Prop := forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. -Notation "\unless C , P" := (unless C P) - (at level 200, C at level 100, - format "'[' \unless C , '/ ' P ']'") : type_scope. +Notation "\unless C , P" := (unless C P) : type_scope. Lemma unlessL C P : implies C (\unless C, P). Proof. by split=> hC G /(_ hC). Qed. @@ -1002,8 +1116,7 @@ Ltac bool_congr := Moreover these infix forms are convertible to their prefix counterpart (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse is not true, however; collective predicate types cannot, in general, be - general, be used applicatively, because of the "uniform inheritance" - restriction on implicit coercions. + used applicatively, because of restrictions on implicit coercions. However, we do define an explicit generic coercion - mem : forall (pT : predType), pT -> mem_pred T where mem_pred T is a variant of simpl_pred T that preserves the infix @@ -1019,319 +1132,391 @@ Ltac bool_congr := not to use it applicatively; this avoids the burden of having to declare a different predicate type for each predicate parameter of each section or lemma. - This trick is made possible by the fact that the constructor of the - mem_pred T type aligns the unification process, forcing a generic - "collective" predicate A : pred T to unify with the actual collective B, - which mem has coerced to pred T via an internal, hidden implicit coercion, - supplied by the predType structure for B. Users should take care not to - inadvertently "strip" (mem B) down to the coerced B, since this will - expose the internal coercion: Coq will display a term B x that cannot be - typed as such. The topredE lemma can be used to restore the x \in B - syntax in this case. While -topredE can conversely be used to change - x \in P into P x, it is safer to use the inE and memE lemmas instead, as - they do not run the risk of exposing internal coercions. As a consequence - it is better to explicitly cast a generic applicative pred T to simpl_pred - using the SimplPred constructor, when it is used as a collective predicate - (see, e.g., Lemma eq_big in bigop). + In detail, we ensure that the head normal form of mem A is always of the + eta-long MemPred (fun x => pA x) form, where pA is the pred interpretation of + A following its predType pT, i.e., the _expansion_ of topred A. For a pred T + evar ?P, (mem ?P) converts MemPred (fun x => ?P x), whose argument is a Miller + pattern and therefore always unify: unifying (mem A) with (mem ?P) always + yields ?P = pA, because the rigid constant MemPred aligns the unification. + Furthermore, we ensure pA is always either A or toP .... A where toP ... is + the expansion of @topred T pT, and toP is declared as a Coercion, so pA will + _display_ as A in either case, and the instances of @mem T (predPredType T) pA + appearing in the premises or right-hand side of a generic lemma parametrized + by ?P will be indistinguishable from @mem T pT A. + Users should take care not to inadvertently "strip" (mem A) down to the + coerced A, since this will expose the internal toP coercion: Coq could then + display terms A x that cannot be typed as such. The topredE lemma can be used + to restore the x \in A syntax in this case. While -topredE can conversely be + used to change x \in P into P x for an applicative P, it is safer to use the + inE, unfold_in or and memE lemmas instead, as they do not run the risk of + exposing internal coercions. As a consequence it is better to explicitly + cast a generic applicative predicate to simpl_pred using the SimplPred + constructor when it is used as a collective predicate (see, e.g., + Lemma eq_big in bigop). We also sometimes "instantiate" the predType structure by defining a - coercion to the sort of the predPredType structure. This works better for - types such as {set T} that have subtypes that coerce to them, since the - same coercion will be inserted by the application of mem. It also lets us - turn any Type aT : predArgType into the total predicate over that type, - i.e., fun _: aT => true. This allows us to write, e.g., ##|'I_n| for the - cardinal of the (finite) type of integers less than n. - Collective predicates have a specific extensional equality, - - A =i B, - while applicative predicates use the extensional equality of functions, - - P =1 Q - The two forms are convertible, however. - We lift boolean operations to predicates, defining: - - predU (union), predI (intersection), predC (complement), - predD (difference), and preim (preimage, i.e., composition) - For each operation we define three forms, typically: - - predU : pred T -> pred T -> simpl_pred T - - #[#predU A & B#]#, a Notation for predU (mem A) (mem B) - - xpredU, a Notation for the lambda-expression inside predU, - which is mostly useful as an argument of =1, since it exposes the head - head constant of the expression to the ssreflect matching algorithm. - The syntax for the preimage of a collective predicate A is - - #[#preim f of A#]# - Finally, the generic syntax for defining a simpl_pred T is - - #[#pred x : T | P(x) #]#, #[#pred x | P(x) #]#, #[#pred x in A | P(x) #]#, etc. - We also support boolean relations, but only the applicative form, with - types - - rel T, an alias for T -> pred T - - simpl_rel T, an auto-simplifying version, and syntax - #[#rel x y | P(x,y) #]#, #[#rel x y in A & B | P(x,y) #]#, etc. - The notation #[#rel of fA#]# can be used to coerce a function returning a - collective predicate to one returning pred T. - Finally, note that there is specific support for ambivalent predicates - that can work in either style, as per this file's head descriptor. **) - + coercion to the sort of the predPredType structure, conveniently denoted + {pred T}. This works better for types such as {set T} that have subtypes that + coerce to them, since the same coercion will be inserted by the application + of mem, or of any lemma that expects a generic collective predicates with + type {pred T} := pred_sort (predPredType T) = pred T; thus {pred T} should be + the preferred type for generic collective predicate parameters. + This device also lets us turn any Type aT : predArgType into the total + predicate over that type, i.e., fun _: aT => true. This allows us to write, + e.g., ##|'I_n| for the cardinal of the (finite) type of integers less than n. + **) + +(** Boolean predicates. *) Definition pred T := T -> bool. - Identity Coercion fun_of_pred : pred >-> Funclass. -Definition rel T := T -> pred T. +Definition subpred T (p1 p2 : pred T) := forall x : T, p1 x -> p2 x. -Identity Coercion fun_of_rel : rel >-> Funclass. +(* Notation for some manifest predicates. *) -Notation xpred0 := (fun _ => false). -Notation xpredT := (fun _ => true). +Notation xpred0 := (fun=> false). +Notation xpredT := (fun=> true). Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). Notation xpredC := (fun (p : pred _) x => ~~ p x). Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). Notation xpreim := (fun f (p : pred _) x => p (f x)). -Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). -Section Predicates. +(** The packed class interface for pred-like types. **) -Variables T : Type. - -Definition subpred (p1 p2 : pred T) := forall x, p1 x -> p2 x. - -Definition subrel (r1 r2 : rel T) := forall x y, r1 x y -> r2 x y. - -Definition simpl_pred := simpl_fun T bool. -Definition applicative_pred := pred T. -Definition collective_pred := pred T. +#[universes(template)] +Structure predType T := + PredType {pred_sort :> Type; topred : pred_sort -> pred T}. + +Definition clone_pred T U := + fun pT & @pred_sort T pT -> U => + fun toP (pT' := @PredType T U toP) & phant_id pT' pT => pT'. +Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ id) : form_scope. + +Canonical predPredType T := PredType (@id (pred T)). +Canonical boolfunPredType T := PredType (@id (T -> bool)). + +(** The type of abstract collective predicates. + While {pred T} is contertible to pred T, it presents the pred_sort coercion + class, which crucially does _not_ coerce to Funclass. Term whose type P coerces + to {pred T} cannot be applied to arguments, but they _can_ be used as if P + had a canonical predType instance, as the coercion will be inserted if the + unification P =~= pred_sort ?pT fails, changing the problem into the trivial + {pred T} =~= pred_sort ?pT (solution ?pT := predPredType P). + Additional benefits of this approach are that any type coercing to P will + also inherit this behaviour, and that the coercion will be apparent in the + elaborated expression. The latter may be important if the coercion is also + a canonical structure projector - see mathcomp/fingroup/fingroup.v. The + main drawback of implementing predType by coercion in this way is that the + type of the value must be known when the unification constraint is imposed: + if we only register the constraint and then later discover later that the + expression had type P it will be too late of insert a coercion, whereas a + canonical instance of predType fo P would have solved the deferred constraint. + Finally, definitions, lemmas and sections should use type {pred T} for + their generic collective type parameters, as this will make it possible to + apply such definitions and lemmas directly to values of types that implement + predType by coercion to {pred T} (values of types that implement predType + without coercing to {pred T} will have to be coerced explicitly using topred). +**) +Notation "{ 'pred' T }" := (pred_sort (predPredType T)) : type_scope. + +(** The type of self-simplifying collective predicates. **) +Definition simpl_pred T := simpl_fun T bool. +Definition SimplPred {T} (p : pred T) : simpl_pred T := SimplFun p. + +(** Some simpl_pred constructors. **) + +Definition pred0 {T} := @SimplPred T xpred0. +Definition predT {T} := @SimplPred T xpredT. +Definition predI {T} (p1 p2 : pred T) := SimplPred (xpredI p1 p2). +Definition predU {T} (p1 p2 : pred T) := SimplPred (xpredU p1 p2). +Definition predC {T} (p : pred T) := SimplPred (xpredC p). +Definition predD {T} (p1 p2 : pred T) := SimplPred (xpredD p1 p2). +Definition preim {aT rT} (f : aT -> rT) (d : pred rT) := SimplPred (xpreim f d). + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] : fun_scope. +Notation "[ 'pred' x : T | E ]" := + (SimplPred (fun x : T => E%B)) (only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := + [pred x : T | E1 && E2 ] (only parsing) : fun_scope. + +(** Coercions for simpl_pred. + As simpl_pred T values are used both applicatively and collectively we + need simpl_pred to coerce to both pred T _and_ {pred T}. However it is + undesireable to have two distinct constants for what are essentially identical + coercion functions, as this confuses the SSReflect keyed matching algorithm. + While the Coq Coercion declarations appear to disallow such Coercion aliasing, + it is possible to work around this limitation with a combination of modules + and functors, which we do below. + In addition we also give a predType instance for simpl_pred, which will + be preferred to the {pred T} coercion to solve simpl_pred T =~= pred_sort ?pT + constraints; not however that the pred_of_simpl coercion _will_ be used + when a simpl_pred T is passed as a {pred T}, since the simplPredType T + structure for simpl_pred T is _not_ convertible to predPredType T. **) + +Module PredOfSimpl. +Definition coerce T (sp : simpl_pred T) : pred T := fun_of_simpl sp. +End PredOfSimpl. +Notation pred_of_simpl := PredOfSimpl.coerce. +Coercion pred_of_simpl : simpl_pred >-> pred. +Canonical simplPredType T := PredType (@pred_of_simpl T). + +Module Type PredSortOfSimplSignature. +Parameter coerce : forall T, simpl_pred T -> {pred T}. +End PredSortOfSimplSignature. +Module DeclarePredSortOfSimpl (PredSortOfSimpl : PredSortOfSimplSignature). +Coercion PredSortOfSimpl.coerce : simpl_pred >-> pred_sort. +End DeclarePredSortOfSimpl. +Module Export PredSortOfSimplCoercion := DeclarePredSortOfSimpl PredOfSimpl. + +(** Type to pred coercion. + This lets us use types of sort predArgType as a synonym for their universal + predicate. We define this predicate as a simpl_pred T rather than a pred T or + a {pred T} so that /= and inE reduce (T x) and x \in T to true, respectively. + Unfortunately, this can't be used for existing types like bool whose sort + is already fixed (at least, not without redefining bool, true, false and + all bool operations and lemmas); we provide syntax to recast a given type + in predArgType as a workaround. **) +Definition predArgType := Type. +Bind Scope type_scope with predArgType. +Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. +Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. +Notation "{ : T }" := (T%type : predArgType) : type_scope. -Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. +(** Boolean relations. + Simplifying relations follow the coding pattern of 2-argument simplifying + functions: the simplifying type constructor is applied to the _last_ + argument. This design choice will let the in_simpl componenent of inE expand + membership in simpl_rel as well. We provide an explicit coercion to rel T + to avoid eta-expansion during coercion; this coercion self-simplifies so it + should be invisible. + **) -Coercion pred_of_simpl (p : simpl_pred) : pred T := fun_of_simpl p. -Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := - fun_of_simpl p. -Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := - fun x => (let: SimplFun f := p in fun _ => f x) x. -(** - Note: applicative_of_simpl is convertible to pred_of_simpl, while - collective_of_simpl is not. **) +Definition rel T := T -> pred T. +Identity Coercion fun_of_rel : rel >-> Funclass. -Definition pred0 := SimplPred xpred0. -Definition predT := SimplPred xpredT. -Definition predI p1 p2 := SimplPred (xpredI p1 p2). -Definition predU p1 p2 := SimplPred (xpredU p1 p2). -Definition predC p := SimplPred (xpredC p). -Definition predD p1 p2 := SimplPred (xpredD p1 p2). -Definition preim rT f (d : pred rT) := SimplPred (xpreim f d). +Definition subrel T (r1 r2 : rel T) := forall x y : T, r1 x y -> r2 x y. -Definition simpl_rel := simpl_fun T (pred T). +Definition simpl_rel T := T -> simpl_pred T. -Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. +Coercion rel_of_simpl T (sr : simpl_rel T) : rel T := fun x : T => sr x. +Arguments rel_of_simpl {T} sr x /. -Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). +Notation xrelpre := (fun f (r : rel _) x y => r (f x) (f y)). -Definition relU r1 r2 := SimplRel (xrelU r1 r2). +Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). +Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). +Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). -Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). -Proof. by move=> *; apply/orP; left. Qed. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. +Notation "[ 'rel' x y : T | E ]" := + (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. -Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). -Proof. by move=> *; apply/orP; right. Qed. +Lemma subrelUl T (r1 r2 : rel T) : subrel r1 (relU r1 r2). +Proof. by move=> x y r1xy; apply/orP; left. Qed. -#[universes(template)] -Variant mem_pred := Mem of pred T. +Lemma subrelUr T (r1 r2 : rel T) : subrel r2 (relU r1 r2). +Proof. by move=> x y r2xy; apply/orP; right. Qed. -Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +(** Variant of simpl_pred specialised to the membership operator. **) #[universes(template)] -Structure predType := PredType { - pred_sort :> Type; - topred : pred_sort -> pred T; - _ : {mem | isMem topred mem} -}. - -Definition mkPredType pT toP := PredType (exist (@isMem pT toP) _ (erefl _)). - -Canonical predPredType := Eval hnf in @mkPredType (pred T) id. -Canonical simplPredType := Eval hnf in mkPredType pred_of_simpl. -Canonical boolfunPredType := Eval hnf in @mkPredType (T -> bool) id. - -Coercion pred_of_mem mp : pred_sort predPredType := let: Mem p := mp in [eta p]. -Canonical memPredType := Eval hnf in mkPredType pred_of_mem. - -Definition clone_pred U := - fun pT & pred_sort pT -> U => - fun a mP (pT' := @PredType U a mP) & phant_id pT' pT => pT'. - -End Predicates. - -Arguments pred0 {T}. -Arguments predT {T}. -Prenex Implicits pred0 predT predI predU predC predD preim relU. - -Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) - (at level 0, format "[ 'pred' : T | E ]") : fun_scope. -Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) - (at level 0, x ident, format "[ 'pred' x | E ]") : fun_scope. -Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] - (at level 0, x ident, format "[ 'pred' x | E1 & E2 ]") : fun_scope. -Notation "[ 'pred' x : T | E ]" := (SimplPred (fun x : T => E%B)) - (at level 0, x ident, only parsing) : fun_scope. -Notation "[ 'pred' x : T | E1 & E2 ]" := [pred x : T | E1 && E2 ] - (at level 0, x ident, only parsing) : fun_scope. -Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) - (at level 0, x ident, y ident, format "[ 'rel' x y | E ]") : fun_scope. -Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) - (at level 0, x ident, y ident, only parsing) : fun_scope. - -Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) - (at level 0, format "[ 'predType' 'of' T ]") : form_scope. +Variant mem_pred T := Mem of pred T. (** - This redundant coercion lets us "inherit" the simpl_predType canonical - instance by declaring a coercion to simpl_pred. This hack is the only way - to put a predType structure on a predArgType. We use simpl_pred rather - than pred to ensure that /= removes the identity coercion. Note that the - coercion will never be used directly for simpl_pred, since the canonical - instance should always be resolved. **) - -Notation pred_class := (pred_sort (predPredType _)). -Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. + We mainly declare pred_of_mem as a coercion so that it is not displayed. + Similarly to pred_of_simpl, it will usually not be inserted by type + inference, as all mem_pred mp =~= pred_sort ?pT unification problems will + be solve by the memPredType instance below; pred_of_mem will however + be used if a mem_pred T is used as a {pred T}, which is desireable as it + will avoid a redundant mem in a collective, e.g., passing (mem A) to a lemma + expection a generic collective predicate p : {pred T} and premise x \in P + will display a subgoal x \in A rathere than x \in mem A. + Conversely, pred_of_mem will _not_ if it is used id (mem A) is used + applicatively or as a pred T; there the simpl_of_mem coercion defined below + will be used, resulting in a subgoal that displays as mem A x by simplifies + to x \in A. + **) +Coercion pred_of_mem {T} mp : {pred T} := let: Mem p := mp in [eta p]. +Canonical memPredType T := PredType (@pred_of_mem T). + +Definition in_mem {T} (x : T) mp := pred_of_mem mp x. +Definition eq_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 = in_mem x mp2. +Definition sub_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 -> in_mem x mp2. + +Arguments in_mem {T} x mp : simpl never. +Typeclasses Opaque eq_mem. +Typeclasses Opaque sub_mem. -(** - This lets us use some types as a synonym for their universal predicate. - Unfortunately, this won't work for existing types like bool, unless we - redefine bool, true, false and all bool ops. **) -Definition predArgType := Type. -Bind Scope type_scope with predArgType. -Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. -Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. +(** The [simpl_of_mem; pred_of_simpl] path provides a new mem_pred >-> pred + coercion, but does _not_ override the pred_of_mem : mem_pred >-> pred_sort + explicit coercion declaration above. + **) +Coercion simpl_of_mem {T} mp := SimplPred (fun x : T => in_mem x mp). -Notation "{ : T }" := (T%type : predArgType) - (at level 0, format "{ : T }") : type_scope. +Lemma sub_refl T (mp : mem_pred T) : sub_mem mp mp. Proof. by []. Qed. +Arguments sub_refl {T mp} [x] mp_x. (** - These must be defined outside a Section because "cooking" kills the - nosimpl tag. **) - + It is essential to interlock the production of the Mem constructor inside + the branch of the predType match, to ensure that unifying mem A with + Mem [eta ?p] sets ?p := toP A (or ?p := P if toP = id and A = [eta P]), + rather than topred pT A, had we put mem A := Mem (topred A). +**) Definition mem T (pT : predType T) : pT -> mem_pred T := - nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). -Definition in_mem T x mp := nosimpl pred_of_mem T mp x. - -Prenex Implicits mem. - -Coercion pred_of_mem_pred T mp := [pred x : T | in_mem x mp]. - -Definition eq_mem T p1 p2 := forall x : T, in_mem x p1 = in_mem x p2. -Definition sub_mem T p1 p2 := forall x : T, in_mem x p1 -> in_mem x p2. - -Typeclasses Opaque eq_mem. - -Lemma sub_refl T (p : mem_pred T) : sub_mem p p. Proof. by []. Qed. -Arguments sub_refl {T p}. + let: PredType toP := pT in fun A => Mem [eta toP A]. +Arguments mem {T pT} A : rename, simpl never. Notation "x \in A" := (in_mem x (mem A)) : bool_scope. Notation "x \in A" := (in_mem x (mem A)) : bool_scope. Notation "x \notin A" := (~~ (x \in A)) : bool_scope. Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. -Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) - (at level 0, A, B at level 69, - format "{ '[hv' 'subset' A '/ ' <= B ']' }") : type_scope. -Notation "[ 'mem' A ]" := (pred_of_simpl (pred_of_mem_pred (mem A))) - (at level 0, only parsing) : fun_scope. -Notation "[ 'rel' 'of' fA ]" := (fun x => [mem (fA x)]) - (at level 0, format "[ 'rel' 'of' fA ]") : fun_scope. -Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) - (at level 0, format "[ 'predI' A & B ]") : fun_scope. -Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) - (at level 0, format "[ 'predU' A & B ]") : fun_scope. -Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) - (at level 0, format "[ 'predD' A & B ]") : fun_scope. -Notation "[ 'predC' A ]" := (predC [mem A]) - (at level 0, format "[ 'predC' A ]") : fun_scope. -Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) - (at level 0, format "[ 'preim' f 'of' A ]") : fun_scope. - -Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] - (at level 0, x ident, format "[ 'pred' x 'in' A ]") : fun_scope. -Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] - (at level 0, x ident, format "[ 'pred' x 'in' A | E ]") : fun_scope. -Notation "[ 'pred' x 'in' A | E1 & E2 ]" := [pred x | x \in A & E1 && E2 ] - (at level 0, x ident, - format "[ 'pred' x 'in' A | E1 & E2 ]") : fun_scope. +Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) : type_scope. + +Notation "[ 'mem' A ]" := + (pred_of_simpl (simpl_of_mem (mem A))) (only parsing) : fun_scope. + +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) : fun_scope. +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := + [pred x | x \in A & E1 && E2 ] : fun_scope. + Notation "[ 'rel' x y 'in' A & B | E ]" := - [rel x y | (x \in A) && (y \in B) && E] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A & B | E ]") : fun_scope. -Notation "[ 'rel' x y 'in' A & B ]" := [rel x y | (x \in A) && (y \in B)] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A & B ]") : fun_scope. -Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A | E ]") : fun_scope. -Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A ]") : fun_scope. - -Section simpl_mem. - -Variables (T : Type) (pT : predType T). -Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). + [rel x y | (x \in A) && (y \in B) && E] : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := + [rel x y | (x \in A) && (y \in B)] : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] : fun_scope. + +(** Aliases of pred T that let us tag intances of simpl_pred as applicative + or collective, via bespoke coercions. This tagging will give control over + the simplification behaviour of inE and othe rewriting lemmas below. + For this control to work it is crucial that collective_of_simpl _not_ + be convertible to either applicative_of_simpl or pred_of_simpl. Indeed + they differ here by a commutattive conversion (of the match and lambda). + **) +Definition applicative_pred T := pred T. +Definition collective_pred T := pred T. +Coercion applicative_pred_of_simpl T (sp : simpl_pred T) : applicative_pred T := + fun_of_simpl sp. +Coercion collective_pred_of_simpl T (sp : simpl_pred T) : collective_pred T := + let: SimplFun p := sp in p. + +(** Explicit simplification rules for predicate application and membership. **) +Section PredicateSimplification. + +Variables T : Type. + +Implicit Types (p : pred T) (pT : predType T) (sp : simpl_pred T). +Implicit Types (mp : mem_pred T). (** - Bespoke structures that provide fine-grained control over matching the - various forms of the \in predicate; note in particular the different forms - of hoisting that are used. We had to work around several bugs in the - implementation of unification, notably improper expansion of telescope - projections and overwriting of a variable assignment by a later - unification (probably due to conversion cache cross-talk). **) + The following four bespoke structures provide fine-grained control over + matching the various predicate forms. While all four follow a common pattern + of using a canonical projection to match a particular form of predicate + (in pred T, simpl_pred, mem_pred and mem_pred, respectively), and display + the matched predicate in the structure type, each is in fact used for a + different, specific purpose: + - registered_applicative_pred: this user-facing structure is used to + declare values of type pred T meant to be used applicatively. The + structure parameter merely displays this same value, and is used to avoid + undesireable, visible occurrence of the structure in the right hand side + of rewrite rules such as app_predE. + There is a canonical instance of registered_applicative_pred for values + of the applicative_of_simpl coercion, which handles the + Definition Apred : applicative_pred T := [pred x | ...] idiom. + This instance is mainly intended for the in_applicative component of inE, + in conjunction with manifest_mem_pred and applicative_mem_pred. + - manifest_simpl_pred: the only instance of this structure matches manifest + simpl_pred values of the form SimplPred p, displaying p in the structure + type. This structure is used in in_simpl to detect and selectively expand + collective predicates of this form. An explicit SimplPred p pattern would + _NOT_ work for this purpose, as then the left-hand side of in_simpl would + reduce to in_mem ?x (Mem [eta ?p]) and would thus match _any_ instance + of \in, not just those arising from a manifest simpl_pred. + - manifest_mem_pred: similar to manifest_simpl_pred, the one instance of this + structure matches manifest mem_pred values of the form Mem [eta ?p]. The + purpose is different however: to match and display in ?p the actual + predicate appearing in an ... \in ... expression matched by the left hand + side of the in_applicative component of inE; then + - applicative_mem_pred is a telescope refinement of manifest_mem_pred p with + a default constructor that checks that the predicate p is the value of a + registered_applicative_pred; any unfolding occurring during this check + does _not_ affect the value of p passed to in_applicative, since that + has been fixed earlier by the manifest_mem_pred match. In particular the + definition of a predicate using the applicative_pred_of_simpl idiom above + will not be expanded - this very case is the reason in_applicative uses + a mem_pred telescope in its left hand side. The more straighforward + ?x \in applicative_pred_value ?ap (equivalent to in_mem ?x (Mem ?ap)) + with ?ap : registered_applicative_pred ?p would set ?p := [pred x | ...] + rather than ?p := Apred in the example above. + Also note that the in_applicative component of inE must be come before the + in_simpl one, as the latter also matches terms of the form x \in Apred. + Finally, no component of inE matches x \in Acoll, when + Definition Acoll : collective_pred T := [pred x | ...]. + as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) + #[universes(template)] -Structure manifest_applicative_pred p := ManifestApplicativePred { - manifest_applicative_pred_value :> pred T; - _ : manifest_applicative_pred_value = p +Structure registered_applicative_pred p := RegisteredApplicativePred { + applicative_pred_value :> pred T; + _ : applicative_pred_value = p }. -Definition ApplicativePred p := ManifestApplicativePred (erefl p). +Definition ApplicativePred p := RegisteredApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). #[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { - manifest_simpl_pred_value :> simpl_pred T; - _ : manifest_simpl_pred_value = SimplPred p + simpl_pred_value :> simpl_pred T; + _ : simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). #[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { - manifest_mem_pred_value :> mem_pred T; - _ : manifest_mem_pred_value= Mem [eta p] + mem_pred_value :> mem_pred T; + _ : mem_pred_value = Mem [eta p] }. -Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +Canonical expose_mem_pred p := ManifestMemPred (erefl (Mem [eta p])). #[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. -Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := - @ApplicativeMemPred ap mp. +Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := + [eta @ApplicativeMemPred ap]. -Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. -Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. +Lemma mem_topred pT (pp : pT) : mem (topred pp) = mem pp. +Proof. by case: pT pp. Qed. -Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Lemma topredE pT x (pp : pT) : topred pp x = (x \in pp). Proof. by rewrite -mem_topred. Qed. -Lemma app_predE x p (ap : manifest_applicative_pred p) : ap x = (x \in p). +Lemma app_predE x p (ap : registered_applicative_pred p) : ap x = (x \in p). Proof. by case: ap => _ /= ->. Qed. Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. -Proof. by case: amp => [[_ /= ->]]. Qed. +Proof. by case: amp => -[_ /= ->]. Qed. Lemma in_collective x p (msp : manifest_simpl_pred p) : (x \in collective_pred_of_simpl msp) = p x. Proof. by case: msp => _ /= ->. Qed. Lemma in_simpl x p (msp : manifest_simpl_pred p) : - in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. + in_mem x (Mem [eta pred_of_simpl msp]) = p x. Proof. by case: msp => _ /= ->. Qed. (** Because of the explicit eta expansion in the left-hand side, this lemma - should only be used in a right-to-left direction. The 8.3 hack allowing - partial right-to-left use does not work with the improved expansion - heuristics in 8.4. **) + should only be used in the left-to-right direction. + **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1345,55 +1530,39 @@ Proof. by []. Qed. Definition memE := mem_simpl. (* could be extended *) -Lemma mem_mem (pp : pT) : (mem (mem pp) = mem pp) * (mem [mem pp] = mem pp). -Proof. by rewrite -mem_topred. Qed. +Lemma mem_mem mp : + (mem mp = mp) * (mem (mp : simpl_pred T) = mp) * (mem (mp : pred T) = mp). +Proof. by case: mp. Qed. -End simpl_mem. +End PredicateSimplification. (** Qualifiers and keyed predicates. **) #[universes(template)] -Variant qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of {pred T}. -Coercion has_quality n T (q : qualifier n T) : pred_class := +Coercion has_quality n T (q : qualifier n T) : {pred T} := fun x => let: Qualifier _ p := q in p x. Arguments has_quality n {T}. Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. -Notation "x \is A" := (x \in has_quality 0 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is A ']'") : bool_scope. -Notation "x \is 'a' A" := (x \in has_quality 1 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is 'a' A ']'") : bool_scope. -Notation "x \is 'an' A" := (x \in has_quality 2 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is 'an' A ']'") : bool_scope. -Notation "x \isn't A" := (x \notin has_quality 0 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't A ']'") : bool_scope. -Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'a' A ']'") : bool_scope. -Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'an' A ']'") : bool_scope. -Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' x : T | P ]" := (Qualifier 0 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. -Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' 'a' x : T | P ]" := (Qualifier 1 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. -Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. +Notation "x \is A" := (x \in has_quality 0 A) : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' x : T | P ]" := + (Qualifier 0 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := + (Qualifier 1 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := + (Qualifier 2 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'an' x : T | P ]" := + (Qualifier 2 (fun x : T => P%B)) (only parsing) : form_scope. (** Keyed predicates: support for property-bearing predicate interfaces. **) @@ -1401,12 +1570,12 @@ Section KeyPred. Variable T : Type. #[universes(template)] -Variant pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : {pred T}) := DefaultPredKey. -Variable p : predPredType T. +Variable p : {pred T}. #[universes(template)] Structure keyed_pred (k : pred_key p) := - PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. Variable k : pred_key p. Definition KeyedPred := @PackKeyedPred k p (frefl _). @@ -1418,10 +1587,10 @@ Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. Instances that strip the mem cast; the first one has "pred_of_mem" as its projection head value, while the second has "pred_of_simpl". The latter has the side benefit of preempting accidental misdeclarations. - Note: pred_of_mem is the registered mem >-> pred_class coercion, while - simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We + Note: pred_of_mem is the registered mem >-> pred_sort coercion, while + [simpl_of_mem; pred_of_simpl] is the mem >-> pred >=> Funclass coercion. We must write down the coercions explicitly as the Canonical head constant - computation does not strip casts !! **) + computation does not strip casts. **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1429,8 +1598,8 @@ Canonical keyed_mem_simpl := End KeyPred. -Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) - (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. +Local Notation in_unkey x S := (x \in @unkey_pred _ S _ _) (only parsing). +Notation "x \in S" := (in_unkey x S) (only printing) : bool_scope. Section KeyedQualifier. @@ -1447,12 +1616,12 @@ Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. End KeyedQualifier. -Notation "x \i 's' A" := (x \i n has_quality 0 A) - (at level 70, format "'[hv' x '/ ' \i 's' A ']'") : bool_scope. -Notation "x \i 's' 'a' A" := (x \i n has_quality 1 A) - (at level 70, format "'[hv' x '/ ' \i 's' 'a' A ']'") : bool_scope. -Notation "x \i 's' 'an' A" := (x \i n has_quality 2 A) - (at level 70, format "'[hv' x '/ ' \i 's' 'an' A ']'") : bool_scope. +Notation "x \is A" := + (in_unkey x (has_quality 0 A)) (only printing) : bool_scope. +Notation "x \is 'a' A" := + (in_unkey x (has_quality 1 A)) (only printing) : bool_scope. +Notation "x \is 'an' A" := + (in_unkey x (has_quality 2 A)) (only printing) : bool_scope. Module DefaultKeying. @@ -1592,7 +1761,7 @@ Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := End LocalProperties. Definition inPhantom := Phantom Prop. -Definition onPhantom T P (x : T) := Phantom Prop (P x). +Definition onPhantom {T} P (x : T) := Phantom Prop (P x). Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := exists2 g, prop_in1 d (inPhantom (cancel f g)) @@ -1602,59 +1771,30 @@ Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) & prop_in1 cd (inPhantom (cancel g f)). -Notation "{ 'for' x , P }" := - (prop_for x (inPhantom P)) - (at level 0, format "{ 'for' x , P }") : type_scope. - -Notation "{ 'in' d , P }" := - (prop_in1 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d , P }") : type_scope. - +Notation "{ 'for' x , P }" := (prop_for x (inPhantom P)) : type_scope. +Notation "{ 'in' d , P }" := (prop_in1 (mem d) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 , P }" := - (prop_in11 (mem d1) (mem d2) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 , P }") : type_scope. - -Notation "{ 'in' d & , P }" := - (prop_in2 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d & , P }") : type_scope. - + (prop_in11 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & , P }" := (prop_in2 (mem d) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 & d3 , P }" := - (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 & d3 , P }") : type_scope. - + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & & d3 , P }" := - (prop_in21 (mem d1) (mem d3) (inPhantom P)) - (at level 0, format "{ 'in' d1 & & d3 , P }") : type_scope. - + (prop_in21 (mem d1) (mem d3) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 & , P }" := - (prop_in12 (mem d1) (mem d2) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 & , P }") : type_scope. - -Notation "{ 'in' d & & , P }" := - (prop_in3 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d & & , P }") : type_scope. - + (prop_in12 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & & , P }" := (prop_in3 (mem d) (inPhantom P)) : type_scope. Notation "{ 'on' cd , P }" := - (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd , P }") : type_scope. + (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. Notation "{ 'on' cd & , P }" := - (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd & , P }") : type_scope. - -Local Arguments onPhantom {_%type_scope} _ _. + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. +Local Arguments onPhantom : clear scopes. Notation "{ 'on' cd , P & g }" := - (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) - (at level 0, format "{ 'on' cd , P & g }") : type_scope. - -Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) - (at level 0, f at level 8, - format "{ 'in' d , 'bijective' f }") : type_scope. - -Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) - (at level 0, f at level 8, - format "{ 'on' cd , 'bijective' f }") : type_scope. + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) : type_scope. +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) : type_scope. +Notation "{ 'on' cd , 'bijective' f }" := + (bijective_on (mem cd) f) : type_scope. (** Weakening and monotonicity lemmas for localized predicates. @@ -1666,7 +1806,7 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) Section LocalGlobal. Variables T1 T2 T3 : predArgType. -Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +Variables (D1 : {pred T1}) (D2 : {pred T2}) (D3 : {pred T3}). Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). @@ -1850,7 +1990,7 @@ End MonoHomoMorphismTheory. Section MonoHomoMorphismTheory_in. Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : pred aT). +Variable (aD : {pred aT}). Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). Notation rD := [pred x | g x \in aD]. diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 6c74ac1960..5e3e8ce5fb 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -28,6 +28,11 @@ Declare ML Module "ssreflect_plugin". argumentType c == the T such that c : forall x : T, P x. returnType c == the R such that c : T -> R. {type of c for s} == P s where c : forall x : T, P x. + nonPropType == an interface for non-Prop Types: a nonPropType coerces + to a Type, and only types that do _not_ have sort + Prop are canonical nonPropType instances. This is + useful for applied views (see mid-file comment). + notProp T == the nonPropType instance for type T. phantom T v == singleton type with inhabitant Phantom T v. phant T == singleton type with inhabitant Phant v. =^~ r == the converse of rewriting rule r (e.g., in a @@ -57,8 +62,6 @@ Declare ML Module "ssreflect_plugin". More information about these definitions and their use can be found in the ssreflect manual, and in specific comments below. **) - - Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -77,7 +80,8 @@ Reserved Notation "(* 69 *)" (at level 69). (** Non ambiguous keyword to check if the SsrSyntax module is imported **) Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). -Reserved Notation "" (at level 200). +Reserved Notation "" (at level 0, n at level 0, + format ""). Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). End SsrSyntax. @@ -85,6 +89,39 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. +(** Save primitive notation that will be overloaded. **) +Local Notation CoqGenericIf c vT vF := (if c then vT else vF) (only parsing). +Local Notation CoqGenericDependentIf c x R vT vF := + (if c as x return R then vT else vF) (only parsing). +Local Notation CoqCast x T := (x : T) (only parsing). + +(** Reserve notation that introduced in this file. **) +Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, + c, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, x ident, only parsing). + +Reserved Notation "x : T" (at level 100, right associativity, + format "'[hv' x '/ ' : T ']'"). +Reserved Notation "T : 'Type'" (at level 100, format "T : 'Type'"). +Reserved Notation "P : 'Prop'" (at level 100, format "P : 'Prop'"). + +Reserved Notation "[ 'the' sT 'of' v 'by' f ]" (at level 0, + format "[ 'the' sT 'of' v 'by' f ]"). +Reserved Notation "[ 'the' sT 'of' v ]" (at level 0, + format "[ 'the' sT 'of' v ]"). +Reserved Notation "{ 'type' 'of' c 'for' s }" (at level 0, + format "{ 'type' 'of' c 'for' s }"). + +Reserved Notation "=^~ r" (at level 100, format "=^~ r"). + +Reserved Notation "[ 'unlockable' 'of' C ]" (at level 0, + format "[ 'unlockable' 'of' C ]"). +Reserved Notation "[ 'unlockable' 'fun' C ]" (at level 0, + format "[ 'unlockable' 'fun' C ]"). + (** To define notations for tactic in intro patterns. When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) @@ -100,32 +137,28 @@ Delimit Scope ssripat_scope with ssripat. Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. -Notation "'if' c 'then' v1 'else' v2" := - (if c then v1 else v2) - (at level 200, c, v1, v2 at level 200, only parsing) : general_if_scope. +Notation "'if' c 'then' vT 'else' vF" := + (CoqGenericIf c vT vF) (only parsing) : general_if_scope. -Notation "'if' c 'return' t 'then' v1 'else' v2" := - (if c return t then v1 else v2) - (at level 200, c, t, v1, v2 at level 200, only parsing) : general_if_scope. +Notation "'if' c 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c c R vT vF) (only parsing) : general_if_scope. -Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := - (if c as x return t then v1 else v2) - (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) - : general_if_scope. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c x R vT vF) (only parsing) : general_if_scope. (** Force boolean interpretation of simple if expressions. **) Declare Scope boolean_if_scope. Delimit Scope boolean_if_scope with BOOL_IF. -Notation "'if' c 'return' t 'then' v1 'else' v2" := - (if c%bool is true in bool return t then v1 else v2) : boolean_if_scope. +Notation "'if' c 'return' R 'then' vT 'else' vF" := + (if c is true as c in bool return R then vT else vF) : boolean_if_scope. -Notation "'if' c 'then' v1 'else' v2" := - (if c%bool is true in bool return _ then v1 else v2) : boolean_if_scope. +Notation "'if' c 'then' vT 'else' vF" := + (if c%bool is true as _ in bool return _ then vT else vF) : boolean_if_scope. -Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := - (if c%bool is true as x in bool return t then v1 else v2) : boolean_if_scope. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (if c%bool is true as x in bool return R then vT else vF) : boolean_if_scope. Open Scope boolean_if_scope. @@ -149,19 +182,15 @@ Open Scope form_scope. precedence of the notation, which binds less tightly than application), and put printing boxes that print the type of a long definition on a separate line rather than force-fit it at the right margin. **) -Notation "x : T" := (x : T) - (at level 100, right associativity, - format "'[hv' x '/ ' : T ']'") : core_scope. +Notation "x : T" := (CoqCast x T) : core_scope. (** Allow the casual use of notations like nat * nat for explicit Type declarations. Note that (nat * nat : Type) is NOT equivalent to (nat * nat)%%type, whose inferred type is legacy type "Set". **) -Notation "T : 'Type'" := (T%type : Type) - (at level 100, only parsing) : core_scope. +Notation "T : 'Type'" := (CoqCast T%type Type) (only parsing) : core_scope. (** Allow similarly Prop annotation for, e.g., rewrite multirules. **) -Notation "P : 'Prop'" := (P%type : Prop) - (at level 100, only parsing) : core_scope. +Notation "P : 'Prop'" := (CoqCast P%type Prop) (only parsing) : core_scope. (** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. @@ -170,8 +199,10 @@ Definition abstract_key := tt. Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := let: tt := lock in statement. -Notation "" := (abstract _ n _). -Notation "T (* n *)" := (abstract T n abstract_key). +Declare Scope ssr_scope. +Notation "" := (abstract _ n _) : ssr_scope. +Notation "T (* n *)" := (abstract T n abstract_key) : ssr_scope. +Open Scope ssr_scope. Register abstract_lock as plugins.ssreflect.abstract_lock. Register abstract_key as plugins.ssreflect.abstract_key. @@ -222,28 +253,27 @@ Local Arguments get_by _%type_scope _%type_scope _ _ _ _. Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) - (at level 0, only parsing) : form_scope. + (only parsing) : form_scope. -Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) - (at level 0, only parsing) : form_scope. +Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*) s s) _)) + (only parsing) : form_scope. (** - The following are "format only" versions of the above notations. Since Coq - doesn't provide this facility, we fake it by splitting the "the" keyword. + The following are "format only" versions of the above notations. We need to do this to prevent the formatter from being be thrown off by application collapsing, coercion insertion and beta reduction in the right hand side of the notations above. **) -Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. +Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) + (only printing) : form_scope. -Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. +Notation "[ 'the' sT 'of' v ]" := (@get _ sT v _ _) + (only printing) : form_scope. (** We would like to recognize -Notation " #[# 'th' 'e' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) - (at level 0, format " #[# 'th' 'e' sT 'of' v : 'Type' #]#") : form_scope. +Notation " #[# 'the' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'the' sT 'of' v : 'Type' #]#") : form_scope. **) (** @@ -278,8 +308,7 @@ Definition argumentType T P & forall x : T, P x := T. Definition dependentReturnType T P & forall x : T, P x := P. Definition returnType aT rT & aT -> rT := rT. -Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) - (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. +Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) : type_scope. (** A generic "phantom" type (actually, a unit type with a phantom parameter). @@ -330,7 +359,7 @@ Notation unkeyed x := (let flex := x in flex). (** Ssreflect converse rewrite rule rule idiom. **) Definition ssr_converse R (r : R) := (Logic.I, r). -Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. +Notation "=^~ r" := (ssr_converse r) : form_scope. (** Term tagging (user-level). @@ -397,11 +426,11 @@ Ltac ssrdone0 := Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. -Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) - (at level 0, format "[ 'unlockable' 'of' C ]") : form_scope. +Notation "[ 'unlockable' 'of' C ]" := + (@Unlockable _ _ C (unlock _)) : form_scope. -Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) - (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. +Notation "[ 'unlockable' 'fun' C ]" := + (@Unlockable _ (fun _ => _) C (unlock _)) : form_scope. (** Generic keyed constant locking. **) @@ -418,7 +447,7 @@ Proof. by case: k. Qed. Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(** More accurate variant of unlock, and safer alternative to locked_withE. **) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. @@ -597,3 +626,102 @@ Ltac over := | apply: Under_iff.under_iff_done | rewrite over ]. + +(** An interface for non-Prop types; used to avoid improper instantiation + of polymorphic lemmas with on-demand implicits when they are used as views. + For example: Some_inj {T} : forall x y : T, Some x = Some y -> x = y. + Using move/Some_inj on a goal of the form Some n = Some 0 will fail: + SSReflect will interpret the view as @Some_inj ?T _top_assumption_ + since this is the well-typed application of the view with the minimal + number of inserted evars (taking ?T := Some n = Some 0), and then will + later complain that it cannot erase _top_assumption_ after having + abstracted the viewed assumption. Making x and y maximal implicits + would avoid this and force the intended @Some_inj nat x y _top_assumption_ + interpretation, but is undesireable as it makes it harder to use Some_inj + with the many SSReflect and MathComp lemmas that have an injectivity + premise. Specifying {T : nonPropType} solves this more elegantly, as then + (?T : Type) no longer unifies with (Some n = Some 0), which has sort Prop. + **) + +Module NonPropType. + +(** Implementation notes: + We rely on three interface Structures: + - test_of r, the middle structure, performs the actual check: it has two + canonical instances whose 'condition' projection are maybeProj (?P : Prop) + and tt, and which set r := true and r := false, respectively. Unifying + condition (?t : test_of ?r) with maybeProj T will thus set ?r to true if + T is in Prop as the test_Prop T instance will apply, and otherwise simplify + maybeProp T to tt and use the test_negative instance and set ?r to false. + - call_of c r sets up a call to test_of on condition c with expected result r. + It has a default instance for its 'callee' projection to Type, which + sets c := maybeProj T and r := false whe unifying with a type T. + - type is a telescope on call_of c r, which checks that unifying test_of ?r1 + with c indeed sets ?r1 := r; the type structure bundles the 'test' instance + and its 'result' value along with its call_of c r projection. The default + instance essentially provides eta-expansion for 'type'. This is only + essential for the first 'result' projection to bool; using the instance + for other projection merely avoids spurrious delta expansions that would + spoil the notProp T notation. + In detail, unifying T =~= ?S with ?S : nonPropType, i.e., + (1) T =~= @callee (@condition (result ?S) (test ?S)) (result ?S) (frame ?S) + first uses the default call instance with ?T := T to reduce (1) to + (2a) @condition (result ?S) (test ?S) =~= maybeProp T + (3) result ?S =~= false + (4) frame ?S =~= call T + along with some trivial universe-related checks which are irrelevant here. + Then the unification tries to use the test_Prop instance to reduce (2a) to + (6a) result ?S =~= true + (7a) ?P =~= T with ?P : Prop + (8a) test ?S =~= test_Prop ?P + Now the default 'check' instance with ?result := true resolves (6a) as + (9a) ?S := @check true ?test ?frame + Then (7a) can be solved precisely if T has sort at most (hence exactly) Prop, + and then (8a) is solved by the check instance, yielding ?test := test_Prop T, + and completing the solution of (2a), and _committing_ to it. But now (3) is + inconsistent with (9a), and this makes the entire problem (1) fails. + If on the othe hand T does not have sort Prop then (7a) fails and the + unification resorts to delta expanding (2a), which gives + (2b) @condition (result ?S) (test ?S) =~= tt + which is then reduced, using the test_negative instance, to + (6b) result ?S =~= false + (8b) test ?S =~= test_negative + Both are solved using the check default instance, as in the (2a) branch, giving + (9b) ?S := @check false test_negative ?frame + Then (3) and (4) are similarly soved using check, giving the final assignment + (9) ?S := notProp T + Observe that we _must_ perform the actual test unification on the arguments + of the initial canonical instance, and not on the instance itself as we do + in mathcomp/matrix and mathcomp/vector, because we want the unification to + fail when T has sort Prop. If both the test_of _and_ the result check + unifications were done as part of the structure telescope then the latter + would be a sub-problem of the former, and thus failing the check would merely + make the test_of unification backtrack and delta-expand and we would not get + failure. + **) + +Structure call_of (condition : unit) (result : bool) := Call {callee : Type}. +Definition maybeProp (T : Type) := tt. +Definition call T := Call (maybeProp T) false T. + +Structure test_of (result : bool) := Test {condition :> unit}. +Definition test_Prop (P : Prop) := Test true (maybeProp P). +Definition test_negative := Test false tt. + +Structure type := + Check {result : bool; test : test_of result; frame : call_of test result}. +Definition check result test frame := @Check result test frame. + +Module Exports. +Canonical call. +Canonical test_Prop. +Canonical test_negative. +Canonical check. +Notation nonPropType := type. +Coercion callee : call_of >-> Sortclass. +Coercion frame : type >-> call_of. +Notation notProp T := (@check false test_negative (call T)). +End Exports. + +End NonPropType. +Export NonPropType.Exports. diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index b51ffada0c..46af775296 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -219,25 +219,113 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Declare Scope fun_scope. -Delimit Scope fun_scope with FUN. -Open Scope fun_scope. +(** Parsing / printing declarations. *) +Reserved Notation "p .1" (at level 2, left associativity, format "p .1"). +Reserved Notation "p .2" (at level 2, left associativity, format "p .2"). +Reserved Notation "f ^~ y" (at level 10, y at level 8, no associativity, + format "f ^~ y"). +Reserved Notation "@^~ x" (at level 10, x at level 8, no associativity, + format "@^~ x"). +Reserved Notation "[ 'eta' f ]" (at level 0, format "[ 'eta' f ]"). +Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). + +Reserved Notation "[ 'fun' : T => E ]" (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x : T => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, + x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). + +Reserved Notation "f =1 g" (at level 70, no associativity). +Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f =2 g" (at level 70, no associativity). +Reserved Notation "f =2 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f \o g" (at level 50, format "f \o '/ ' g"). +Reserved Notation "f \; g" (at level 60, right associativity, + format "f \; '/ ' g"). + +Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a >-> r }"). +Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a }"). +Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). +Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a }"). +Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a >-> r }"). +Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a }"). +Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). +Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a }"). +Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y /~ a }"). +Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a >-> r }"). +Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a }"). +Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). +Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a }"). +Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y /~ a }"). + +Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). +Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). -(** Notations for argument transpose **) -Notation "f ^~ y" := (fun x => f x y) - (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. -Notation "@^~ x" := (fun f => f x) - (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. +(** + Syntax for defining auxiliary recursive function. + Usage: + Section FooDefinition. + Variables (g1 : T1) (g2 : T2). (globals) + Fixoint foo_auxiliary (a3 : T3) ... := + body, using #[#rec e3, ... #]# for recursive calls + where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. + Definition foo x y .. := #[#rec e1, ... #]#. + + proofs about foo + End FooDefinition. **) + +Reserved Notation "[ 'rec' a ]" (at level 0, + format "[ 'rec' a ]"). +Reserved Notation "[ 'rec' a , b ]" (at level 0, + format "[ 'rec' a , b ]"). +Reserved Notation "[ 'rec' a , b , c ]" (at level 0, + format "[ 'rec' a , b , c ]"). +Reserved Notation "[ 'rec' a , b , c , d ]" (at level 0, + format "[ 'rec' a , b , c , d ]"). +Reserved Notation "[ 'rec' a , b , c , d , e ]" (at level 0, + format "[ 'rec' a , b , c , d , e ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i , j ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i , j ]"). Declare Scope pair_scope. Delimit Scope pair_scope with PAIR. Open Scope pair_scope. (** Notations for pair/conjunction projections **) -Notation "p .1" := (fst p) - (at level 2, left associativity, format "p .1") : pair_scope. -Notation "p .2" := (snd p) - (at level 2, left associativity, format "p .2") : pair_scope. +Notation "p .1" := (fst p) : pair_scope. +Notation "p .2" := (snd p) : pair_scope. Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). @@ -291,41 +379,13 @@ Canonical wrap T x := @Wrap T x. Prenex Implicits unwrap wrap Wrap. -(** - Syntax for defining auxiliary recursive function. - Usage: - Section FooDefinition. - Variables (g1 : T1) (g2 : T2). (globals) - Fixoint foo_auxiliary (a3 : T3) ... := - body, using #[#rec e3, ... #]# for recursive calls - where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. - Definition foo x y .. := #[#rec e1, ... #]#. - + proofs about foo - End FooDefinition. **) +Declare Scope fun_scope. +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. -Reserved Notation "[ 'rec' a0 ]" - (at level 0, format "[ 'rec' a0 ]"). -Reserved Notation "[ 'rec' a0 , a1 ]" - (at level 0, format "[ 'rec' a0 , a1 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). +(** Notations for argument transpose **) +Notation "f ^~ y" := (fun x => f x y) : fun_scope. +Notation "@^~ x" := (fun f => f x) : fun_scope. (** Definitions and notation for explicit functions with simplification, @@ -344,33 +404,19 @@ Coercion fun_of_simpl : simpl_fun >-> Funclass. End SimplFun. -Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) - (at level 0, - format "'[hv' [ 'fun' : T => '/ ' E ] ']'") : fun_scope. - -Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) - (at level 0, x ident, - format "'[hv' [ 'fun' x => '/ ' E ] ']'") : fun_scope. - +Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) : fun_scope. +Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) : fun_scope. +Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) : fun_scope. Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) - (at level 0, x ident, only parsing) : fun_scope. - -Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) - (at level 0, x ident, y ident, - format "'[hv' [ 'fun' x y => '/ ' E ] ']'") : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - -Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := - (fun x : xT => [fun y : yT => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. + (only parsing) : fun_scope. +Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" := (fun x : T => [fun y : U => E]) + (only parsing) : fun_scope. (** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. @@ -402,51 +448,38 @@ Typeclasses Opaque eqrel. Hint Resolve frefl rrefl : core. -Notation "f1 =1 f2" := (eqfun f1 f2) - (at level 70, no associativity) : fun_scope. -Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) - (at level 70, f2 at next level, A at level 90) : fun_scope. -Notation "f1 =2 f2" := (eqrel f1 f2) - (at level 70, no associativity) : fun_scope. -Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) - (at level 70, f2 at next level, A at level 90) : fun_scope. +Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) : fun_scope. Section Composition. Variables A B C : Type. -Definition funcomp u (f : B -> A) (g : C -> B) x := let: tt := u in f (g x). -Definition catcomp u g f := funcomp u f g. -Local Notation comp := (funcomp tt). - +Definition comp (f : B -> A) (g : C -> B) x := f (g x). +Definition catcomp g f := comp f g. Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. -Proof. by move=> eq_ff' eq_gg' x; rewrite /= eq_gg' eq_ff'. Qed. +Proof. by move=> eq_ff' eq_gg' x; rewrite /comp eq_gg' eq_ff'. Qed. End Composition. -Notation comp := (funcomp tt). -Notation "@ 'comp'" := (fun A B C => @funcomp A B C tt). -Notation "f1 \o f2" := (comp f1 f2) - (at level 50, format "f1 \o '/ ' f2") : fun_scope. -Notation "f1 \; f2" := (catcomp tt f1 f2) - (at level 60, right associativity, format "f1 \; '/ ' f2") : fun_scope. +Arguments comp {A B C} f g x /. +Arguments catcomp {A B C} g f x /. +Notation "f1 \o f2" := (comp f1 f2) : fun_scope. +Notation "f1 \; f2" := (catcomp f1 f2) : fun_scope. -Notation "[ 'eta' f ]" := (fun x => f x) - (at level 0, format "[ 'eta' f ]") : fun_scope. +Notation "[ 'eta' f ]" := (fun x => f x) : fun_scope. -Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. +Notation "'fun' => E" := (fun _ => E) : fun_scope. Notation id := (fun x => x). -Notation "@ 'id' T" := (fun x : T => x) - (at level 10, T at level 8, only parsing) : fun_scope. +Notation "@ 'id' T" := (fun x : T => x) (only parsing) : fun_scope. -Definition id_head T u x : T := let: tt := u in x. -Definition explicit_id_key := tt. -Notation idfun := (id_head tt). -Notation "@ 'idfun' T " := (@id_head T explicit_id_key) - (at level 10, T at level 8, format "@ 'idfun' T") : fun_scope. +Definition idfun T x : T := x. +Arguments idfun {T} x /. Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. @@ -542,74 +575,33 @@ Definition monomorphism_2 (aR rR : _ -> _ -> sT) := End Morphism. Notation "{ 'morph' f : x / a >-> r }" := - (morphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'morph' f : x / a >-> r }") : type_scope. - + (morphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'morph' f : x / a }" := - (morphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'morph' f : x / a }") : type_scope. - + (morphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'morph' f : x y / a >-> r }" := - (morphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'morph' f : x y / a >-> r }") : type_scope. - + (morphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'morph' f : x y / a }" := - (morphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'morph' f : x y / a }") : type_scope. - + (morphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'homo' f : x / a >-> r }" := - (homomorphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'homo' f : x / a >-> r }") : type_scope. - + (homomorphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'homo' f : x / a }" := - (homomorphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'homo' f : x / a }") : type_scope. - + (homomorphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'homo' f : x y / a >-> r }" := - (homomorphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y / a >-> r }") : type_scope. - + (homomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'homo' f : x y / a }" := - (homomorphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y / a }") : type_scope. - + (homomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'homo' f : x y /~ a }" := - (homomorphism_2 f (fun y x => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y /~ a }") : type_scope. - + (homomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. Notation "{ 'mono' f : x / a >-> r }" := - (monomorphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'mono' f : x / a >-> r }") : type_scope. - + (monomorphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'mono' f : x / a }" := - (monomorphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'mono' f : x / a }") : type_scope. - + (monomorphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'mono' f : x y / a >-> r }" := - (monomorphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y / a >-> r }") : type_scope. - + (monomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'mono' f : x y / a }" := - (monomorphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y / a }") : type_scope. - + (monomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'mono' f : x y /~ a }" := - (monomorphism_2 f (fun y x => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y /~ a }") : type_scope. + (monomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. (** In an intuitionistic setting, we have two degrees of injectivity. The @@ -620,9 +612,6 @@ Notation "{ 'mono' f : x y /~ a }" := Section Injections. -(** - rT must come first so we can use @ to mitigate the Coq 1st order - unification bug (e..g., Coq can't infer rT from a "cancel" lemma). **) Variables (rT aT : Type) (f : aT -> rT). Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. @@ -650,10 +639,8 @@ Proof. by move=> fK <-. Qed. End Injections. -Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. - -(** Force implicits to use as a view. **) -Prenex Implicits Some_inj. +Lemma Some_inj {T : nonPropType} : injective (@Some T). +Proof. by move=> x y []. Qed. (** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index ca360f65a7..6fc630056c 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -634,9 +634,9 @@ Fixpoint mem_seq (s : seq T) := Definition eqseq_class := seq T. Identity Coercion seq_of_eqseq : eqseq_class >-> seq. -Coercion pred_of_eq_seq (s : eqseq_class) : pred_class := [eta mem_seq s]. +Coercion pred_of_eq_seq (s : eqseq_class) : {pred T} := [eta mem_seq s]. -Canonical seq_predType := @mkPredType T (seq T) pred_of_eq_seq. +Canonical seq_predType := @PredType T (seq T) pred_of_eq_seq. Fixpoint uniq s := if s is x :: s' then (x \notin s') && uniq s' else true. diff --git a/test-suite/ssr/nonPropType.v b/test-suite/ssr/nonPropType.v new file mode 100644 index 0000000000..bcdc907b38 --- /dev/null +++ b/test-suite/ssr/nonPropType.v @@ -0,0 +1,23 @@ +Require Import ssreflect. + +(** Test the nonPropType interface and its application to prevent unwanted + instantiations in views. **) + +Lemma raw_flip {T} (x y : T) : x = y -> y = x. Proof. by []. Qed. +Lemma flip {T : nonPropType} (x y : T) : x = y -> y = x. Proof. by []. Qed. + +Lemma testSet : true = false -> True. +Proof. +Fail move/raw_flip. +have flip_true := @flip _ true. +(* flip_true : forall y : notProp bool, x = y -> y = x *) +simpl in flip_true. +(* flip_true : forall y : bool, x = y -> y = x *) +by move/flip. +Qed. + +Lemma override (t1 t2 : True) : t1 = t2 -> True. +Proof. +Fail move/flip. +by move/(@flip (notProp True)). +Qed. diff --git a/test-suite/ssr/predRewrite.v b/test-suite/ssr/predRewrite.v new file mode 100644 index 0000000000..2ad762ccf1 --- /dev/null +++ b/test-suite/ssr/predRewrite.v @@ -0,0 +1,28 @@ +Require Import ssreflect ssrfun ssrbool. + +(** Test the various idioms that control rewriting in boolean predicate. **) + +Definition simpl_P := [pred a | ~~ a]. +Definition nosimpl_P : pred bool := [pred a | ~~ a]. +Definition coll_P : collective_pred bool := [pred a | ~~ a]. +Definition appl_P : applicative_pred bool := [pred a | ~~ a]. +Definition can_appl_P : pred bool := [pred a | ~~ a]. +Canonical register_can_appl_P := ApplicativePred can_appl_P. +Ltac see_neg := (let x := fresh "x" in set x := {-}(~~ _); clear x). + +Lemma test_pred_rewrite (f := false) : True. +Proof. +have _: f \in simpl_P by rewrite inE; see_neg. +have _ a: simpl_P (a && f) by simpl; see_neg; rewrite andbF. +have _ a: simpl_P (a && f) by rewrite inE; see_neg; rewrite andbF. +have _: f \in nosimpl_P by rewrite inE; see_neg. +have _: nosimpl_P f. simpl. Fail see_neg. Fail rewrite inE. done. +have _: f \in coll_P. Fail rewrite inE. by rewrite in_collective; see_neg. +have _: f \in appl_P. + rewrite inE. Fail see_neg. Fail rewrite inE. simpl. Fail see_neg. + Fail rewrite app_predE. done. +have _: f \in can_appl_P. + rewrite inE. Fail see_neg. Fail rewrite inE. simpl. Fail see_neg. + by rewrite app_predE in_simpl; see_neg. +done. +Qed. -- cgit v1.2.3 From d2bbd834841ba3c8b2b482a02489bd4fac19f0fb Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 4 Apr 2019 11:07:14 +0200 Subject: [vm] x86_64 registers Backport https://github.com/ocaml/ocaml/commit/bc333918980b97a2c81031ec33e72a417f854376 from OCaml VM --- kernel/byterun/coq_interp.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 2293ae9dfd..e838519fe4 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -159,6 +159,11 @@ if (sp - num_args < coq_stack_threshold) { \ #define ACCU_REG asm("38") #define JUMPTBL_BASE_REG asm("39") #endif +#ifdef __x86_64__ +#define PC_REG asm("%r15") +#define SP_REG asm("%r14") +#define ACCU_REG asm("%r13") +#endif #endif #define CheckInt1() do{ \ -- cgit v1.2.3 From d1905fbcde5905de640657a820e531929e23dd8a Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 5 Apr 2019 12:35:10 +0200 Subject: [vm] Arm 64 registers Backport https://github.com/ocaml/ocaml/commit/055d5c0379e42b4f561cb1fc5159659d8e9a7b6f from OCaml VM --- kernel/byterun/coq_interp.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index e838519fe4..1925ef5932 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -164,6 +164,12 @@ if (sp - num_args < coq_stack_threshold) { \ #define SP_REG asm("%r14") #define ACCU_REG asm("%r13") #endif +#ifdef __aarch64__ +#define PC_REG asm("%x19") +#define SP_REG asm("%x20") +#define ACCU_REG asm("%x21") +#define JUMPTBL_BASE_REG asm("%x22") +#endif #endif #define CheckInt1() do{ \ -- cgit v1.2.3 From 46896e9442e74cb78ad7396054cee76564f78ec3 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 5 Apr 2019 12:37:03 +0200 Subject: [vm] ARM registers Backport https://github.com/ocaml/ocaml/commit/eb1922c6ab88e832e39ba3972fab619081061928 from OCaml VM --- kernel/byterun/coq_interp.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 1925ef5932..9742768c5d 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -148,8 +148,9 @@ if (sp - num_args < coq_stack_threshold) { \ #define SP_REG asm("a4") #define ACCU_REG asm("d7") #endif -#if defined(__arm__) && !defined(__thumb2__) -#define PC_REG asm("r9") +/* OCaml PR#4953: these specific registers not available in Thumb mode */ +#if defined(__arm__) && !defined(__thumb__) +#define PC_REG asm("r6") #define SP_REG asm("r8") #define ACCU_REG asm("r7") #endif -- cgit v1.2.3 From df6328178a92d7a51e2a08acbec5013d080e73aa Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 5 Apr 2019 12:44:08 +0200 Subject: [vm] PPC64 registers Backport https://github.com/ocaml/ocaml/commit/c6ce97fe26e149d43ee2cf71ca821a4592ce1785 from OCaml VM --- kernel/byterun/coq_interp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 9742768c5d..a8fd2fbe47 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -133,7 +133,7 @@ if (sp - num_args < coq_stack_threshold) { \ #define SP_REG asm("%edi") #define ACCU_REG #endif -#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#if defined(__ppc__) || defined(__ppc64__) #define PC_REG asm("26") #define SP_REG asm("27") #define ACCU_REG asm("28") -- cgit v1.2.3 From e9fec7c112a7792d67949ef5abe3de8a8832beda Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 5 Apr 2019 12:49:53 +0200 Subject: [vm] Backport from OCaml Backport https://github.com/ocaml/ocaml/commit/71b94fa3e8d73c40e298409fa5fd6501383d38a6 and https://github.com/ocaml/ocaml/commit/d3e86fdfcc8f40a99380303f16f9b782233e047e from OCaml VM --- kernel/byterun/coq_interp.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a8fd2fbe47..da152599ce 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -104,7 +104,8 @@ if (sp - num_args < coq_stack_threshold) { \ several architectures. */ -#if defined(__GNUC__) && !defined(DEBUG) +#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) \ + && !defined(__llvm__) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") -- cgit v1.2.3 From 7fbb53b1649627b3f765fc9516becd3cd1674464 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 29 Apr 2019 20:05:58 +0200 Subject: Mini-test. --- test-suite/success/change.v | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test-suite/success/change.v b/test-suite/success/change.v index a9821b027f..5a8f735151 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -68,3 +68,11 @@ eassumption. match goal with |- ?x=1 => change (x=1) with (0+x=1) end. match goal with |- 0+1=1 => trivial end. Qed. + +(* Mini-check that no_check does not check *) + +Goal False. +change_no_check True. +exact I. +Fail Qed. +Abort. -- cgit v1.2.3 From 29955b2b6e5eb46adc71425956a5c940522fb30d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 29 Apr 2019 20:16:51 +0200 Subject: Deprecating convert_concl_no_check. --- plugins/ltac/g_auto.mlg | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index ec5e46d89b..e59076bd63 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -182,9 +182,18 @@ TACTIC EXTEND unify } END +{ +let deprecated_convert_concl_no_check = + CWarnings.create + ~name:"convert_concl_no_check" ~category:"deprecated" + (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") +} TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl ~check:false x DEFAULTcast } +| ["convert_concl_no_check" constr(x) ] -> { + deprecated_convert_concl_no_check (); + Tactics.convert_concl ~check:false x DEFAULTcast + } END { -- cgit v1.2.3 From a63ac0351d6feb3f3242649faccf88da6a34d5eb Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:15:59 +0200 Subject: Fix a nanoPG bug: was accepting unexpectedly extra modifier keys pressed. For instance, Ctrl-Meta-e was behaving like Ctrl-e. --- ide/nanoPG.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index d85d87142c..de386e4ccf 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -67,7 +67,10 @@ type 'c entry = { let mC = [`CONTROL] let mM = [`MOD1] -let mod_of t x = List.for_all (fun m -> List.mem m (GdkEvent.Key.state t)) x +let mod_of t x = + let y = GdkEvent.Key.state t in + List.for_all (fun m -> List.mem m y) x && + List.for_all (fun m -> List.mem m x) y let pr_keymod l = if l = mC then "C-" -- cgit v1.2.3 From 714d745858b031e58c5d089799d017eb092543c0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:43:35 +0200 Subject: NanoPG: expanding the notation C- and M- to Ctrl- and Meta-. Not only will this be clearer but it prepares to describing action on MacOS which shall use Cmd and which cannot be abbreviated w/o introducing a confusion with the abbreviation C- of Control-. --- ide/nanoPG.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index de386e4ccf..89bf07ce23 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -73,8 +73,8 @@ let mod_of t x = List.for_all (fun m -> List.mem m x) y let pr_keymod l = - if l = mC then "C-" - else if l = mM then "M-" + if l = mC then "Ctrl-" + else if l = mM then "Meta-" else "" let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents = -- cgit v1.2.3 From dda4e65e530bd0e4a3ada165fdc752e1a217da8b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:18:17 +0200 Subject: CoqIDE: Adding MacOS X support for Meta-based nano-PG keys. In practice, most of Alt modified keys are used on MacOS X keyboards for special characters and many Command modified keys are used for MacOS standard actions. So, we propose to use Ctrl-Command- as a prefix for the Meta-based nano-PG shortcuts. E.g. Ctrl-Command-e would go the end of the sentence. --- ide/nanoPG.ml | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 89bf07ce23..0cb39c8d75 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -65,7 +65,13 @@ type 'c entry = { } let mC = [`CONTROL] -let mM = [`MOD1] +let mM = + if Coq_config.arch = "Darwin" then + (* We add both MOD2 and META because both are + returned when pressing Command on MacOS X *) + [`CONTROL;`MOD2;`META] + else + [`MOD1] let mod_of t x = let y = GdkEvent.Key.state t in @@ -73,9 +79,13 @@ let mod_of t x = List.for_all (fun m -> List.mem m x) y let pr_keymod l = - if l = mC then "Ctrl-" - else if l = mM then "Meta-" - else "" + if l = mC then + "Ctrl-" + else + if l = mM then + if Coq_config.arch = "Darwin" then "Ctrl-Cmd-" else "Meta-" + else + "" let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents = List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents }) -- cgit v1.2.3 From 523fc765d1363767ffb6970781767dfcdca6892c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:29:38 +0200 Subject: Cosmetic in nanoPG.ml: fixing a wrong indentation. --- ide/nanoPG.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 0cb39c8d75..70f2a71db2 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -299,9 +299,9 @@ let find gui (Step(here,konts)) t = else if k = _c && mod_of t mC && sel_nonempty () then ignore(run t gui (Action("Edit","Copy")) empty); - let cmp { key; mods } = key = k && mod_of t mods in - try `Do (List.find cmp here) with Not_found -> - try `Cont (List.find cmp konts).contents with Not_found -> `NotFound + let cmp { key; mods } = key = k && mod_of t mods in + try `Do (List.find cmp here) with Not_found -> + try `Cont (List.find cmp konts).contents with Not_found -> `NotFound let init w nb ags = let gui = { notebook = nb; action_groups = ags } in -- cgit v1.2.3 From d42c059d6c7877948fdae76bf0400d4e3b06b90d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:29:49 +0200 Subject: NanoPG doc: telling that char, word, sentence, line have their unicode meaning. More precisely, GTK+ uses Pango rules which follows the standard Unicode text segmentation rules (see http://www.unicode.org/reports/tr29/). --- ide/nanoPG.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 70f2a71db2..435076c332 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -333,4 +333,6 @@ let init w nb ags = -let get_documentation () = print_keypaths pg +let get_documentation () = + "Chars, words, lines and sentences below pertain to standard unicode segmentation rules\n" ^ + print_keypaths pg -- cgit v1.2.3 From bae9b53c58d995a0cce404c279c37206e5418d2f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:38:05 +0200 Subject: CoqIDE nanoPG: adding keys to go the start/end of file (w/o evaluating). On MacOS X: Ctrl-Cmd-Left and Ctrl-Cmd-Right Elsewhere: Meta-Left and Meta-Right See issue #9899 (moving cursor to beginning and end of file). --- ide/nanoPG.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 435076c332..5e6c0b8462 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -160,6 +160,13 @@ let emacs = insert emacs "Emacs" [] [ mkE _e "e" "Move to end of line" (Motion(fun s i -> (if not i#ends_line then i#forward_to_line_end else i), { s with move = None })); + mkE ~mods:mM _Right "->" "Move to end of buffer" (Motion(fun s i -> + i#forward_to_end, + { s with move = None })); + mkE ~mods:mM _Left "<-" "Move to start of buffer" (Motion(fun s i -> + let buffer = new GText.buffer i#buffer in + buffer#start_iter, + { s with move = None })); mkE _a "a" "Move to beginning of line" (Motion(fun s i -> (i#set_line_offset 0), { s with move = None })); mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i -> -- cgit v1.2.3 From 7d3e6fefd7dab20c433fb7ae1baec5fa3ff2f0d7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 12:56:30 +0200 Subject: CoqIDE: updating documentation of the Preference windows. In particular, we explicitly mention the existence of an Emacs mode. --- doc/sphinx/practical-tools/coqide.rst | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 97d86943fb..d3d75dddd8 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -181,7 +181,14 @@ presented as a notebook. The first section is for selecting the text font used for scripts, goal and message windows. -The second section is devoted to file management: you may configure +The second and third sections are for controlling colors and style. + +The fourth section is for customizing the editor. It includes in +particular the ability to activate an Emacs mode named +micro-Proof-General (use the Help menu to know more about the +available bindings). + +The next section is devoted to file management: you may configure automatic saving of files, by periodically saving the contents into files named `#f#` for each opened file `f`. You may also activate the *revert* feature: in case a opened file is modified on the disk by a -- cgit v1.2.3 From 5610158cf3e256888184d44ae7e09bf626fd6102 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 10 Apr 2019 01:31:21 -0300 Subject: Credits for 8.10 --- CHANGES.md | 1 + doc/sphinx/changes.rst | 447 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 448 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 51583639ca..5a91bc2428 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -113,6 +113,7 @@ Plugins Tactics - Removed the deprecated `romega` tactics. + - Tactic names are no longer allowed to clash, even if they are not defined in the same section. For example, the following is no longer accepted: `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 57b9e45342..10cbbcfcaa 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -2,6 +2,453 @@ Recent changes -------------- +Version 8.10 +------------ + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +|Coq| version 8.10 contains two major new features: support for a native +fixed-precision integer type and a new sort `SProp` of strict +propositions. It is also the result of refinements and stabilization of +previous features, deprecations or removals of deprecated features, +cleanups of the internals of the system and API. This release includes +many user-visible changes, including deprecations that are documented in +the following section, and new features that are documented in the +reference manual. Here are the most important user-visible changes: + +- Kernel: + + - A notion of primitive object was added to the calculus. Its first + instance is primitive cyclic unsigned integers, axiomatized in + module UInt63(link), by Maxime Dénès, Benjamin Grégoire and Vincent + Laporte. See Section :ref:`primitive-integers`. + + - The :math:`\SProp` sort of definitionally proof-irrelevant propositions was + introduced by Gaëtan Gilbert. :math:`\SProp` allows to mark proof + terms as irrelevant for conversion, and is treated like `Prop` + during extraction. It is enabled using the `-allow-sprop` + command-line flag. See Section :ref:`sprop`. + + - The unfolding heuristic in termination checking was made more complete + by Enrico Tassi, allowing more constants to be unfolded to discover + valid recursive calls. + +- Universes: + + - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes` and + private universes for opaque polymorphic constants, by Gaëtan Gilbert. + +- Notations: + + - New command :cmd:`String Notation` to register string syntax for custom + inductive types, by Jason Gross. + + - Numeral Notations now parse decimal constants, by Pierre Roux. + +- Ltac: + + - Ltac backtraces can be turned on using the :opt:`Ltac Backtrace` option, + by Pierre-Marie Pédrot. + + +- The tactics :tac:`lia`, :tac:`nia`, :tac:`lra`, :tac:`nra` are now using a novel + Simplex-based proof engine, by Fréderic Besson. + +- SSReflect has new intro patterns and a consistent clear discipline, by + Enrico Tassi. + +- :cmd:`Combined Scheme` now works when inductive schemes are generated in sort + `Type`, by Théo Winterhalter. + +- A new registration mechanism for reference from ML code to Coq + constructs has been added, by Emilio Jesús Gallego Arias. + +- CoqIDE: + + - Migrated to gtk+3 and lablgtk3 by Hugo Herbelin and Jacques Garrigue. + + - Supports smart input for Unicode characters by Arthur Charguéraud. + +- Infrastructure: + + - Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the + `INSTALL` file for more information on dependencies. + + - Coq now supports building with Dune, in addition to the traditional + Makefile which is scheduled for deprecation, by Emilio Jesús Gallego + Arias and Rudi Grinberg. Experimental support for building Coq + projects has been integrated in Dune at the same time, providing an + [improved + experience](`https://coq.discourse.group/t/a-guide-to-building-your-coq-libraries-and-plugins-with-dune/` + for plugin developers. We thank the Dune team for their work + supporting Coq. + + +Version 8.10 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system, including +many additions to the standard library (see the next subsection for details). + +On the implementation side, the ``dev/doc/changes.md`` file documents +the numerous changes to the implementation and improvements of +interfaces. The file provides guidelines on porting a plugin to the new +version and a plugin development tutorial originally made by Yves Bertot +is now in `doc/plugin_tutorial`. The ``dev/doc/critical-bugs`` file +documents the known critical bugs of |Coq| and affected releases. + +The efficiency of the whole system has seen improvements thanks to +contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop, Théo Zimmermann worked on maintaining and improving the +continuous integration system and package building infrastructure. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) +with contributions from many users. A list of packages is available at +https://coq.inria.fr/opam/www/. + +The 61 contributors to this version are David A. Dalrymple, Tanaka +Akira, Benjamin Barenblat, Yves Bertot, Frédéric Besson, Lasse +Blaauwbroek, Martin Bodin, Joachim Breitner, Tej Chajed, Frédéric +Chapoton, Arthur Charguéraud, Cyril Cohen, Lukasz Czajka, Christian +Doczkal, Maxime Dénès, Andres Erbsen, Jim Fehrle, Gaëtan Gilbert, Matěj +Grabovský, Simon Gregersen, Jason Gross, Samuel Gruetter, Hugo Herbelin, +Jasper Hugunin, Mirai Ikebuchi, Emilio Jesus Gallego Arias, Chantal +Keller, Matej Košík, Vincent Laporte, Olivier Laurent, Larry Darryl Lee +Jr, Pierre Letouzey, Nick Lewycky, Yao Li, Yishuai Li, Xia Li-yao, Assia +Mahboubi, Simon Marechal, Erik Martin-Dorel, Thierry Martinez, Guillaume +Melquiond, Kayla Ngan, Sam Pablo Kuper, Karl Palmskog, Clément +Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, Kazuhiko Sakaguchi, Ryan +Scott, Vincent Semeria, Gan Shen, Michael Soegtrop, Matthieu Sozeau, +Enrico Tassi, Laurent Théry, Kamil Trzciński, whitequark, Théo +Winterhalter, Beta Ziliani and Théo Zimmermann. + +Many power users helped to improve the design of the new features via +the issue and pull request system, the |Coq| development mailing list, +the coq-club@inria.fr mailing list or the new Discourse forum. It would +be impossible to mention exhaustively the names of everybody who to some +extent influenced the development. + +Version 8.10 is the fifth release of |Coq| developed on a time-based +development cycle. Its development spanned 6 months from the release of +|Coq| 8.9. Vincent Laport is the release manager and maintainer of this +release. This release is the result of ??? commits and ??? PRs +merged, closing ??? issues. + +| Santiago de Chile, April 2019, +| Matthieu Sozeau for the |Coq| development team +| + +Details of changes +~~~~~~~~~~~~~~~~~~ + +OCaml and dependencies + +- Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a + fork of the core parsing library that Coq uses, which is a small + subset of the whole Camlp5 distribution. In particular, this subset + doesn't depend on the OCaml AST, allowing easier compilation and + testing on experimental OCaml versions. + + The Coq developers would like to thank Daniel de Rauglaudre for many + years of continued support. + +Coqide + +- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. + +- CoqIDE now properly sets the module name for a given file based on + its path, see `-topfile` change entry for more details. + +Coqtop + +- the use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use. (@ejgallego #9095) + +- new option -topfile filename, which will set the current module name + (à la -top) based on the filename passed, taking into account the + proper -R/-Q options. For example, given -R Foo foolib using + -topfile foolib/bar.v will set the module name to Foo.Bar. + +Specification language, type inference + +- Fixing a missing check in interpreting instances of existential + variables that are bound to local definitions might exceptionally + induce an overhead if the cost of checking the conversion of the + corresponding definitions is additionally high (PR #8215). + +- A few improvements in inference of the return clause of `match` can + exceptionally introduce incompatibilities (PR #262). This can be + solved by writing an explicit `return` clause, sometimes even simply + an explicit `return _` clause. + +- Using non-projection values with the projection syntax is not + allowed. For instance "0.(S)" is not a valid way to write "S 0". + Projections from non-primitive (emulated) records are allowed with + warning "nonprimitive-projection-syntax". + +Kernel + +- Added primitive integers + +- Unfolding heuristic in termination checking made more complete. + In particular Coq is now more aggressive in unfolding constants + when it looks for a iota redex. Performance regression may occur + in Fixpoint declarations without an explicit {struct} annotation, + since guessing the decreasing argument can now be more expensive. + (PR #9602) + +Notations + +- New command `Declare Scope` to explicitly declare a scope name + before any use of it. Implicit declaration of a scope at the time of + `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is + deprecated. + +- New command `String Notation` to register string syntax for custom + inductive types. + +- Numeral notations now parse decimal constants such as 1.02e+01 or + 10.2. Parsers added for Q and R. This should be considered as an + experimental feature currently. + Note: in -- the rare -- case when such numeral notations were used + in a development along with Q or R, they may have to be removed or + deconflicted through explicit scope annotations (1.23%Q, + 45.6%R,...). + +- Various bugs have been fixed (e.g. PR #9214 on removing spurious + parentheses on abbreviations shortening a strict prefix of an application). + +- Numeral Notations now support inductive types in the input to + printing functions (e.g., numeral notations can be defined for terms + containing things like `@cons nat O O`), and parsing functions now + fully normalize terms including parameters of constructors (so that, + e.g., a numeral notation whose parsing function outputs a proof of + `Nat.gcd x y = 1` will no longer fail to parse due to containing the + constant `Nat.gcd` in the parameter-argument of `eq_refl`). See + #9840 for more details. + +- Deprecated compatibility notations have actually been removed. Uses + of these notations are generally easy to fix thanks to the hint + contained in the deprecation warnings. For projects that require + more than a handful of such fixes, there is [a + script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) + that will do it automatically, using the output of coqc. The script + contains documentation on its usage in a comment at the top. + +Plugins + +- The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) + was removed. If some users are interested in maintaining this plugin + externally, the Coq development team can provide assistance for extracting + the plugin and setting up a new repository. + +Tactics + +- Removed the deprecated `romega` tactics. +- Tactic names are no longer allowed to clash, even if they are not defined in + the same section. For example, the following is no longer accepted: + `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` + +- The tactics 'lia','nia','lra','nra' are now using a novel + Simplex-based proof engine. In case of regression, 'Unset Simplex' + to get the venerable Fourier-based engine. + +- Names of existential variables occurring in Ltac functions + (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted + the same way as other variable names occurring in Ltac functions. + +- Hint declaration and removal should now specify a database (e.g. `Hint Resolve + foo : database`). When the database name is omitted, the hint is added to the + core database (as previously), but a deprecation warning is emitted. + +- There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms. + +- Ltac backtraces can be turned on using the "Ltac Backtrace" option. + +- The syntax of the `autoapply` tactic was fixed to conform with preexisting + documentation: it now takes a `with` clause instead of a `using` clause. + + + +Vernacular commands + +- `Combined Scheme` can now work when inductive schemes are generated in sort + `Type`. It used to be limited to sort `Prop`. + +- Binders for an `Instance` now act more like binders for a `Theorem`. + Names may not be repeated, and may not overlap with section variable names. + +- Removed the deprecated `Implicit Tactic` family of commands. + +- The `Automatic Introduction` option has been removed and is now the + default. + +- `Arguments` now accepts names for arguments provided with `extra_scopes`. + +- The naming scheme for anonymous binders in a `Theorem` has changed to + avoid conflicts with explicitly named binders. + +- Computation of implicit arguments now properly handles local definitions in the + binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. + +- `Declare Instance` now requires an instance name. + +- Option `Refine Instance Mode` has been turned off by default, meaning that + `Instance` no longer opens a proof when a body is provided. + +- `Instance`, when no body is provided, now always opens a proof. This is a + breaking change, as instance of `Instance foo : C.` where `C` is a trivial + class will have to be changed into `Instance foo : C := {}.` or + `Instance foo : C. Proof. Qed.`. + +- Option `Program Mode` now means that the `Program` attribute is enabled + for all commands that support it. In particular, it does not have any effect + on tactics anymore. May cause some incompatibilities. + +- The algorithm computing implicit arguments now behaves uniformly for primitive + projection and application nodes (bug #9508). + +- `Hypotheses` and `Variables` can now take implicit binders inside sections. + +- Removed deprecated option `Automatic Coercions Import`. + +- The `Show Script` command has been deprecated. + +- Option `Refine Instance Mode` has been deprecated and will be removed in + the next version. + +- `Coercion` does not warn ambiguous paths which are obviously convertible with + existing ones. + +- A new flag `Fast Name Printing` has been introduced. It changes the + algorithm used for allocating bound variable names for a faster but less + clever one. + +Tools + +- The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: + - `no` disables native_compute + - `yes` enables native_compute and precompiles `.v` files to native code + - `ondemand` enables native_compute but compiles code only when `native_compute` is called + + The default value is `ondemand`. + + Note that this flag now has priority over the configure flag of the same name. + +- A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether + conversion can use the VM. The default value is `yes`. + +- CoqIDE now supports input for Unicode characters. For example, typing + "\alpha" then the "Shift+Space" will insert the greek letter alpha. + In fact, typing the prefix string "\a" is sufficient. + A larger number of default bindings are provided, following the latex + naming convention. Bindings can be customized, either globally, or on a + per-project basis, with the requirement is that keys must begin with a + backslash and contain no space character. Bindings may be assigned custom + priorities, so that prefixes resolve to the most convenient bindings. + The documentation pages for CoqIDE provides further details. + +- The pretty timing diff scripts (flag `TIMING=1` to a + `coq_makefile`-made `Makefile`, also + `tools/make-both-single-timing-files.py`, + `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) + now correctly support non-UTF-8 characters in the output of + `coqc`/`make` as well as printing to stdout, on both python2 and + python3. + +Standard Library + +- Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about + the upper bound of number represented by a vector. + Allowed implicit vector length argument in `Ndigits.Bv2N`. + +- Added `Bvector.BVeq` that decides whether two `Bvector`s are equal. + +- Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. + +- Added `ByteVector` type that can convert to and from [string]. + +- The prelude used to be automatically Exported and is now only + Imported. This should be relevant only when importing files which + don't use -noinit into files which do. + +- Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an + ordered type (using lexical order). + +- The `Coq.Numbers.Cyclic.Int31` library is deprecated. + +- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. + +- Moved the `auto` hints of the `FSet` library into a new + `fset` database. + +Universes + +- Added `Print Universes Subgraph` variant of `Print Universes`. + Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` + +- Added private universes for opaque polymorphic constants, see doc + for the "Private Polymorphic Universes" option (and Unset it to get + the previous behaviour). + +SProp + +- Added a universe "SProp" for definitionally proof irrelevant + propositions. Use with -allow-sprop. See manual for details. + +Inductives + +- An option and attributes to control the automatic decision to declare + an inductive type as template polymorphic were added. Warning + "auto-template" (off by default) can trigger when an inductive is + automatically declared template polymorphic without the attribute. + +Funind + +- Inductive types declared by Funind will never be template polymorphic. + +Misc + +- Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. + +- Removed option "Printing Primitive Projection Compatibility" + +SSReflect + +- New intro patterns: + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` + See the reference manual for the actual documentation. + +- Clear discipline made consistent across the entire proof language. + Whenever a clear switch `{x..}` comes immediately before an existing proof + context entry (used as a view, as a rewrite rule or as name for a new + context entry) then such entry is cleared too. + + E.g. The following sentences are elaborated as follows (when H is an existing + proof context entry): + - `=> {x..} H` -> `=> {x..H} H` + - `=> {x..} /H` -> `=> /v {x..H}` + - `rewrite {x..} H` -> `rewrite E {x..H}` + +Diffs + +- Some error messages that show problems with a pair of non-matching values will now + highlight the differences. + Version 8.9 ----------- -- cgit v1.2.3 From fd864160d128836abf34f07eacc1e085e3f774b0 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 17 Apr 2019 08:03:26 -0400 Subject: Apply suggestions from code review Mainly markup fixes by Theo Co-Authored-By: mattam82 --- doc/sphinx/changes.rst | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 10cbbcfcaa..7f68d1a25d 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -132,7 +132,7 @@ extent influenced the development. Version 8.10 is the fifth release of |Coq| developed on a time-based development cycle. Its development spanned 6 months from the release of -|Coq| 8.9. Vincent Laport is the release manager and maintainer of this +|Coq| 8.9. Vincent Laporte is the release manager and maintainer of this release. This release is the result of ??? commits and ??? PRs merged, closing ??? issues. @@ -166,7 +166,7 @@ Coqtop - the use of `coqtop` as a compiler has been deprecated, in favor of `coqc`. Consequently option `-compile` will stop to be accepted in the next release. `coqtop` is now reserved to interactive - use. (@ejgallego #9095) + use. Change by Emilio Gallego Arías. - new option -topfile filename, which will set the current module name (à la -top) based on the filename passed, taking into account the @@ -186,7 +186,7 @@ Specification language, type inference an explicit `return _` clause. - Using non-projection values with the projection syntax is not - allowed. For instance "0.(S)" is not a valid way to write "S 0". + allowed. For instance :g:`0.(S)` is not a valid way to write :g:`S 0`. Projections from non-primitive (emulated) records are allowed with warning "nonprimitive-projection-syntax". @@ -203,9 +203,9 @@ Kernel Notations -- New command `Declare Scope` to explicitly declare a scope name +- New command :cmd:`Declare Scope` to explicitly declare a scope name before any use of it. Implicit declaration of a scope at the time of - `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is + :cmd:`Bind Scope`, :cmd:`Delimit Scope`, :cmd:`Undelimit Scope`, or :cmd:`Notation` is deprecated. - New command `String Notation` to register string syntax for custom @@ -233,7 +233,7 @@ Notations - Deprecated compatibility notations have actually been removed. Uses of these notations are generally easy to fix thanks to the hint - contained in the deprecation warnings. For projects that require + contained in the deprecation warning emitted by the previous version of Coq. For projects that require more than a handful of such fixes, there is [a script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) that will do it automatically, using the output of coqc. The script @@ -263,7 +263,7 @@ Tactics - Hint declaration and removal should now specify a database (e.g. `Hint Resolve foo : database`). When the database name is omitted, the hint is added to the - core database (as previously), but a deprecation warning is emitted. + `core` database (as previously), but a deprecation warning is emitted. - There are now tactics in `PreOmega.v` called `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and @@ -275,7 +275,7 @@ Tactics - Ltac backtraces can be turned on using the "Ltac Backtrace" option. -- The syntax of the `autoapply` tactic was fixed to conform with preexisting +- The syntax of the :tacn:`autoapply` tactic was fixed to conform with preexisting documentation: it now takes a `with` clause instead of a `using` clause. @@ -285,7 +285,7 @@ Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort `Type`. It used to be limited to sort `Prop`. -- Binders for an `Instance` now act more like binders for a `Theorem`. +- Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. Names may not be repeated, and may not overlap with section variable names. - Removed the deprecated `Implicit Tactic` family of commands. @@ -301,9 +301,9 @@ Vernacular commands - Computation of implicit arguments now properly handles local definitions in the binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. -- `Declare Instance` now requires an instance name. +- :cmd:`Declare Instance` now requires an instance name. -- Option `Refine Instance Mode` has been turned off by default, meaning that +- Option :opt:`Refine Instance Mode` has been turned off by default, meaning that `Instance` no longer opens a proof when a body is provided. - `Instance`, when no body is provided, now always opens a proof. This is a @@ -311,7 +311,7 @@ Vernacular commands class will have to be changed into `Instance foo : C := {}.` or `Instance foo : C. Proof. Qed.`. -- Option `Program Mode` now means that the `Program` attribute is enabled +- Option :opt:`Program Mode` now means that the `Program` attribute is enabled for all commands that support it. In particular, it does not have any effect on tactics anymore. May cause some incompatibilities. @@ -327,10 +327,10 @@ Vernacular commands - Option `Refine Instance Mode` has been deprecated and will be removed in the next version. -- `Coercion` does not warn ambiguous paths which are obviously convertible with +- :cmd:`Coercion` does not warn ambiguous paths which are obviously convertible with existing ones. -- A new flag `Fast Name Printing` has been introduced. It changes the +- A new flag :opt:`Fast Name Printing` has been introduced. It changes the algorithm used for allocating bound variable names for a faster but less clever one. @@ -380,7 +380,7 @@ Standard Library - The prelude used to be automatically Exported and is now only Imported. This should be relevant only when importing files which - don't use -noinit into files which do. + don't use `-noinit` into files which do. - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an ordered type (using lexical order). @@ -398,7 +398,7 @@ Universes Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` - Added private universes for opaque polymorphic constants, see doc - for the "Private Polymorphic Universes" option (and Unset it to get + for the :opt"`Private Polymorphic Universes` option (and Unset it to get the previous behaviour). SProp @@ -419,9 +419,9 @@ Funind Misc -- Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. +- Option :opt`Typeclasses Axioms Are Instances` (compatibility option introduced in the previous version) is deprecated. Use :cmd:`Declare Instance` for axioms which should be instances. -- Removed option "Printing Primitive Projection Compatibility" +- Removed option `Printing Primitive Projection Compatibility` SSReflect -- cgit v1.2.3 From 61c780ad8138bfa768977d652c25741dad35d448 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 18 Apr 2019 14:26:39 +0200 Subject: First fixing pass, and experiment with dune-style PR number and author listing. --- doc/sphinx/addendum/sprop.rst | 8 +-- doc/sphinx/changes.rst | 111 +++++++++++++++++------------ doc/sphinx/language/gallina-extensions.rst | 1 + 3 files changed, 72 insertions(+), 48 deletions(-) diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index c0c8c2d79c..8935ba27e3 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -10,9 +10,9 @@ SProp (proof irrelevant propositions) This section describes the extension of |Coq| with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also known as strict propositions). To use :math:`\SProp` you must pass -``-allow-sprop`` to the |Coq| program or use :opt:`Allow StrictProp`. +``-allow-sprop`` to the |Coq| program or use :flag:`Allow StrictProp`. -.. opt:: Allow StrictProp +.. flag:: Allow StrictProp :name: Allow StrictProp Allows using :math:`\SProp` when set and forbids it when unset. The @@ -201,10 +201,10 @@ This means that some errors will be delayed until ``Qed``: Abort. -.. opt:: Elaboration StrictProp Cumulativity +.. flag:: Elaboration StrictProp Cumulativity :name: Elaboration StrictProp Cumulativity - Unset this option (it's on by default) to be strict with regard to + Unset this flag (it is on by default) to be strict with regard to :math:`\SProp` cumulativity during elaboration. The implementation of proof irrelevance uses inferred "relevance" diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 7f68d1a25d..4797363063 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -9,82 +9,104 @@ Summary of changes ~~~~~~~~~~~~~~~~~~ |Coq| version 8.10 contains two major new features: support for a native -fixed-precision integer type and a new sort `SProp` of strict +fixed-precision integer type and a new sort :math:`\SProp` of strict propositions. It is also the result of refinements and stabilization of previous features, deprecations or removals of deprecated features, cleanups of the internals of the system and API. This release includes many user-visible changes, including deprecations that are documented in -the following section, and new features that are documented in the +the next section, and new features that are documented in the reference manual. Here are the most important user-visible changes: - Kernel: - A notion of primitive object was added to the calculus. Its first instance is primitive cyclic unsigned integers, axiomatized in - module UInt63(link), by Maxime Dénès, Benjamin Grégoire and Vincent - Laporte. See Section :ref:`primitive-integers`. + module :g:`UInt63`. See Section :ref:`primitive-integers` + (`#6914 `_, by Maxime Dénès, + Benjamin Grégoire and Vincent Laporte). - The :math:`\SProp` sort of definitionally proof-irrelevant propositions was - introduced by Gaëtan Gilbert. :math:`\SProp` allows to mark proof - terms as irrelevant for conversion, and is treated like `Prop` + introduced. :math:`\SProp` allows to mark proof + terms as irrelevant for conversion, and is treated like :math:`\Prop` during extraction. It is enabled using the `-allow-sprop` - command-line flag. See Section :ref:`sprop`. + command-line flag or the :flag:`Allow StrictProp` flag. + See Chapter :ref:`sprop` + (`#8817 `_, by Gaëtan Gilbert). - - The unfolding heuristic in termination checking was made more complete - by Enrico Tassi, allowing more constants to be unfolded to discover - valid recursive calls. + - The unfolding heuristic in termination checking was made more + complete, allowing more constants to be unfolded to discover valid + recursive calls + (`#9602 `_, by Enrico Tassi). - Universes: - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes` and - private universes for opaque polymorphic constants, by Gaëtan Gilbert. + private universes for opaque polymorphic constants + (`#8451 `_, by Gaëtan Gilbert). - Notations: - New command :cmd:`String Notation` to register string syntax for custom - inductive types, by Jason Gross. + inductive types + (`#8965 `_, by Jason Gross). - - Numeral Notations now parse decimal constants, by Pierre Roux. + - Numeral Notations now parse decimal constants + (`#8764 `_, by Pierre Roux). - Ltac: - - Ltac backtraces can be turned on using the :opt:`Ltac Backtrace` option, - by Pierre-Marie Pédrot. + - Ltac backtraces can be turned on using the :flag:`Ltac Backtrace` + flag, which is off by default + (`#9142 `_, + fixes `#7769 `_ + and `#7385 `_, + by Pierre-Marie Pédrot). +- The tactics :tacn:`lia`, :tacn:`nia`, :tacn:`lra`, :tacn:`nra` are now using a novel + Simplex-based proof engine + (`#8457 `_, by Fréderic Besson). -- The tactics :tac:`lia`, :tac:`nia`, :tac:`lra`, :tac:`nra` are now using a novel - Simplex-based proof engine, by Fréderic Besson. - -- SSReflect has new intro patterns and a consistent clear discipline, by - Enrico Tassi. +- SSReflect has new intro patterns and a consistent clear discipline + (`#6705 `_ + and `#9341 `_, + by Enrico Tassi). - :cmd:`Combined Scheme` now works when inductive schemes are generated in sort - `Type`, by Théo Winterhalter. + :math:`\Type` + (`#7634 `_, by Théo Winterhalter). - A new registration mechanism for reference from ML code to Coq - constructs has been added, by Emilio Jesús Gallego Arias. + constructs has been added + (`#186 `_, + by Emilio Jesús Gallego Arias, Maxime Dénès and Vincent Laporte). - CoqIDE: - - Migrated to gtk+3 and lablgtk3 by Hugo Herbelin and Jacques Garrigue. + - Migrated to gtk+3 and lablgtk3 + (`#9279 `_, + by Hugo Herbelin, with help of Jacques Garrigue, + Emilio Jesús Gallego Arias, Michael Sogetrop and Vincent Laporte). - - Supports smart input for Unicode characters by Arthur Charguéraud. + - Supports smart input for Unicode characters + (`#8560 `_, by Arthur Charguéraud). - Infrastructure: - Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the - `INSTALL` file for more information on dependencies. + `INSTALL` file for more information on dependencies + (`#7522 `_, by Emilio Jesús Gallego Arías). - Coq now supports building with Dune, in addition to the traditional - Makefile which is scheduled for deprecation, by Emilio Jesús Gallego - Arias and Rudi Grinberg. Experimental support for building Coq - projects has been integrated in Dune at the same time, providing an - [improved - experience](`https://coq.discourse.group/t/a-guide-to-building-your-coq-libraries-and-plugins-with-dune/` + Makefile which is scheduled for deprecation + (`#6857 `_, + by Emilio Jesús Gallego Arias and Rudi Grinberg). + + Experimental support for building Coq projects has been integrated + in Dune at the same time, providing an `improved experience + `_ for plugin developers. We thank the Dune team for their work supporting Coq. - Version 8.10 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system, including many additions to the standard library (see the next subsection for details). @@ -140,8 +162,8 @@ merged, closing ??? issues. | Matthieu Sozeau for the |Coq| development team | -Details of changes -~~~~~~~~~~~~~~~~~~ +Details of changes in 8.10+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ OCaml and dependencies @@ -303,15 +325,16 @@ Vernacular commands - :cmd:`Declare Instance` now requires an instance name. -- Option :opt:`Refine Instance Mode` has been turned off by default, meaning that - `Instance` no longer opens a proof when a body is provided. +- The flag :flag:`Refine Instance Mode` has been turned off by default, meaning that + :cmd:`Instance` no longer opens a proof when a body is provided. -- `Instance`, when no body is provided, now always opens a proof. This is a - breaking change, as instance of `Instance foo : C.` where `C` is a trivial - class will have to be changed into `Instance foo : C := {}.` or - `Instance foo : C. Proof. Qed.`. +- Command :cmd:`Instance`, when no body is provided, now always opens + a proof. This is a breaking change, as instance of :n:`Instance + @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will + have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` + or :n:`Instance @ident__1 : @ident__2. Proof. Qed.`. -- Option :opt:`Program Mode` now means that the `Program` attribute is enabled +- The flag :flag:`Program Mode` now means that the `Program` attribute is enabled for all commands that support it. In particular, it does not have any effect on tactics anymore. May cause some incompatibilities. @@ -330,7 +353,7 @@ Vernacular commands - :cmd:`Coercion` does not warn ambiguous paths which are obviously convertible with existing ones. -- A new flag :opt:`Fast Name Printing` has been introduced. It changes the +- A new flag :flag:`Fast Name Printing` has been introduced. It changes the algorithm used for allocating bound variable names for a faster but less clever one. @@ -372,7 +395,7 @@ Standard Library the upper bound of number represented by a vector. Allowed implicit vector length argument in `Ndigits.Bv2N`. -- Added `Bvector.BVeq` that decides whether two `Bvector`s are equal. +- Added `Bvector.BVeq` that decides whether two `Bvector`\s are equal. - Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. @@ -599,8 +622,8 @@ engineer working with Maxime Dénès in the |Coq| consortium. | Matthieu Sozeau for the |Coq| development team | -Details of changes -~~~~~~~~~~~~~~~~~~ +Details of changes in 8.9+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Kernel diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 695dea222f..5308330820 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2244,6 +2244,7 @@ Printing universes unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. .. cmdv:: Print Universes Subgraph(@names) + :name: Print Universes Subgraph Prints the graph restricted to the requested names (adjusting constraints to preserve the implied transitive constraints between -- cgit v1.2.3 From bb4b9469ddf45d76385cdcddf27dc82266a8c73b Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 18 Apr 2019 15:10:06 +0200 Subject: Remove 8.10 entries from CHANGES file. --- CHANGES.md | 331 ++++--------------------------------------------- README.md | 9 +- doc/sphinx/changes.rst | 3 + 3 files changed, 33 insertions(+), 310 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 5a91bc2428..3c8070d585 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,341 +1,58 @@ Unreleased changes ================== -OCaml and dependencies + -- Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the - INSTALL file for more information on dependencies. +**Kernel** -- Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a - fork of the core parsing library that Coq uses, which is a small - subset of the whole Camlp5 distribution. In particular, this subset - doesn't depend on the OCaml AST, allowing easier compilation and - testing on experimental OCaml versions. - The Coq developers would like to thank Daniel de Rauglaudre for many - years of continued support. +**Specification language, type inference** -Coqide -- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. +**Notations** -- CoqIDE now properly sets the module name for a given file based on - its path, see -topfile change entry for more details. -- Preferences from coqide.keys are no longer overridden by modifiers - preferences in coqiderc. +**Tactics** -Coqtop -- the use of `coqtop` as a compiler has been deprecated, in favor of - `coqc`. Consequently option `-compile` will stop to be accepted in - the next release. `coqtop` is now reserved to interactive - use. (@ejgallego #9095) +**Tactic language** -- new option -topfile filename, which will set the current module name - (à la -top) based on the filename passed, taking into account the - proper -R/-Q options. For example, given -R Foo foolib using - -topfile foolib/bar.v will set the module name to Foo.Bar. - -Specification language, type inference -- Fixing a missing check in interpreting instances of existential - variables that are bound to local definitions might exceptionally - induce an overhead if the cost of checking the conversion of the - corresponding definitions is additionally high (PR #8215). +**SSReflect** -- A few improvements in inference of the return clause of `match` can - exceptionally introduce incompatibilities (PR #262). This can be - solved by writing an explicit `return` clause, sometimes even simply - an explicit `return _` clause. - -- Using non-projection values with the projection syntax is not - allowed. For instance "0.(S)" is not a valid way to write "S 0". - Projections from non-primitive (emulated) records are allowed with - warning "nonprimitive-projection-syntax". - -Kernel - -- Added primitive integers - -- Unfolding heuristic in termination checking made more complete. - In particular Coq is now more aggressive in unfolding constants - when it looks for a iota redex. Performance regression may occur - in Fixpoint declarations without an explicit {struct} annotation, - since guessing the decreasing argument can now be more expensive. - (PR #9602) - -Notations - -- New command `Declare Scope` to explicitly declare a scope name - before any use of it. Implicit declaration of a scope at the time of - `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is - deprecated. - -- New command `String Notation` to register string syntax for custom - inductive types. - -- Numeral notations now parse decimal constants such as 1.02e+01 or - 10.2. Parsers added for Q and R. This should be considered as an - experimental feature currently. - Note: in -- the rare -- case when such numeral notations were used - in a development along with Q or R, they may have to be removed or - deconflicted through explicit scope annotations (1.23%Q, - 45.6%R,...). - -- Various bugs have been fixed (e.g. PR #9214 on removing spurious - parentheses on abbreviations shortening a strict prefix of an application). - -- Numeral Notations now support inductive types in the input to - printing functions (e.g., numeral notations can be defined for terms - containing things like `@cons nat O O`), and parsing functions now - fully normalize terms including parameters of constructors (so that, - e.g., a numeral notation whose parsing function outputs a proof of - `Nat.gcd x y = 1` will no longer fail to parse due to containing the - constant `Nat.gcd` in the parameter-argument of `eq_refl`). See - #9840 for more details. - -- Deprecated compatibility notations have actually been removed. Uses - of these notations are generally easy to fix thanks to the hint - contained in the deprecation warnings. For projects that require - more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script - contains documentation on its usage in a comment at the top. - -Plugins - -- The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) - was removed. If some users are interested in maintaining this plugin - externally, the Coq development team can provide assistance for extracting - the plugin and setting up a new repository. - -Tactics - -- Removed the deprecated `romega` tactics. - -- Tactic names are no longer allowed to clash, even if they are not defined in - the same section. For example, the following is no longer accepted: - `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` - -- The tactics 'lia','nia','lra','nra' are now using a novel - Simplex-based proof engine. In case of regression, 'Unset Simplex' - to get the venerable Fourier-based engine. - -- Names of existential variables occurring in Ltac functions - (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted - the same way as other variable names occurring in Ltac functions. - -- Hint declaration and removal should now specify a database (e.g. `Hint Resolve - foo : database`). When the database name is omitted, the hint is added to the - core database (as previously), but a deprecation warning is emitted. - -- There are now tactics in `PreOmega.v` called - `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and - `Z.to_euclidean_division_equations` (which combines the `div_mod` - and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to - support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), - by posing the specifying equation for `Z.div` and `Z.modulo` before - replacing them with atoms. - -- Ltac backtraces can be turned on using the "Ltac Backtrace" option. - -- The syntax of the `autoapply` tactic was fixed to conform with preexisting - documentation: it now takes a `with` clause instead of a `using` clause. - - - -Vernacular commands - -- `Combined Scheme` can now work when inductive schemes are generated in sort - `Type`. It used to be limited to sort `Prop`. - -- Binders for an `Instance` now act more like binders for a `Theorem`. - Names may not be repeated, and may not overlap with section variable names. - -- Removed the deprecated `Implicit Tactic` family of commands. - -- The `Automatic Introduction` option has been removed and is now the - default. - -- `Arguments` now accepts names for arguments provided with `extra_scopes`. - -- The naming scheme for anonymous binders in a `Theorem` has changed to - avoid conflicts with explicitly named binders. - -- Computation of implicit arguments now properly handles local definitions in the - binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. - -- `Declare Instance` now requires an instance name. - -- Option `Refine Instance Mode` has been turned off by default, meaning that - `Instance` no longer opens a proof when a body is provided. - -- `Instance`, when no body is provided, now always opens a proof. This is a - breaking change, as instance of `Instance foo : C.` where `C` is a trivial - class will have to be changed into `Instance foo : C := {}.` or - `Instance foo : C. Proof. Qed.`. - -- Option `Program Mode` now means that the `Program` attribute is enabled - for all commands that support it. In particular, it does not have any effect - on tactics anymore. May cause some incompatibilities. - -- The algorithm computing implicit arguments now behaves uniformly for primitive - projection and application nodes (bug #9508). - -- `Hypotheses` and `Variables` can now take implicit binders inside sections. - -- Removed deprecated option `Automatic Coercions Import`. - -- The `Show Script` command has been deprecated. - -- Option `Refine Instance Mode` has been deprecated and will be removed in - the next version. - -- `Coercion` does not warn ambiguous paths which are obviously convertible with - existing ones. - -- A new flag `Fast Name Printing` has been introduced. It changes the - algorithm used for allocating bound variable names for a faster but less - clever one. - -Tools - -- The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: - - `no` disables native_compute - - `yes` enables native_compute and precompiles `.v` files to native code - - `ondemand` enables native_compute but compiles code only when `native_compute` is called - - The default value is `ondemand`. - - Note that this flag now has priority over the configure flag of the same name. - -- A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether - conversion can use the VM. The default value is `yes`. - -- CoqIDE now supports input for Unicode characters. For example, typing - "\alpha" then the "Shift+Space" will insert the greek letter alpha. - In fact, typing the prefix string "\a" is sufficient. - A larger number of default bindings are provided, following the latex - naming convention. Bindings can be customized, either globally, or on a - per-project basis, with the requirement is that keys must begin with a - backslash and contain no space character. Bindings may be assigned custom - priorities, so that prefixes resolve to the most convenient bindings. - The documentation pages for CoqIDE provides further details. - -- The pretty timing diff scripts (flag `TIMING=1` to a - `coq_makefile`-made `Makefile`, also - `tools/make-both-single-timing-files.py`, - `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) - now correctly support non-UTF-8 characters in the output of - `coqc`/`make` as well as printing to stdout, on both python2 and - python3. - -- Coq options can be set on the command line, eg `-set "Universe Polymorphism=true"` - -- coq_makefile's install target now errors if any file to install is missing. - -Standard Library - -- Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about - the upper bound of number represented by a vector. - Allowed implicit vector length argument in `Ndigits.Bv2N`. - -- Added `Bvector.BVeq` that decides whether two `Bvector`s are equal. - -- Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. - -- Added `ByteVector` type that can convert to and from [string]. - -- The prelude used to be automatically Exported and is now only - Imported. This should be relevant only when importing files which - don't use -noinit into files which do. - -- Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an - ordered type (using lexical order). - -- The `Coq.Numbers.Cyclic.Int31` library is deprecated. - -- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. - -- Moved the `auto` hints of the `FSet` library into a new - `fset` database. - -Universes - -- Added `Print Universes Subgraph` variant of `Print Universes`. - Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` - -- Added private universes for opaque polymorphic constants, see doc - for the "Private Polymorphic Universes" option (and Unset it to get - the previous behaviour). - -SProp - -- Added a universe "SProp" for definitionally proof irrelevant - propositions. Use with -allow-sprop. See manual for details. - -Inductives - -- An option and attributes to control the automatic decision to - declare an inductive type as template polymorphic were added. - Warning "auto-template" will trigger when an inductive is - automatically declared template polymorphic without the attribute. - -Funind +- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. -- Inductive types declared by Funind will never be template polymorphic. +- New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. -Misc +- `if c return t then ...` now expects `c` to be a variable bound in `t`. -- Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. +- New `nonPropType` interface matching types that do _not_ have sort `Prop`. -- Removed option "Printing Primitive Projection Compatibility" +- New `relpre R f` definition for the preimage of a relation R under f. -SSReflect -- New tactic `under` to rewrite under binders, given an extensionality lemma: - - interactive mode: `under lem`, associated terminator: `over` - - one-liner mode: `under lem do [tac1 | ...]` +**Commands and options** - It can take occurrence switches, contextual patterns, and intro patterns: - `under {2}[in RHS]eq_big => [i|i ?] do ...`. - See the reference manual for the actual documentation. +**Tools** -- New intro patterns: - - temporary introduction: `=> +` - - block introduction: `=> [^ prefix ] [^~ suffix ]` - - fast introduction: `=> >` - - tactics as views: `=> /ltac:mytac` - - replace hypothesis: `=> {}H` - See the reference manual for the actual documentation. +**CoqIDE** -- Clear discipline made consistent across the entire proof language. - Whenever a clear switch `{x..}` comes immediately before an existing proof - context entry (used as a view, as a rewrite rule or as name for a new - context entry) then such entry is cleared too. - E.g. The following sentences are elaborated as follows (when H is an existing - proof context entry): - - `=> {x..} H` -> `=> {x..H} H` - - `=> {x..} /H` -> `=> /v {x..H}` - - `rewrite {x..} H` -> `rewrite E {x..H}` +**Standard library** -- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. -- New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion - class, simplified `predType` interface: `pred_class` and `mkPredType` - deprecated, `{pred T}` and `PredType` should be used instead. +**Infrastructure and dependencies** -- `if c return t then ...` now expects `c` to be a variable bound in `t`. -- New `nonPropType` interface matching types that do _not_ have sort `Prop`. +**Miscellaneous** -- New `relpre R f` definition for the preimage of a relation R under f. -Diffs +Released changes +================ -- Some error messages that show problems with a pair of non-matching values will now - highlight the differences. +See . diff --git a/README.md b/README.md index ef80736e1a..54e12b09d4 100644 --- a/README.md +++ b/README.md @@ -69,9 +69,12 @@ for additional user-contributed documentation. ## Changes -There is a file named [`CHANGES.md`](CHANGES.md) that explains the differences and the -incompatibilities since last versions. If you upgrade Coq, please read -it carefully. +The [Recent +changes](https://coq.github.io/doc/master/refman/changes.html) chapter +of the reference manual explains the differences and the +incompatibilities of each new version of Coq. If you upgrade Coq, +please read it carefully as it contains important advice on how to +approach some problems you may encounter. ## Questions and discussion diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 4797363063..645be500fd 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -195,6 +195,9 @@ Coqtop proper -R/-Q options. For example, given -R Foo foolib using -topfile foolib/bar.v will set the module name to Foo.Bar. +- Experimental: Coq flags and options can now be set on the + command-line, e.g. `-set "Universe Polymorphism=true"`. + Specification language, type inference - Fixing a missing check in interpreting instances of existential -- cgit v1.2.3 From 890f206ebea4a14f5be8b273cee4ae8f99ca25e1 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Fri, 19 Apr 2019 18:52:26 +0200 Subject: Split changes between main changes and other changes (no repetition). Add more links to PRs and credits of authors. --- doc/sphinx/changes.rst | 568 +++++++++++------------ doc/sphinx/practical-tools/coqide.rst | 2 + doc/sphinx/user-extensions/syntax-extensions.rst | 2 + 3 files changed, 282 insertions(+), 290 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 645be500fd..d8ea9c1552 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -12,9 +12,9 @@ Summary of changes fixed-precision integer type and a new sort :math:`\SProp` of strict propositions. It is also the result of refinements and stabilization of previous features, deprecations or removals of deprecated features, -cleanups of the internals of the system and API. This release includes -many user-visible changes, including deprecations that are documented in -the next section, and new features that are documented in the +cleanups of the internals of the system and API, and many documentation improvements. +This release includes many user-visible changes, including deprecations that are +documented in the next subsection, and new features that are documented in the reference manual. Here are the most important user-visible changes: - Kernel: @@ -35,44 +35,63 @@ reference manual. Here are the most important user-visible changes: - The unfolding heuristic in termination checking was made more complete, allowing more constants to be unfolded to discover valid - recursive calls + recursive calls. Performance regression may occur in Fixpoint + declarations without an explicit ``{struct}`` annotation, since + guessing the decreasing argument can now be more expensive (`#9602 `_, by Enrico Tassi). - Universes: - - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes` and - private universes for opaque polymorphic constants + - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes`. + Try for instance + :g:`Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1).` (`#8451 `_, by Gaëtan Gilbert). + - Added private universes for opaque polymorphic constants, see the + documentation for the :flag:`Private Polymorphic Universes` flag, + and unset it to get the previous behaviour + (`#8850 `_, by Gaëtan Gilbert). + - Notations: - New command :cmd:`String Notation` to register string syntax for custom inductive types (`#8965 `_, by Jason Gross). - - Numeral Notations now parse decimal constants + - Experimental: :ref:`Numeral Notations ` now parse decimal + constants such as ``1.02e+01`` or ``10.2``. Parsers added for :g:`Q` and :g:`R`. + In the rare case when such numeral notations were used + in a development along with :g:`Q` or :g:`R`, they may have to be removed or + disambiguated through explicit scope annotations (`#8764 `_, by Pierre Roux). -- Ltac: - - - Ltac backtraces can be turned on using the :flag:`Ltac Backtrace` - flag, which is off by default - (`#9142 `_, - fixes `#7769 `_ - and `#7385 `_, - by Pierre-Marie Pédrot). +- Ltac backtraces can be turned on using the :flag:`Ltac Backtrace` + flag, which is off by default + (`#9142 `_, + fixes `#7769 `_ + and `#7385 `_, + by Pierre-Marie Pédrot). - The tactics :tacn:`lia`, :tacn:`nia`, :tacn:`lra`, :tacn:`nra` are now using a novel - Simplex-based proof engine + Simplex-based proof engine. In case of regression, unset :flag:`Simplex` + to get the venerable Fourier-based engine (`#8457 `_, by Fréderic Besson). -- SSReflect has new intro patterns and a consistent clear discipline - (`#6705 `_ - and `#9341 `_, - by Enrico Tassi). +- New SSReflect intro patterns: + + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` + + See Section :ref:`introduction_ssr` + (`#6705 `_, by Enrico Tassi, + with help from Maxime Dénès, + ideas coming from various users). - :cmd:`Combined Scheme` now works when inductive schemes are generated in sort - :math:`\Type` + :math:`\Type`. It used to be limited to sort `Prop` (`#7634 `_, by Théo Winterhalter). - A new registration mechanism for reference from ML code to Coq @@ -82,24 +101,44 @@ reference manual. Here are the most important user-visible changes: - CoqIDE: - - Migrated to gtk+3 and lablgtk3 + - CoqIDE now depends on gtk+3 and lablgtk3 instead of gtk+2 and lablgtk2 (`#9279 `_, - by Hugo Herbelin, with help of Jacques Garrigue, + by Hugo Herbelin, with help from Jacques Garrigue, Emilio Jesús Gallego Arias, Michael Sogetrop and Vincent Laporte). - - Supports smart input for Unicode characters + - Smart input for Unicode characters. For example, typing + ``\alpha`` then ``Shift+Space`` will insert the greek letter alpha. + A larger number of default bindings are provided, following the latex + naming convention. Bindings can be customized, either globally, or on a + per-project basis. See Section :ref:`coqide-unicode` for details (`#8560 `_, by Arthur Charguéraud). -- Infrastructure: +- Infrastructure and dependencies: - Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the `INSTALL` file for more information on dependencies (`#7522 `_, by Emilio Jesús Gallego Arías). + - Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a + fork of the core parsing library that Coq uses, which is a small + subset of the whole Camlp5 distribution. In particular, this subset + doesn't depend on the OCaml AST, allowing easier compilation and + testing on experimental OCaml versions. Coq also ships a new parser + `coqpp` that plugin authors must switch to + (`#7902 `_, + `#7979 `_, + `#8161 `_, + `#8667 `_, + and `#8945 `_, + by Pierre-Marie Pédrot and Emilio Jesús Gallego Arias). + + The Coq developers would like to thank Daniel de Rauglaudre for many + years of continued support. + - Coq now supports building with Dune, in addition to the traditional Makefile which is scheduled for deprecation (`#6857 `_, - by Emilio Jesús Gallego Arias and Rudi Grinberg). + by Emilio Jesús Gallego Arias, with help from Rudi Grinberg). Experimental support for building Coq projects has been integrated in Dune at the same time, providing an `improved experience @@ -162,318 +201,267 @@ merged, closing ??? issues. | Matthieu Sozeau for the |Coq| development team | -Details of changes in 8.10+beta1 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -OCaml and dependencies - -- Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a - fork of the core parsing library that Coq uses, which is a small - subset of the whole Camlp5 distribution. In particular, this subset - doesn't depend on the OCaml AST, allowing easier compilation and - testing on experimental OCaml versions. - - The Coq developers would like to thank Daniel de Rauglaudre for many - years of continued support. - -Coqide - -- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. - -- CoqIDE now properly sets the module name for a given file based on - its path, see `-topfile` change entry for more details. - -Coqtop - -- the use of `coqtop` as a compiler has been deprecated, in favor of - `coqc`. Consequently option `-compile` will stop to be accepted in - the next release. `coqtop` is now reserved to interactive - use. Change by Emilio Gallego Arías. - -- new option -topfile filename, which will set the current module name - (à la -top) based on the filename passed, taking into account the - proper -R/-Q options. For example, given -R Foo foolib using - -topfile foolib/bar.v will set the module name to Foo.Bar. - -- Experimental: Coq flags and options can now be set on the - command-line, e.g. `-set "Universe Polymorphism=true"`. - -Specification language, type inference - -- Fixing a missing check in interpreting instances of existential - variables that are bound to local definitions might exceptionally - induce an overhead if the cost of checking the conversion of the - corresponding definitions is additionally high (PR #8215). - -- A few improvements in inference of the return clause of `match` can - exceptionally introduce incompatibilities (PR #262). This can be - solved by writing an explicit `return` clause, sometimes even simply - an explicit `return _` clause. - -- Using non-projection values with the projection syntax is not - allowed. For instance :g:`0.(S)` is not a valid way to write :g:`S 0`. - Projections from non-primitive (emulated) records are allowed with - warning "nonprimitive-projection-syntax". - -Kernel - -- Added primitive integers +Other changes in 8.10+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Unfolding heuristic in termination checking made more complete. - In particular Coq is now more aggressive in unfolding constants - when it looks for a iota redex. Performance regression may occur - in Fixpoint declarations without an explicit {struct} annotation, - since guessing the decreasing argument can now be more expensive. - (PR #9602) +- Command-line tools and options: + + - The use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use + (`#9095 `_, + by Emilio Jesús Gallego Arias). + + - New option ``-topfile filename``, which will set the current module name + (*à la* ``-top``) based on the filename passed, taking into account the + proper ``-R``/``-Q`` options. For example, given ``-R Foo foolib`` using + ``-topfile foolib/bar.v`` will set the module name to ``Foo.Bar``. + CoqIDE now properly sets the module name for a given file based on + its path + (`#8991 `_, + closes `#8989 `_, + by Gaëtan Gilbert). + + - Experimental: Coq flags and options can now be set on the + command-line, e.g. ``-set "Universe Polymorphism=true"`` + (`#9876 `_, by Gaëtan Gilbert). + + - The `-native-compiler` flag of `coqc` and `coqtop` now takes an + argument which can have three values: + + - `no` disables native_compute + - `yes` enables native_compute and precompiles `.v` files to + native code + - `ondemand` enables native_compute but compiles code only when + `native_compute` is called + + The default value is `ondemand`. Note that this flag now has + priority over the configure flag of the same name. + + A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls + whether conversion can use the VM. The default value is `yes`. + + (`#8870 `_, by Maxime Dénès) + + - The pretty timing diff scripts (flag `TIMING=1` to a + `coq_makefile`\-made `Makefile`, also + `tools/make-both-single-timing-files.py`, + `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) + now correctly support non-UTF-8 characters in the output of + `coqc` / `make` as well as printing to stdout, on both python2 and + python3 + (`#9872 `_, + closes `#9767 `_ + and `#9705 `_, + by Jason Gross) + +- Specification language, type inference: + + - Fixing a missing check in interpreting instances of existential + variables that are bound to local definitions. Might exceptionally + induce an overhead if the cost of checking the conversion of the + corresponding definitions is additionally high + (`#8217 `_, + closes `#8215 `_, + by Hugo Herbelin). + + - A few improvements in inference of the return clause of `match` that + can exceptionally introduce incompatibilities. This can be + solved by writing an explicit `return` clause, sometimes even simply + an explicit `return _` clause + (`#262 `_, by Hugo Herbelin). + + - Using non-projection values with the projection syntax is not + allowed. For instance :g:`0.(S)` is not a valid way to write :g:`S 0`. + Projections from non-primitive (emulated) records are allowed with + warning "nonprimitive-projection-syntax" + (`#8829 `_, by Gaëtan Gilbert). + + - An option and attributes to control the automatic decision to declare + an inductive type as template polymorphic were added. Warning + "auto-template" (off by default) can trigger when an inductive is + automatically declared template polymorphic without the attribute. + + Inductive types declared by Funind will never be template polymorphic. + + (`#8488 `_, by Gaëtan Gilbert) -Notations - -- New command :cmd:`Declare Scope` to explicitly declare a scope name - before any use of it. Implicit declaration of a scope at the time of - :cmd:`Bind Scope`, :cmd:`Delimit Scope`, :cmd:`Undelimit Scope`, or :cmd:`Notation` is - deprecated. - -- New command `String Notation` to register string syntax for custom - inductive types. - -- Numeral notations now parse decimal constants such as 1.02e+01 or - 10.2. Parsers added for Q and R. This should be considered as an - experimental feature currently. - Note: in -- the rare -- case when such numeral notations were used - in a development along with Q or R, they may have to be removed or - deconflicted through explicit scope annotations (1.23%Q, - 45.6%R,...). - -- Various bugs have been fixed (e.g. PR #9214 on removing spurious - parentheses on abbreviations shortening a strict prefix of an application). - -- Numeral Notations now support inductive types in the input to - printing functions (e.g., numeral notations can be defined for terms - containing things like `@cons nat O O`), and parsing functions now - fully normalize terms including parameters of constructors (so that, - e.g., a numeral notation whose parsing function outputs a proof of - `Nat.gcd x y = 1` will no longer fail to parse due to containing the - constant `Nat.gcd` in the parameter-argument of `eq_refl`). See - #9840 for more details. - -- Deprecated compatibility notations have actually been removed. Uses - of these notations are generally easy to fix thanks to the hint - contained in the deprecation warning emitted by the previous version of Coq. For projects that require - more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script - contains documentation on its usage in a comment at the top. - -Plugins +- Notations: -- The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) + - New command :cmd:`Declare Scope` to explicitly declare a scope name + before any use of it. Implicit declaration of a scope at the time of + :cmd:`Bind Scope`, :cmd:`Delimit Scope`, :cmd:`Undelimit Scope`, + or :cmd:`Notation` is deprecated + (`#7135 `_, by Hugo Herbelin). + + - Various bugs have been fixed (e.g. `#9214 + `_ on removing spurious + parentheses on abbreviations shortening a strict prefix of an + application, by Hugo Herbelin). + + - :cmd:`Numeral Notation` now support inductive types in the input to + printing functions (e.g., numeral notations can be defined for terms + containing things like :g:`@cons nat O O`), and parsing functions now + fully normalize terms including parameters of constructors (so that, + e.g., a numeral notation whose parsing function outputs a proof of + :g:`Nat.gcd x y = 1` will no longer fail to parse due to containing the + constant :g:`Nat.gcd` in the parameter-argument of :g:`eq_refl`) + (`#9874 `_, + closes `#9840 `_ + and `#9844 `_, + by Jason Gross). + + - Deprecated compatibility notations have actually been + removed. Uses of these notations are generally easy to fix thanks + to the hint contained in the deprecation warning emitted by Coq + 8.8 and 8.9. For projects that require more than a handful of + such fixes, there is `a script + `_ + that will do it automatically, using the output of ``coqc`` + (`#8638 `_, by Jason Gross). + +- The `quote plugin + `_ was removed. If some users are interested in maintaining this plugin - externally, the Coq development team can provide assistance for extracting - the plugin and setting up a new repository. - -Tactics - -- Removed the deprecated `romega` tactics. -- Tactic names are no longer allowed to clash, even if they are not defined in - the same section. For example, the following is no longer accepted: - `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` - -- The tactics 'lia','nia','lra','nra' are now using a novel - Simplex-based proof engine. In case of regression, 'Unset Simplex' - to get the venerable Fourier-based engine. - -- Names of existential variables occurring in Ltac functions - (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted - the same way as other variable names occurring in Ltac functions. - -- Hint declaration and removal should now specify a database (e.g. `Hint Resolve - foo : database`). When the database name is omitted, the hint is added to the - `core` database (as previously), but a deprecation warning is emitted. - -- There are now tactics in `PreOmega.v` called - `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and - `Z.to_euclidean_division_equations` (which combines the `div_mod` - and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to - support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), - by posing the specifying equation for `Z.div` and `Z.modulo` before - replacing them with atoms. - -- Ltac backtraces can be turned on using the "Ltac Backtrace" option. + externally, the Coq development team can provide assistance for + extracting the plugin and setting up a new repository + (`#7894 `_, by Maxime Dénès). -- The syntax of the :tacn:`autoapply` tactic was fixed to conform with preexisting - documentation: it now takes a `with` clause instead of a `using` clause. - - - -Vernacular commands - -- `Combined Scheme` can now work when inductive schemes are generated in sort - `Type`. It used to be limited to sort `Prop`. - -- Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. - Names may not be repeated, and may not overlap with section variable names. - -- Removed the deprecated `Implicit Tactic` family of commands. - -- The `Automatic Introduction` option has been removed and is now the - default. - -- `Arguments` now accepts names for arguments provided with `extra_scopes`. - -- The naming scheme for anonymous binders in a `Theorem` has changed to - avoid conflicts with explicitly named binders. - -- Computation of implicit arguments now properly handles local definitions in the - binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. +- Ltac: -- :cmd:`Declare Instance` now requires an instance name. + - Tactic names are no longer allowed to clash, even if they are not defined in + the same section. For example, the following is no longer accepted: + :g:`Ltac foo := idtac. Section S. Ltac foo := fail. End S.` -- The flag :flag:`Refine Instance Mode` has been turned off by default, meaning that - :cmd:`Instance` no longer opens a proof when a body is provided. + - Names of existential variables occurring in Ltac functions + (e.g. :g:`?[n]` or :g:`?n` in terms - not in patterns) are now interpreted + the same way as other variable names occurring in Ltac functions + (`#7309 `_, by Hugo Herbelin). -- Command :cmd:`Instance`, when no body is provided, now always opens - a proof. This is a breaking change, as instance of :n:`Instance - @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will - have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` - or :n:`Instance @ident__1 : @ident__2. Proof. Qed.`. +- Tactics: -- The flag :flag:`Program Mode` now means that the `Program` attribute is enabled - for all commands that support it. In particular, it does not have any effect - on tactics anymore. May cause some incompatibilities. + - Removed the deprecated `romega` tactic + (`#8419 `_, + by Maxime Dénès and Vincent Laporte). -- The algorithm computing implicit arguments now behaves uniformly for primitive - projection and application nodes (bug #9508). + - Hint declaration and removal should now specify a database (e.g. `Hint Resolve + foo : database`). When the database name is omitted, the hint is added to the + `core` database (as previously), but a deprecation warning is emitted. -- `Hypotheses` and `Variables` can now take implicit binders inside sections. + - There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms. -- Removed deprecated option `Automatic Coercions Import`. + - The syntax of the :tacn:`autoapply` tactic was fixed to conform with preexisting + documentation: it now takes a `with` clause instead of a `using` clause. -- The `Show Script` command has been deprecated. + - SSReflect clear discipline made consistent across the entire proof language. + Whenever a clear switch `{x..}` comes immediately before an existing proof + context entry (used as a view, as a rewrite rule or as name for a new + context entry) then such entry is cleared too. -- Option `Refine Instance Mode` has been deprecated and will be removed in - the next version. + E.g. The following sentences are elaborated as follows (when H is an existing + proof context entry): -- :cmd:`Coercion` does not warn ambiguous paths which are obviously convertible with - existing ones. + - `=> {x..} H` -> `=> {x..H} H` + - `=> {x..} /H` -> `=> /v {x..H}` + - `rewrite {x..} H` -> `rewrite E {x..H}` -- A new flag :flag:`Fast Name Printing` has been introduced. It changes the - algorithm used for allocating bound variable names for a faster but less - clever one. + (`#9341 `_, by Enrico Tassi). -Tools +- Vernacular commands: -- The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: - - `no` disables native_compute - - `yes` enables native_compute and precompiles `.v` files to native code - - `ondemand` enables native_compute but compiles code only when `native_compute` is called + - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. + Names may not be repeated, and may not overlap with section variable names. - The default value is `ondemand`. + - Removed the deprecated `Implicit Tactic` family of commands. - Note that this flag now has priority over the configure flag of the same name. - -- A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether - conversion can use the VM. The default value is `yes`. + - The `Automatic Introduction` option has been removed and is now the + default. -- CoqIDE now supports input for Unicode characters. For example, typing - "\alpha" then the "Shift+Space" will insert the greek letter alpha. - In fact, typing the prefix string "\a" is sufficient. - A larger number of default bindings are provided, following the latex - naming convention. Bindings can be customized, either globally, or on a - per-project basis, with the requirement is that keys must begin with a - backslash and contain no space character. Bindings may be assigned custom - priorities, so that prefixes resolve to the most convenient bindings. - The documentation pages for CoqIDE provides further details. + - `Arguments` now accepts names for arguments provided with `extra_scopes`. -- The pretty timing diff scripts (flag `TIMING=1` to a - `coq_makefile`-made `Makefile`, also - `tools/make-both-single-timing-files.py`, - `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) - now correctly support non-UTF-8 characters in the output of - `coqc`/`make` as well as printing to stdout, on both python2 and - python3. + - The naming scheme for anonymous binders in a `Theorem` has changed to + avoid conflicts with explicitly named binders. -Standard Library + - Computation of implicit arguments now properly handles local definitions in the + binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. -- Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about - the upper bound of number represented by a vector. - Allowed implicit vector length argument in `Ndigits.Bv2N`. + - :cmd:`Declare Instance` now requires an instance name. -- Added `Bvector.BVeq` that decides whether two `Bvector`\s are equal. + - The flag :flag:`Refine Instance Mode` has been turned off by default, meaning that + :cmd:`Instance` no longer opens a proof when a body is provided. -- Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. + - Command :cmd:`Instance`, when no body is provided, now always opens + a proof. This is a breaking change, as instance of :n:`Instance + @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will + have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` + or :n:`Instance @ident__1 : @ident__2. Proof. Qed.`. -- Added `ByteVector` type that can convert to and from [string]. + - The flag :flag:`Program Mode` now means that the `Program` attribute is enabled + for all commands that support it. In particular, it does not have any effect + on tactics anymore. May cause some incompatibilities. -- The prelude used to be automatically Exported and is now only - Imported. This should be relevant only when importing files which - don't use `-noinit` into files which do. + - The algorithm computing implicit arguments now behaves uniformly for primitive + projection and application nodes (bug #9508). -- Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an - ordered type (using lexical order). + - :cmd:`Hypotheses` and :cmd:`Variables` can now take implicit + binders inside sections. -- The `Coq.Numbers.Cyclic.Int31` library is deprecated. + - Removed deprecated option `Automatic Coercions Import`. -- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. + - The ``Show Script`` command has been deprecated. -- Moved the `auto` hints of the `FSet` library into a new - `fset` database. + - The flag :flag:`Refine Instance Mode` has been deprecated and will + be removed in the next version. -Universes + - :cmd:`Coercion` does not warn ambiguous paths which are obviously convertible with + existing ones. -- Added `Print Universes Subgraph` variant of `Print Universes`. - Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` + - A new flag :flag:`Fast Name Printing` has been introduced. It changes the + algorithm used for allocating bound variable names for a faster but less + clever one. -- Added private universes for opaque polymorphic constants, see doc - for the :opt"`Private Polymorphic Universes` option (and Unset it to get - the previous behaviour). + - Option ``Typeclasses Axioms Are Instances`` (compatibility option + introduced in the previous version) is deprecated. Use :cmd:`Declare + Instance` for axioms which should be instances. -SProp + - Removed option `Printing Primitive Projection Compatibility` -- Added a universe "SProp" for definitionally proof irrelevant - propositions. Use with -allow-sprop. See manual for details. +- Standard Library: -Inductives + - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about + the upper bound of number represented by a vector. + Allowed implicit vector length argument in `Ndigits.Bv2N`. -- An option and attributes to control the automatic decision to declare - an inductive type as template polymorphic were added. Warning - "auto-template" (off by default) can trigger when an inductive is - automatically declared template polymorphic without the attribute. + - Added `Bvector.BVeq` that decides whether two `Bvector`\s are equal. -Funind + - Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. -- Inductive types declared by Funind will never be template polymorphic. + - Added `ByteVector` type that can convert to and from [string]. -Misc + - The prelude used to be automatically Exported and is now only + Imported. This should be relevant only when importing files which + don't use `-noinit` into files which do. -- Option :opt`Typeclasses Axioms Are Instances` (compatibility option introduced in the previous version) is deprecated. Use :cmd:`Declare Instance` for axioms which should be instances. + - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an + ordered type (using lexical order). -- Removed option `Printing Primitive Projection Compatibility` - -SSReflect - -- New intro patterns: - - temporary introduction: `=> +` - - block introduction: `=> [^ prefix ] [^~ suffix ]` - - fast introduction: `=> >` - - tactics as views: `=> /ltac:mytac` - - replace hypothesis: `=> {}H` - See the reference manual for the actual documentation. + - The `Coq.Numbers.Cyclic.Int31` library is deprecated. -- Clear discipline made consistent across the entire proof language. - Whenever a clear switch `{x..}` comes immediately before an existing proof - context entry (used as a view, as a rewrite rule or as name for a new - context entry) then such entry is cleared too. + - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. - E.g. The following sentences are elaborated as follows (when H is an existing - proof context entry): - - `=> {x..} H` -> `=> {x..H} H` - - `=> {x..} /H` -> `=> /v {x..H}` - - `rewrite {x..} H` -> `rewrite E {x..H}` + - Moved the `auto` hints of the `FSet` library into a new + `fset` database. -Diffs +- Some error messages that show problems with a pair of non-matching + values will now highlight the differences. -- Some error messages that show problems with a pair of non-matching values will now - highlight the differences. Version 8.9 ----------- diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 97d86943fb..6cbd00f45d 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -252,6 +252,8 @@ use antialiased fonts or not, by setting the environment variable `GDK_USE_XFT` to 1 or 0 respectively. +.. _coqide-unicode: + Bindings for input of Unicode symbols ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 3ca1dda4d6..ac079ea7d5 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1376,6 +1376,8 @@ Abbreviations denoted expression is performed at definition time. Type checking is done only at the time of use of the abbreviation. +.. _numeral-notations: + Numeral notations ----------------- -- cgit v1.2.3 From deb35e4fc79909e0695fa719847394f1f8567442 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 23 Apr 2019 19:05:53 +0200 Subject: Change entry for #9906. --- doc/sphinx/changes.rst | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index d8ea9c1552..0a9e9b55ff 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -256,6 +256,9 @@ Other changes in 8.10+beta1 and `#9705 `_, by Jason Gross) + - coq_makefile's install target now errors if any file to install is missing + (`#9906 `_, by Gaëtan Gilbert). + - Specification language, type inference: - Fixing a missing check in interpreting instances of existential -- cgit v1.2.3 From 13d6db12f4e40e995572b15af52e3c31dd0c5182 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 24 Apr 2019 11:18:55 +0200 Subject: Finish adding authors and links to PRs. --- doc/sphinx/changes.rst | 122 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 83 insertions(+), 39 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 0a9e9b55ff..7adc1b5f08 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -21,7 +21,8 @@ reference manual. Here are the most important user-visible changes: - A notion of primitive object was added to the calculus. Its first instance is primitive cyclic unsigned integers, axiomatized in - module :g:`UInt63`. See Section :ref:`primitive-integers` + module :g:`UInt63`. See Section :ref:`primitive-integers`. + The `Coq.Numbers.Cyclic.Int31` library is deprecated (`#6914 `_, by Maxime Dénès, Benjamin Grégoire and Vincent Laporte). @@ -336,6 +337,7 @@ Other changes in 8.10+beta1 - Tactic names are no longer allowed to clash, even if they are not defined in the same section. For example, the following is no longer accepted: :g:`Ltac foo := idtac. Section S. Ltac foo := fail. End S.` + (`#8555 `_, by Maxime Dénès). - Names of existential variables occurring in Ltac functions (e.g. :g:`?[n]` or :g:`?n` in terms - not in patterns) are now interpreted @@ -350,18 +352,23 @@ Other changes in 8.10+beta1 - Hint declaration and removal should now specify a database (e.g. `Hint Resolve foo : database`). When the database name is omitted, the hint is added to the - `core` database (as previously), but a deprecation warning is emitted. + `core` database (as previously), but a deprecation warning is emitted + (`#8987 `_, by Maxime Dénès). - There are now tactics in `PreOmega.v` called `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and `Z.to_euclidean_division_equations` (which combines the `div_mod` - and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to + and `quot_rem` variants) which allow :tacn:`lia`, :tacn:`nia`, etc to support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), by posing the specifying equation for `Z.div` and `Z.modulo` before - replacing them with atoms. + replacing them with atoms + (`#8062 `_, by Jason Gross). - The syntax of the :tacn:`autoapply` tactic was fixed to conform with preexisting - documentation: it now takes a `with` clause instead of a `using` clause. + documentation: it now takes a `with` clause instead of a `using` clause + (`#9524 `_, + closes `#7632 `_, + by Théo Zimmermann). - SSReflect clear discipline made consistent across the entire proof language. Whenever a clear switch `{x..}` comes immediately before an existing proof @@ -380,90 +387,127 @@ Other changes in 8.10+beta1 - Vernacular commands: - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. - Names may not be repeated, and may not overlap with section variable names. + Names may not be repeated, and may not overlap with section variable names + (`#8820 `_, + closes `#8791 `_, + by Jasper Hugunin). - - Removed the deprecated `Implicit Tactic` family of commands. + - Removed the deprecated `Implicit Tactic` family of commands + (`#8779 `_, by Pierre-Marie Pédrot). - The `Automatic Introduction` option has been removed and is now the - default. + default + (`#9001 `_, + by Emilio Jesús Gallego Arias). - - `Arguments` now accepts names for arguments provided with `extra_scopes`. + - `Arguments` now accepts names for arguments provided with `extra_scopes` + (`#9117 `_, by Maxime Dénès). - The naming scheme for anonymous binders in a `Theorem` has changed to - avoid conflicts with explicitly named binders. + avoid conflicts with explicitly named binders + (`#9160 `_, + closes `#8819 `_, + by Jasper Hugunin). - Computation of implicit arguments now properly handles local definitions in the - binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. + binders for an `Instance`, and can be mixed with implicit binders `{x : T}` + (`#9307 `_, + closes `#9300 `_, + by Jasper Hugunin). - :cmd:`Declare Instance` now requires an instance name. - - The flag :flag:`Refine Instance Mode` has been turned off by default, meaning that - :cmd:`Instance` no longer opens a proof when a body is provided. + The flag :flag:`Refine Instance Mode` has been turned off by default, + meaning that :cmd:`Instance` no longer opens a proof when a body is + provided. The flag has been deprecated and will be removed in the next + version. + + (`#9270 `_, + and `#9825 `_, + by Maxime Dénès) - Command :cmd:`Instance`, when no body is provided, now always opens a proof. This is a breaking change, as instance of :n:`Instance @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` - or :n:`Instance @ident__1 : @ident__2. Proof. Qed.`. + or :n:`Instance @ident__1 : @ident__2. Proof. Qed.` + (`#9274 `_, by Maxime Dénès). - The flag :flag:`Program Mode` now means that the `Program` attribute is enabled for all commands that support it. In particular, it does not have any effect - on tactics anymore. May cause some incompatibilities. + on tactics anymore. May cause some incompatibilities + (`#9410 `_, by Maxime Dénès). - The algorithm computing implicit arguments now behaves uniformly for primitive - projection and application nodes (bug #9508). + projection and application nodes + (`#9509 `_, + closes `#9508 `_, + by Pierre-Marie Pédrot). - :cmd:`Hypotheses` and :cmd:`Variables` can now take implicit - binders inside sections. + binders inside sections + (`#9364 `_, + closes `#9363 `_, + by Jasper Hugunin). - - Removed deprecated option `Automatic Coercions Import`. + - Removed deprecated option `Automatic Coercions Import` + (`#8094 `_, by Maxime Dénès). - - The ``Show Script`` command has been deprecated. + - The ``Show Script`` command has been deprecated + (`#9829 `_, by Vincent Laporte). - - The flag :flag:`Refine Instance Mode` has been deprecated and will - be removed in the next version. - - - :cmd:`Coercion` does not warn ambiguous paths which are obviously convertible with - existing ones. + - :cmd:`Coercion` does not warn ambiguous paths which are obviously + convertible with existing ones + (`#9743 `_, + closes `#3219 `_, + by Kazuhiko Sakaguchi). - A new flag :flag:`Fast Name Printing` has been introduced. It changes the algorithm used for allocating bound variable names for a faster but less - clever one. + clever one + (`#9078 `_, by Pierre-Marie Pédrot). - Option ``Typeclasses Axioms Are Instances`` (compatibility option introduced in the previous version) is deprecated. Use :cmd:`Declare - Instance` for axioms which should be instances. + Instance` for axioms which should be instances + (`#8920 `_, by Gaëtan Gilbert). - Removed option `Printing Primitive Projection Compatibility` + (`#9306 `_, by Gaëtan Gilbert). - Standard Library: - - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about - the upper bound of number represented by a vector. - Allowed implicit vector length argument in `Ndigits.Bv2N`. - - Added `Bvector.BVeq` that decides whether two `Bvector`\s are equal. + Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg` + (`#8171 `_, by Yishuai Li). - - Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. + - Added `ByteVector` type that can convert to and from `string` + (`#8365 `_, by Yishuai Li). - - Added `ByteVector` type that can convert to and from [string]. + - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about + the upper bound of number represented by a vector. + Allowed implicit vector length argument in `Ndigits.Bv2N` + (`#8815 `_, by Yishuai Li). - The prelude used to be automatically Exported and is now only Imported. This should be relevant only when importing files which - don't use `-noinit` into files which do. + don't use `-noinit` into files which do + (`#9013 `_, by Gaëtan Gilert). - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an - ordered type (using lexical order). - - - The `Coq.Numbers.Cyclic.Int31` library is deprecated. + ordered type, using lexical order + (`#7221 `_, by Li Yao). - - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. + - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo` + (`#9425 `_, by Andres Erbsen). - Moved the `auto` hints of the `FSet` library into a new - `fset` database. + `fset` database + (`#9725 `_, by Frédéric Besson). - Some error messages that show problems with a pair of non-matching - values will now highlight the differences. + values will now highlight the differences + (`#8669 `_, by Jim Fehrle). Version 8.9 -- cgit v1.2.3 From 50654fc1917e8fc475973c9066280839aa0e2d88 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 25 Apr 2019 09:17:59 +0200 Subject: Remove misplaced CHANGES entry and fix links formatting. PR #8187 misplaced its CHANGES entry. We remove it in this commit instead of moving it to the right place because it is reverted in #9987. --- doc/sphinx/changes.rst | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 7adc1b5f08..648561fbb5 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -675,16 +675,12 @@ Notations - Deprecated compatibility notations will actually be removed in the next version of Coq. Uses of these notations are generally easy to fix thanks to the hint contained in the deprecation warnings. For - projects that require more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script + projects that require more than a handful of such fixes, there is `a + script + `_ + that will do it automatically, using the output of ``coqc``. The script contains documentation on its usage in a comment at the top. -- When several notations are available for the same expression, - priority is given to latest notations defined in the scopes being - opened, in order, rather than to the latest notations defined - independently of whether they are in an opened scope or not. - Tactics - Added toplevel goal selector `!` which expects a single focused goal. @@ -768,7 +764,7 @@ Standard Library `Require Import Coq.Compat.Coq88` will make these notations available. Users wishing to port their developments automatically may download `fix.py` from - + https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169 and run a command like `while true; do make -Okj 2>&1 | /path/to/fix.py; done` and get a cup of coffee. (This command must be manually interrupted once the build finishes all the way though. @@ -792,8 +788,8 @@ Tools If you would like to maintain this tool externally, please contact us. - Removed the Emacs modes distributed with Coq. You are advised to - use [Proof-General](https://proofgeneral.github.io/) (and optionally - [Company-Coq](https://github.com/cpitclaudel/company-coq)) instead. + use `Proof-General `_ (and optionally + `Company-Coq `_) instead. If your use case is not covered by these alternative Emacs modes, please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. -- cgit v1.2.3 From 93209c4352ef2634156c8899c391778747254e14 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 25 Apr 2019 09:22:15 +0200 Subject: Remove remaining references to CHANGES.md from the Recent changes chapter. --- doc/sphinx/changes.rst | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 648561fbb5..8aaa39f36c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -520,7 +520,7 @@ Summary of changes of features and deprecations or removals of deprecated features, cleanups of the internals of the system and API along with a few new features. This release includes many user-visible changes, including -deprecations that are documented in ``CHANGES.md`` and new features that +deprecations that are documented in the next subsection and new features that are documented in the reference manual. Here are the most important changes: @@ -534,7 +534,7 @@ changes: manual). - Deprecated notations of the standard library will be removed in the - next version of |Coq|, see the ``CHANGES.md`` file for a script to + next version of |Coq|, see the next subsection for a script to ease porting, by Jason Gross and Jean-Christophe Léchenet. - Added the :cmd:`Numeral Notation` command for registering decimal @@ -587,7 +587,7 @@ changes: - Library: additions and changes in the ``VectorDef``, ``Ascii``, and ``String`` libraries. Syntax notations are now available only when using ``Import`` of libraries and not merely ``Require``, by various - contributors (source of incompatibility, see ``CHANGES.md`` for details). + contributors (source of incompatibility, see the next subsection for details). - Toplevels: ``coqtop`` and ``coqide`` can now display diffs between proof steps in color, using the :opt:`Diffs` option, by Jim Fehrle. @@ -604,7 +604,7 @@ changes: Version 8.9 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. Most -important ones are documented in the ``CHANGES.md`` file. +important ones are documented in the next subsection file. On the implementation side, the ``dev/doc/changes.md`` file documents the numerous changes to the implementation and improvements of @@ -932,7 +932,7 @@ version. Version 8.8 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. -Most important ones are documented in the ``CHANGES.md`` file. +Most important ones are documented in the next subsection file. The efficiency of the whole system has seen improvements thanks to contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and @@ -1292,7 +1292,7 @@ of integers and real constants are now represented using ``IZR`` (work by Guillaume Melquiond). Standard library additions and improvements by Jason Gross, Pierre Letouzey and -others, documented in the ``CHANGES.md`` file. +others, documented in the next subsection file. The mathematical proof language/declarative mode plugin was removed from the archive. -- cgit v1.2.3 From 0473775ea96088fc13c99d0082f26f5be6eaec85 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 25 Apr 2019 09:31:07 +0200 Subject: More review suggestions. --- doc/sphinx/changes.rst | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 8aaa39f36c..5d267b37fa 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -24,7 +24,8 @@ reference manual. Here are the most important user-visible changes: module :g:`UInt63`. See Section :ref:`primitive-integers`. The `Coq.Numbers.Cyclic.Int31` library is deprecated (`#6914 `_, by Maxime Dénès, - Benjamin Grégoire and Vincent Laporte). + Benjamin Grégoire and Vincent Laporte, + with help and reviews from many others). - The :math:`\SProp` sort of definitionally proof-irrelevant propositions was introduced. :math:`\SProp` allows to mark proof @@ -164,6 +165,8 @@ contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael Soegtrop, Théo Zimmermann worked on maintaining and improving the continuous integration system and package building infrastructure. +Coq is now continuously tested against OCaml trunk, in addition to the +oldest supported and latest OCaml releases. The OPAM repository for |Coq| packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) -- cgit v1.2.3 From eda7d026b6919b8bef13512f5e324c7174f81a7e Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 25 Apr 2019 16:51:35 +0200 Subject: Advertize continuous deployment of documentation. --- doc/sphinx/changes.rst | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 5d267b37fa..f433df0978 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -168,6 +168,12 @@ continuous integration system and package building infrastructure. Coq is now continuously tested against OCaml trunk, in addition to the oldest supported and latest OCaml releases. +Coq's documentation for the development branch is now deployed +continously at https://coq.github.io/doc/master/api (documentation of +the ML API), https://coq.github.io/doc/master/refman (reference +manual), and https://coq.github.io/doc/master/stdlib (documentation of +the standard library). Similar links exist for the `v8.10` branch. + The OPAM repository for |Coq| packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) with contributions from many users. A list of packages is available at -- cgit v1.2.3 From 5e37ef7fedf16a10b18d08c87a20e2dc42dde19a Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 29 Apr 2019 11:13:55 +0200 Subject: Add number of commits, PRs and issues closed. --- doc/sphinx/changes.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index f433df0978..441170e419 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -204,8 +204,8 @@ extent influenced the development. Version 8.10 is the fifth release of |Coq| developed on a time-based development cycle. Its development spanned 6 months from the release of |Coq| 8.9. Vincent Laporte is the release manager and maintainer of this -release. This release is the result of ??? commits and ??? PRs -merged, closing ??? issues. +release. This release is the result of ~2500 commits and ~650 PRs merged, +closing 150+ issues. | Santiago de Chile, April 2019, | Matthieu Sozeau for the |Coq| development team -- cgit v1.2.3 From 73a0d923563b5ec157d517eb5e8ea1c794be64a9 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 29 Apr 2019 17:24:26 +0200 Subject: Change entry for #10014. --- doc/sphinx/changes.rst | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 441170e419..3b34973306 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -269,6 +269,10 @@ Other changes in 8.10+beta1 - coq_makefile's install target now errors if any file to install is missing (`#9906 `_, by Gaëtan Gilbert). + - Preferences from ``coqide.keys`` are no longer overridden by + modifiers preferences in ``coqiderc`` + (`#10014 `_, by Hugo Herbelin). + - Specification language, type inference: - Fixing a missing check in interpreting instances of existential -- cgit v1.2.3 From 9af92ba8374e51f00a58fe97abce18c67884db25 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 29 Apr 2019 17:46:38 +0200 Subject: Change entry from #9651. --- doc/sphinx/changes.rst | 37 +++++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 3b34973306..1c4c748295 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -79,18 +79,31 @@ reference manual. Here are the most important user-visible changes: to get the venerable Fourier-based engine (`#8457 `_, by Fréderic Besson). -- New SSReflect intro patterns: - - - temporary introduction: `=> +` - - block introduction: `=> [^ prefix ] [^~ suffix ]` - - fast introduction: `=> >` - - tactics as views: `=> /ltac:mytac` - - replace hypothesis: `=> {}H` - - See Section :ref:`introduction_ssr` - (`#6705 `_, by Enrico Tassi, - with help from Maxime Dénès, - ideas coming from various users). +- SSReflect: + + - New intro patterns: + + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` + + See Section :ref:`introduction_ssr` + (`#6705 `_, by Enrico Tassi, + with help from Maxime Dénès, + ideas coming from various users). + + - New tactic :tacn:`under` to rewrite under binders, given an + extensionality lemma: + + - interactive mode: :n:`under @term`, associated terminator: :tacn:`over` + - one-liner mode: `under @term do [@tactic | ...]` + + It can take occurrence switches, contextual patterns, and intro patterns: + :g:`under {2}[in RHS]eq_big => [i|i ?] do ...` + (`#9651 `_, + by Erik Martin-Dorel and Enrico Tassi). - :cmd:`Combined Scheme` now works when inductive schemes are generated in sort :math:`\Type`. It used to be limited to sort `Prop` -- cgit v1.2.3 From d911384de18874b98c20bf25e444f1d356af4249 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 27 Apr 2019 13:28:37 +0200 Subject: Renaming nanoPG to microPG. This is to be consistent with what the preference panel displays (namely μpG). We keep the nanoPG name in the preference file by compatibility. --- ide/coqide.ml | 8 +- ide/ide.mllib | 2 +- ide/microPG.ml | 345 ++++++++++++++++++++++++++++++++++++++++++++++++++++ ide/microPG.mli | 13 ++ ide/nanoPG.ml | 345 ---------------------------------------------------- ide/nanoPG.mli | 13 -- ide/preferences.ml | 5 +- ide/preferences.mli | 2 +- 8 files changed, 367 insertions(+), 366 deletions(-) create mode 100644 ide/microPG.ml create mode 100644 ide/microPG.mli delete mode 100644 ide/nanoPG.ml delete mode 100644 ide/nanoPG.mli diff --git a/ide/coqide.ml b/ide/coqide.ml index aa9e150fd5..4f00be27a1 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -561,7 +561,7 @@ let update_status sn = | None -> "" | Some n -> ", proving " ^ n in - display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name); + display ("Ready"^ (if microPG#get then ", [μPG]" else "") ^ path ^ name); Coq.return () in Coq.bind (Coq.status false) next @@ -1200,7 +1200,7 @@ let build_ui () = item "Help for μPG mode" ~label:"Help for μPG mode" ~callback:(fun _ -> on_current_term (fun sn -> sn.messages#default_route#clear; - sn.messages#default_route#add_string (NanoPG.get_documentation ()))); + sn.messages#default_route#add_string (MicroPG.get_documentation ()))); item "About Coq" ~label:"_About" ~stock:`ABOUT ~callback:MiscMenu.about ]; @@ -1234,7 +1234,7 @@ let build_ui () = let () = vbox#pack toolbar#coerce in (* Emacs/PG mode *) - NanoPG.init w notebook all_menus; + MicroPG.init w notebook all_menus; (* On tab switch, reset, update location *) let _ = notebook#connect#switch_page ~callback:(fun n -> @@ -1251,7 +1251,7 @@ let build_ui () = let () = refresh_notebook_pos () in let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in let () = lower_hbox#pack ~expand:true status#coerce in - let () = push_info ("Ready"^ if nanoPG#get then ", [μPG]" else "") in + let () = push_info ("Ready"^ if microPG#get then ", [μPG]" else "") in (* Location display *) let l = GMisc.label diff --git a/ide/ide.mllib b/ide/ide.mllib index ed6520f29f..f8e8ff48d6 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -30,5 +30,5 @@ CoqOps Wg_Command Session Coqide_ui -NanoPG +MicroPG Coqide diff --git a/ide/microPG.ml b/ide/microPG.ml new file mode 100644 index 0000000000..25cab4638c --- /dev/null +++ b/ide/microPG.ml @@ -0,0 +1,345 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* ag#name = name) gui.action_groups +let ct gui = gui.notebook#current_term + +let get_sel b = b#selection_bounds +let sel_nonempty b = let i, j = get_sel b in not (i#equal j) +let get_sel_txt b = let i, j = get_sel b in i#get_text ~stop:j + +type status = { move : int option; kill : (string * bool) option; sel: bool } + +let pr_status { move; kill; sel } = + let move = Option.cata (fun i -> string_of_int i) "" move in + let kill = Option.cata (fun (s,b) -> sprintf "kill(%b) %S" b s) "" kill in + let sel = string_of_bool sel in + Printf.sprintf "{ move: %s; kill: %s; sel: %s }" move kill sel +let pr_key t = + let kv = GdkEvent.Key.keyval t in + let str = GdkEvent.Key.string t in + let str_of_mod = function + | `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL" + | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" | `MOD3 -> "MOD3" | `MOD4 -> "MOD4" + | `MOD5 -> "MOD5" | `BUTTON1 -> "BUTTON1" | `BUTTON2 -> "BUTTON2" + | `BUTTON3 -> "BUTTON3" | `BUTTON4 -> "BUTTON4" | `BUTTON5 -> "BUTTON5" + | `SUPER -> "SUPER" | `HYPER -> "HYPER" | `META -> "META" + | `RELEASE -> "RELEASE" in + let mods = String.concat " " (List.map str_of_mod (GdkEvent.Key.state t)) in + Printf.sprintf "'%s' (%d, %s)" str kv mods + +type action = + | Action of string * string + | Callback of (gui -> unit) + | Edit of (status -> GSourceView3.source_buffer -> GText.iter -> + (string -> string -> unit) -> status) + | Motion of (status -> GText.iter -> GText.iter * status) + +type 'c entry = { + mods : Gdk.Tags.modifier list; + key : Gdk.keysym; + keyname : string; + doc : string; + contents : 'c +} + +let mC = [`CONTROL] +let mM = + if Coq_config.arch = "Darwin" then + (* We add both MOD2 and META because both are + returned when pressing Command on MacOS X *) + [`CONTROL;`MOD2;`META] + else + [`MOD1] + +let mod_of t x = + let y = GdkEvent.Key.state t in + List.for_all (fun m -> List.mem m y) x && + List.for_all (fun m -> List.mem m x) y + +let pr_keymod l = + if l = mC then + "Ctrl-" + else + if l = mM then + if Coq_config.arch = "Darwin" then "Ctrl-Cmd-" else "Meta-" + else + "" + +let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents = + List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents }) + ((mods, key, keyname)::alias) + +type keypaths = Step of action entry list * keypaths entry list + +let print_keypaths kps = + let rec aux prefix (Step (l, konts)) = + String.concat "\n" ( + (List.map (fun x -> + prefix ^ pr_keymod x.mods ^ x.keyname ^ " " ^ x.doc ) l) @ + (List.map (fun x -> + aux (prefix^pr_keymod x.mods^x.keyname^" ") x.contents) konts)) in + aux " " kps + +let empty = Step([],[]) + +let frontier (Step(l1,l2)) = + List.map (fun x -> pr_keymod x.mods ^ x.keyname) l1 @ + List.map (fun x -> pr_keymod x.mods ^ x.keyname) l2 + +let insert kps name enter_syms bindings = + let rec aux kps enter_syms = + match enter_syms, kps with + | [], Step (el, konts) -> Step (List.flatten bindings @ el, konts) + | (mods, key, keyname)::gs, Step (el, konts) -> + if List.exists (fun { key = k; mods = m } -> key = k && mods = m) konts + then + let konts = + List.map + (fun ({ key = k; contents } as x) -> + if key <> k then x else { x with contents = aux contents gs }) + konts in + Step(el,konts) + else + let kont = + { mods; key; keyname; doc = name; contents = aux empty gs } in + Step(el, kont::konts) in + aux kps enter_syms + +let run_action gui group name = + ((actiong gui group)#get_action name)#activate () + +let run key gui action status = + match action with + | Callback f -> f gui; status + | Action(group, name) -> run_action gui group name; status + | Edit f -> + let b = (ct gui).script#source_buffer in + let i = b#get_iter_at_mark `INSERT in + let status = f status b i (run_action gui) in + if not status.sel then + b#place_cursor ~where:(b#get_iter_at_mark `SEL_BOUND); + status + | Motion f -> + let b, script = (ct gui).script#source_buffer, (ct gui).script in + let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in + let i = + if sel_mode then b#get_iter_at_mark `SEL_BOUND + else b#get_iter_at_mark `INSERT in + let where, status = f status i in + let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in + if sel_mode then (b#move_mark `SEL_BOUND ~where; script#scroll_mark_onscreen `SEL_BOUND) + else (b#place_cursor ~where; script#scroll_mark_onscreen `INSERT); + status + +let emacs = empty + +let emacs = insert emacs "Emacs" [] [ + (* motion *) + mkE _e "e" "Move to end of line" (Motion(fun s i -> + (if not i#ends_line then i#forward_to_line_end else i), + { s with move = None })); + mkE ~mods:mM _Right "->" "Move to end of buffer" (Motion(fun s i -> + i#forward_to_end, + { s with move = None })); + mkE ~mods:mM _Left "<-" "Move to start of buffer" (Motion(fun s i -> + let buffer = new GText.buffer i#buffer in + buffer#start_iter, + { s with move = None })); + mkE _a "a" "Move to beginning of line" (Motion(fun s i -> + (i#set_line_offset 0), { s with move = None })); + mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i -> + i#forward_sentence_end, { s with move = None })); + mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i -> + i#backward_sentence_start, { s with move = None })); + mkE _n "n" "Move to next line" (Motion(fun s i -> + let orig_off = Option.default i#line_offset s.move in + let i = i#forward_line in + let new_off = min (i#chars_in_line - 1) orig_off in + (if new_off > 0 then i#set_line_offset new_off else i), + { s with move = Some orig_off })); + mkE _p "p" "Move to previous line" (Motion(fun s i -> + let orig_off = Option.default i#line_offset s.move in + let i = i#backward_line in + let new_off = min (i#chars_in_line - 1) orig_off in + (if new_off > 0 then i#set_line_offset new_off else i), + { s with move = Some orig_off })); + mkE _f "f" "Forward char" ~alias:[[],_Right,"RIGHT"] + (Motion(fun s i -> i#forward_char, { s with move = None })); + mkE _b "b" "Backward char" ~alias:[[],_Left,"LEFT"] + (Motion(fun s i -> i#backward_char, { s with move = None })); + mkE ~mods:mM _f "f" "Forward word" ~alias:[mC,_Right,"RIGHT"] + (Motion(fun s i -> i#forward_word_end, { s with move = None })); + mkE ~mods:mM _b "b" "Backward word" ~alias:[mC,_Left,"LEFT"] + (Motion(fun s i -> i#backward_word_start, { s with move = None })); + mkE _space "SPC" "Set mark" ~alias:[mC,_at,"@"] (Motion(fun s i -> + if s.sel = false then i, { s with sel = true } + else i, { s with sel = false } )); + (* edits *) + mkE ~mods:mM _w "w" "Copy selected region" (Edit(fun s b i run -> + if sel_nonempty b then + let txt = get_sel_txt b in + run "Edit" "Copy"; + { s with kill = Some(txt,false); sel = false } + else s)); + mkE _w "w" "Kill selected region" (Edit(fun s b i run -> + if sel_nonempty b then + let txt = get_sel_txt b in + run "Edit" "Cut"; + { s with kill = Some(txt,false); sel = false } + else s)); + mkE _k "k" "Kill until the end of line" (Edit(fun s b i _ -> + let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in + let k = + if i#ends_line then begin + b#delete ~start:i ~stop:i#forward_char; "\n" + end else begin + let k = b#get_text ~start:i ~stop:i#forward_to_line_end () in + b#delete ~start:i ~stop:i#forward_to_line_end; k + end in + { s with kill = Some (already_killed ^ k,true) })); + mkE ~mods:mM _d "d" "Kill next word" (Edit(fun s b i _ -> + let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in + let k = + let k = b#get_text ~start:i ~stop:i#forward_word_end () in + b#delete ~start:i ~stop:i#forward_word_end; k in + { s with kill = Some (already_killed ^ k,true) })); + mkE ~mods:mM _k "k" "Kill until sentence end" (Edit(fun s b i _ -> + let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in + let k = + let k = b#get_text ~start:i ~stop:i#forward_sentence_end () in + b#delete ~start:i ~stop:i#forward_sentence_end; k in + { s with kill = Some (already_killed ^ k,true) })); + mkE ~mods:mM _BackSpace "DELBACK" "Kill word before cursor" + (Edit(fun s b i _ -> + let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in + let k = + let k = b#get_text ~start:i ~stop:i#backward_word_start () in + b#delete ~start:i ~stop:i#backward_word_start; k in + { s with kill = Some (already_killed ^ k,true) })); + mkE _d "d" "Delete next character" (Edit(fun s b i _ -> + b#delete ~start:i ~stop:i#forward_char; s)); + mkE _y "y" "Yank killed text back " (Edit(fun s b i _ -> + let k, s = match s.kill with + | Some (k,_) -> k, { s with kill = Some (k,false) } + | _ -> "", s in + b#insert ~iter:i k; + s)); + (* misc *) + mkE _underscore "_" "Undo" (Action("Edit", "Undo")); + mkE _g "g" "Esc" (Callback(fun gui -> (ct gui).finder#hide ())); + mkE _s "s" "Search" (Callback(fun gui -> + if (ct gui).finder#coerce#misc#visible + then run_action gui "Edit" "Find Next" + else run_action gui "Edit" "Find")); + mkE _s "r" "Search backward" (Callback(fun gui -> + if (ct gui).finder#coerce#misc#visible + then run_action gui "Edit" "Find Previous" + else run_action gui "Edit" "Find")); + ] + +let emacs = insert emacs "Emacs" [mC,_x,"x"] [ + mkE _s "s" "Save" (Action("File", "Save")); + mkE _c "c" "Quit" (Action("File", "Quit")); + mkE _f "f" "Open" (Action("File", "Open")); + mkE ~mods:[] _u "u" "Undo" (Action("Edit", "Undo")); + ] + +let pg = insert emacs "Proof General" [mC,_c,"c"] [ + mkE _Return "RET" "Go to" (Action("Navigation", "Go to")); + mkE _n "n" "Advance 1 sentence" (Action("Navigation", "Forward")); + mkE _u "u" "Retract 1 sentence" (Action("Navigation", "Backward")); + mkE _b "b" "Advance" (Action("Navigation", "End")); + mkE _r "r" "Restart" (Action("Navigation", "Start")); + mkE _c "c" "Stop" (Action("Navigation", "Interrupt")); + ] + +let command gui c = + let command = (ct gui).command in + let script = (ct gui).script in + let term = + let i, j = script#source_buffer#selection_bounds in + if i#equal j then None + else Some (script#buffer#get_text ~start:i ~stop:j ()) in + command#show; + command#new_query ~command:c ?term () + +let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [ + mkE _p "p" "Print" (Callback (fun gui -> command gui "Print")); + mkE _c "c" "Check" (Callback (fun gui -> command gui "Check")); + mkE _b "b" "About" (Callback (fun gui -> command gui "About")); + mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout")); + mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern")); + mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate")); + mkE _Return "RET" "match template" (Action("Templates","match")); + ] + +let empty = { sel = false; kill = None; move = None } + +let find gui (Step(here,konts)) t = + (* hack: ^c does copy in clipboard *) + let sel_nonempty () = sel_nonempty (ct gui).script#source_buffer in + let k = GdkEvent.Key.keyval t in + if k = _x && mod_of t mC && sel_nonempty () then + ignore(run t gui (Action("Edit","Cut")) empty) + else + if k = _c && mod_of t mC && sel_nonempty () then + ignore(run t gui (Action("Edit","Copy")) empty); + let cmp { key; mods } = key = k && mod_of t mods in + try `Do (List.find cmp here) with Not_found -> + try `Cont (List.find cmp konts).contents with Not_found -> `NotFound + +let init w nb ags = + let gui = { notebook = nb; action_groups = ags } in + let cur = ref pg in + let status = ref empty in + let reset () = eprintf "reset\n%!"; cur := pg in + ignore(w#event#connect#key_press ~callback:(fun t -> + let on_current_term f = + let term = try Some nb#current_term with Invalid_argument _ -> None in + match term with None -> false | Some t -> f t + in + on_current_term (fun x -> + if x.script#misc#get_property "has-focus" <> `BOOL true + then false + else begin + eprintf "got key %s\n%!" (pr_key t); + if microPG#get then begin + match find gui !cur t with + | `Do e -> + eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status); + status := run t gui e.contents !status; reset (); true + | `Cont c -> + flash_info ("Waiting one of " ^ String.concat " " (frontier c)); + cur := c; true + | `NotFound -> reset (); false + end else false + end))); + ignore(w#event#connect#button_press ~callback:(fun t -> reset (); false)) + + + +let get_documentation () = + "Chars, words, lines and sentences below pertain to standard unicode segmentation rules\n" ^ + print_keypaths pg diff --git a/ide/microPG.mli b/ide/microPG.mli new file mode 100644 index 0000000000..bc9b39d823 --- /dev/null +++ b/ide/microPG.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* string +val init : GWindow.window -> Session.session Wg_Notebook.typed_notebook -> + GAction.action_group list -> unit diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml deleted file mode 100644 index 5e6c0b8462..0000000000 --- a/ide/nanoPG.ml +++ /dev/null @@ -1,345 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* ag#name = name) gui.action_groups -let ct gui = gui.notebook#current_term - -let get_sel b = b#selection_bounds -let sel_nonempty b = let i, j = get_sel b in not (i#equal j) -let get_sel_txt b = let i, j = get_sel b in i#get_text ~stop:j - -type status = { move : int option; kill : (string * bool) option; sel: bool } - -let pr_status { move; kill; sel } = - let move = Option.cata (fun i -> string_of_int i) "" move in - let kill = Option.cata (fun (s,b) -> sprintf "kill(%b) %S" b s) "" kill in - let sel = string_of_bool sel in - Printf.sprintf "{ move: %s; kill: %s; sel: %s }" move kill sel -let pr_key t = - let kv = GdkEvent.Key.keyval t in - let str = GdkEvent.Key.string t in - let str_of_mod = function - | `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL" - | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" | `MOD3 -> "MOD3" | `MOD4 -> "MOD4" - | `MOD5 -> "MOD5" | `BUTTON1 -> "BUTTON1" | `BUTTON2 -> "BUTTON2" - | `BUTTON3 -> "BUTTON3" | `BUTTON4 -> "BUTTON4" | `BUTTON5 -> "BUTTON5" - | `SUPER -> "SUPER" | `HYPER -> "HYPER" | `META -> "META" - | `RELEASE -> "RELEASE" in - let mods = String.concat " " (List.map str_of_mod (GdkEvent.Key.state t)) in - Printf.sprintf "'%s' (%d, %s)" str kv mods - -type action = - | Action of string * string - | Callback of (gui -> unit) - | Edit of (status -> GSourceView3.source_buffer -> GText.iter -> - (string -> string -> unit) -> status) - | Motion of (status -> GText.iter -> GText.iter * status) - -type 'c entry = { - mods : Gdk.Tags.modifier list; - key : Gdk.keysym; - keyname : string; - doc : string; - contents : 'c -} - -let mC = [`CONTROL] -let mM = - if Coq_config.arch = "Darwin" then - (* We add both MOD2 and META because both are - returned when pressing Command on MacOS X *) - [`CONTROL;`MOD2;`META] - else - [`MOD1] - -let mod_of t x = - let y = GdkEvent.Key.state t in - List.for_all (fun m -> List.mem m y) x && - List.for_all (fun m -> List.mem m x) y - -let pr_keymod l = - if l = mC then - "Ctrl-" - else - if l = mM then - if Coq_config.arch = "Darwin" then "Ctrl-Cmd-" else "Meta-" - else - "" - -let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents = - List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents }) - ((mods, key, keyname)::alias) - -type keypaths = Step of action entry list * keypaths entry list - -let print_keypaths kps = - let rec aux prefix (Step (l, konts)) = - String.concat "\n" ( - (List.map (fun x -> - prefix ^ pr_keymod x.mods ^ x.keyname ^ " " ^ x.doc ) l) @ - (List.map (fun x -> - aux (prefix^pr_keymod x.mods^x.keyname^" ") x.contents) konts)) in - aux " " kps - -let empty = Step([],[]) - -let frontier (Step(l1,l2)) = - List.map (fun x -> pr_keymod x.mods ^ x.keyname) l1 @ - List.map (fun x -> pr_keymod x.mods ^ x.keyname) l2 - -let insert kps name enter_syms bindings = - let rec aux kps enter_syms = - match enter_syms, kps with - | [], Step (el, konts) -> Step (List.flatten bindings @ el, konts) - | (mods, key, keyname)::gs, Step (el, konts) -> - if List.exists (fun { key = k; mods = m } -> key = k && mods = m) konts - then - let konts = - List.map - (fun ({ key = k; contents } as x) -> - if key <> k then x else { x with contents = aux contents gs }) - konts in - Step(el,konts) - else - let kont = - { mods; key; keyname; doc = name; contents = aux empty gs } in - Step(el, kont::konts) in - aux kps enter_syms - -let run_action gui group name = - ((actiong gui group)#get_action name)#activate () - -let run key gui action status = - match action with - | Callback f -> f gui; status - | Action(group, name) -> run_action gui group name; status - | Edit f -> - let b = (ct gui).script#source_buffer in - let i = b#get_iter_at_mark `INSERT in - let status = f status b i (run_action gui) in - if not status.sel then - b#place_cursor ~where:(b#get_iter_at_mark `SEL_BOUND); - status - | Motion f -> - let b, script = (ct gui).script#source_buffer, (ct gui).script in - let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in - let i = - if sel_mode then b#get_iter_at_mark `SEL_BOUND - else b#get_iter_at_mark `INSERT in - let where, status = f status i in - let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in - if sel_mode then (b#move_mark `SEL_BOUND ~where; script#scroll_mark_onscreen `SEL_BOUND) - else (b#place_cursor ~where; script#scroll_mark_onscreen `INSERT); - status - -let emacs = empty - -let emacs = insert emacs "Emacs" [] [ - (* motion *) - mkE _e "e" "Move to end of line" (Motion(fun s i -> - (if not i#ends_line then i#forward_to_line_end else i), - { s with move = None })); - mkE ~mods:mM _Right "->" "Move to end of buffer" (Motion(fun s i -> - i#forward_to_end, - { s with move = None })); - mkE ~mods:mM _Left "<-" "Move to start of buffer" (Motion(fun s i -> - let buffer = new GText.buffer i#buffer in - buffer#start_iter, - { s with move = None })); - mkE _a "a" "Move to beginning of line" (Motion(fun s i -> - (i#set_line_offset 0), { s with move = None })); - mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i -> - i#forward_sentence_end, { s with move = None })); - mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i -> - i#backward_sentence_start, { s with move = None })); - mkE _n "n" "Move to next line" (Motion(fun s i -> - let orig_off = Option.default i#line_offset s.move in - let i = i#forward_line in - let new_off = min (i#chars_in_line - 1) orig_off in - (if new_off > 0 then i#set_line_offset new_off else i), - { s with move = Some orig_off })); - mkE _p "p" "Move to previous line" (Motion(fun s i -> - let orig_off = Option.default i#line_offset s.move in - let i = i#backward_line in - let new_off = min (i#chars_in_line - 1) orig_off in - (if new_off > 0 then i#set_line_offset new_off else i), - { s with move = Some orig_off })); - mkE _f "f" "Forward char" ~alias:[[],_Right,"RIGHT"] - (Motion(fun s i -> i#forward_char, { s with move = None })); - mkE _b "b" "Backward char" ~alias:[[],_Left,"LEFT"] - (Motion(fun s i -> i#backward_char, { s with move = None })); - mkE ~mods:mM _f "f" "Forward word" ~alias:[mC,_Right,"RIGHT"] - (Motion(fun s i -> i#forward_word_end, { s with move = None })); - mkE ~mods:mM _b "b" "Backward word" ~alias:[mC,_Left,"LEFT"] - (Motion(fun s i -> i#backward_word_start, { s with move = None })); - mkE _space "SPC" "Set mark" ~alias:[mC,_at,"@"] (Motion(fun s i -> - if s.sel = false then i, { s with sel = true } - else i, { s with sel = false } )); - (* edits *) - mkE ~mods:mM _w "w" "Copy selected region" (Edit(fun s b i run -> - if sel_nonempty b then - let txt = get_sel_txt b in - run "Edit" "Copy"; - { s with kill = Some(txt,false); sel = false } - else s)); - mkE _w "w" "Kill selected region" (Edit(fun s b i run -> - if sel_nonempty b then - let txt = get_sel_txt b in - run "Edit" "Cut"; - { s with kill = Some(txt,false); sel = false } - else s)); - mkE _k "k" "Kill until the end of line" (Edit(fun s b i _ -> - let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in - let k = - if i#ends_line then begin - b#delete ~start:i ~stop:i#forward_char; "\n" - end else begin - let k = b#get_text ~start:i ~stop:i#forward_to_line_end () in - b#delete ~start:i ~stop:i#forward_to_line_end; k - end in - { s with kill = Some (already_killed ^ k,true) })); - mkE ~mods:mM _d "d" "Kill next word" (Edit(fun s b i _ -> - let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in - let k = - let k = b#get_text ~start:i ~stop:i#forward_word_end () in - b#delete ~start:i ~stop:i#forward_word_end; k in - { s with kill = Some (already_killed ^ k,true) })); - mkE ~mods:mM _k "k" "Kill until sentence end" (Edit(fun s b i _ -> - let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in - let k = - let k = b#get_text ~start:i ~stop:i#forward_sentence_end () in - b#delete ~start:i ~stop:i#forward_sentence_end; k in - { s with kill = Some (already_killed ^ k,true) })); - mkE ~mods:mM _BackSpace "DELBACK" "Kill word before cursor" - (Edit(fun s b i _ -> - let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in - let k = - let k = b#get_text ~start:i ~stop:i#backward_word_start () in - b#delete ~start:i ~stop:i#backward_word_start; k in - { s with kill = Some (already_killed ^ k,true) })); - mkE _d "d" "Delete next character" (Edit(fun s b i _ -> - b#delete ~start:i ~stop:i#forward_char; s)); - mkE _y "y" "Yank killed text back " (Edit(fun s b i _ -> - let k, s = match s.kill with - | Some (k,_) -> k, { s with kill = Some (k,false) } - | _ -> "", s in - b#insert ~iter:i k; - s)); - (* misc *) - mkE _underscore "_" "Undo" (Action("Edit", "Undo")); - mkE _g "g" "Esc" (Callback(fun gui -> (ct gui).finder#hide ())); - mkE _s "s" "Search" (Callback(fun gui -> - if (ct gui).finder#coerce#misc#visible - then run_action gui "Edit" "Find Next" - else run_action gui "Edit" "Find")); - mkE _s "r" "Search backward" (Callback(fun gui -> - if (ct gui).finder#coerce#misc#visible - then run_action gui "Edit" "Find Previous" - else run_action gui "Edit" "Find")); - ] - -let emacs = insert emacs "Emacs" [mC,_x,"x"] [ - mkE _s "s" "Save" (Action("File", "Save")); - mkE _c "c" "Quit" (Action("File", "Quit")); - mkE _f "f" "Open" (Action("File", "Open")); - mkE ~mods:[] _u "u" "Undo" (Action("Edit", "Undo")); - ] - -let pg = insert emacs "Proof General" [mC,_c,"c"] [ - mkE _Return "RET" "Go to" (Action("Navigation", "Go to")); - mkE _n "n" "Advance 1 sentence" (Action("Navigation", "Forward")); - mkE _u "u" "Retract 1 sentence" (Action("Navigation", "Backward")); - mkE _b "b" "Advance" (Action("Navigation", "End")); - mkE _r "r" "Restart" (Action("Navigation", "Start")); - mkE _c "c" "Stop" (Action("Navigation", "Interrupt")); - ] - -let command gui c = - let command = (ct gui).command in - let script = (ct gui).script in - let term = - let i, j = script#source_buffer#selection_bounds in - if i#equal j then None - else Some (script#buffer#get_text ~start:i ~stop:j ()) in - command#show; - command#new_query ~command:c ?term () - -let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [ - mkE _p "p" "Print" (Callback (fun gui -> command gui "Print")); - mkE _c "c" "Check" (Callback (fun gui -> command gui "Check")); - mkE _b "b" "About" (Callback (fun gui -> command gui "About")); - mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout")); - mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern")); - mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate")); - mkE _Return "RET" "match template" (Action("Templates","match")); - ] - -let empty = { sel = false; kill = None; move = None } - -let find gui (Step(here,konts)) t = - (* hack: ^c does copy in clipboard *) - let sel_nonempty () = sel_nonempty (ct gui).script#source_buffer in - let k = GdkEvent.Key.keyval t in - if k = _x && mod_of t mC && sel_nonempty () then - ignore(run t gui (Action("Edit","Cut")) empty) - else - if k = _c && mod_of t mC && sel_nonempty () then - ignore(run t gui (Action("Edit","Copy")) empty); - let cmp { key; mods } = key = k && mod_of t mods in - try `Do (List.find cmp here) with Not_found -> - try `Cont (List.find cmp konts).contents with Not_found -> `NotFound - -let init w nb ags = - let gui = { notebook = nb; action_groups = ags } in - let cur = ref pg in - let status = ref empty in - let reset () = eprintf "reset\n%!"; cur := pg in - ignore(w#event#connect#key_press ~callback:(fun t -> - let on_current_term f = - let term = try Some nb#current_term with Invalid_argument _ -> None in - match term with None -> false | Some t -> f t - in - on_current_term (fun x -> - if x.script#misc#get_property "has-focus" <> `BOOL true - then false - else begin - eprintf "got key %s\n%!" (pr_key t); - if nanoPG#get then begin - match find gui !cur t with - | `Do e -> - eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status); - status := run t gui e.contents !status; reset (); true - | `Cont c -> - flash_info ("Waiting one of " ^ String.concat " " (frontier c)); - cur := c; true - | `NotFound -> reset (); false - end else false - end))); - ignore(w#event#connect#button_press ~callback:(fun t -> reset (); false)) - - - -let get_documentation () = - "Chars, words, lines and sentences below pertain to standard unicode segmentation rules\n" ^ - print_keypaths pg diff --git a/ide/nanoPG.mli b/ide/nanoPG.mli deleted file mode 100644 index bc9b39d823..0000000000 --- a/ide/nanoPG.mli +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* string -val init : GWindow.window -> Session.session Wg_Notebook.typed_notebook -> - GAction.action_group list -> unit diff --git a/ide/preferences.ml b/ide/preferences.ml index 3893d023bd..4e2e3f31e6 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -561,7 +561,8 @@ let tab_length = let highlight_current_line = new preference ~name:["highlight_current_line"] ~init:false ~repr:Repr.(bool) -let nanoPG = +let microPG = + (* Legacy name in preference is "nanoPG" *) new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool) let user_queries = @@ -799,7 +800,7 @@ let configure ?(apply=(fun () -> ())) parent = let () = button "Show progress bar" show_progress_bar in let () = button "Insert spaces instead of tabs" spaces_instead_of_tabs in let () = button "Highlight current line" highlight_current_line in - let () = button "Emacs/PG keybindings (μPG mode)" nanoPG in + let () = button "Emacs/PG keybindings (μPG mode)" microPG in let callback () = () in custom ~label box callback true in diff --git a/ide/preferences.mli b/ide/preferences.mli index 785c191b46..b01c4598d8 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -102,7 +102,7 @@ val show_progress_bar : bool preference val spaces_instead_of_tabs : bool preference val tab_length : int preference val highlight_current_line : bool preference -val nanoPG : bool preference +val microPG : bool preference val user_queries : (string * string) list preference val diffs : string preference -- cgit v1.2.3 From d9a975352e5982602d3315facfa005ea40b16bcb Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 30 Apr 2019 21:48:34 +0200 Subject: Remove leftover test suite file Quote.out --- test-suite/output/Quote.out | 24 ------------------------ 1 file changed, 24 deletions(-) delete mode 100644 test-suite/output/Quote.out diff --git a/test-suite/output/Quote.out b/test-suite/output/Quote.out deleted file mode 100644 index 998eb37cc8..0000000000 --- a/test-suite/output/Quote.out +++ /dev/null @@ -1,24 +0,0 @@ -(interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx)) -(interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) - (f_and (f_const A) - (f_and (f_or (f_atom End_idx) (f_const A)) - (f_or (f_const A) (f_not (f_atom End_idx)))))) -1 subgoal - - H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ - B - ============================ - interp_f - (Node_vm B (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (Empty_vm Prop)) - (f_and (f_atom (Left_idx End_idx)) - (f_and (f_or (f_atom End_idx) (f_atom (Left_idx End_idx))) - (f_or (f_atom (Left_idx End_idx)) (f_not (f_atom End_idx))))) -1 subgoal - - H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ - B - ============================ - interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) - (f_and (f_const A) - (f_and (f_or (f_atom End_idx) (f_const A)) - (f_or (f_const A) (f_not (f_atom End_idx))))) -- cgit v1.2.3 From 708df3d3ebe5c6cf7c8b085beea986566fdab094 Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Tue, 30 Apr 2019 13:24:47 -0700 Subject: Remove the k0 argument from pretype functions. This was introduced by @herbelin in 817308ab59daa40bef09838cfc3d810863de0e46, appears to have been made unnecessary again by herbelin in 4dab4fc5b2c20e9b7db88aec25a920b56ac83cb6. At this point it appears to be completely unused. --- pretyping/pretyping.ml | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 48d981082c..f2b8671a48 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -380,7 +380,7 @@ let orelse_name name name' = match name with | Anonymous -> name' | _ -> name -let pretype_id pretype k0 loc env sigma id = +let pretype_id pretype loc env sigma id = (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context !!env) in @@ -475,10 +475,10 @@ let mark_obligation_evar sigma k evc = (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = +let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in - let pretype = pretype ~program_mode ~poly k0 resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly resolve_tc in + let pretype = pretype ~program_mode ~poly resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -487,7 +487,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) loc env sigma id in inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> @@ -498,7 +498,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -984,7 +984,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -1016,7 +1016,7 @@ and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk up let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode ~poly resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1041,7 +1041,7 @@ and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk up sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1068,7 +1068,7 @@ and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigm let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1088,16 +1088,15 @@ let ise_pretype_gen flags env sigma lvar kind c = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let env = GlobEnv.make ~hypnaming env sigma lvar in - let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) -- cgit v1.2.3 From 77257819ea4a381067e65fd46e7d7590aa7e2600 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Thu, 11 Apr 2019 12:45:07 +0200 Subject: Remove Global.env from goptions by passing from vernacentries Currently this env is only used to error for Printing If/Let on non-2-constructor/non-1-constructor types so we could alternatively remove it and not error / error later when trying to print. Keeping the env and the error as-is should be fine though. --- library/goptions.ml | 32 +++++++++++++++----------------- library/goptions.mli | 22 ++++++++++------------ vernac/vernacentries.ml | 16 ++++++++-------- 3 files changed, 33 insertions(+), 37 deletions(-) diff --git a/library/goptions.ml b/library/goptions.ml index b9c1802a72..f4b8ce9465 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -42,13 +42,12 @@ let error_undeclared_key key = (****************************************************************************) (* 1- Tables *) -class type ['a] table_of_A = -object - method add : 'a -> unit - method remove : 'a -> unit - method mem : 'a -> unit - method print : unit -end +type 'a table_of_A = { + add : Environ.env -> 'a -> unit; + remove : Environ.env -> 'a -> unit; + mem : Environ.env -> 'a -> unit; + print : unit -> unit; +} module MakeTable = functor @@ -109,18 +108,17 @@ module MakeTable = (fun a b -> spc () ++ printer a ++ b) table (mt ()) ++ str "." ++ fnl ()))) - class table_of_A () = - object - method add x = add_option (A.encode (Global.env()) x) - method remove x = remove_option (A.encode (Global.env()) x) - method mem x = - let y = A.encode (Global.env()) x in + let table_of_A = { + add = (fun env x -> add_option (A.encode env x)); + remove = (fun env x -> remove_option (A.encode env x)); + mem = (fun env x -> + let y = A.encode env x in let answer = MySet.mem y !t in - Feedback.msg_info (A.member_message y answer) - method print = print_table A.title A.printer !t - end + Feedback.msg_info (A.member_message y answer)); + print = (fun () -> print_table A.title A.printer !t); + } - let _ = A.table := (nick,new table_of_A ())::!A.table + let _ = A.table := (nick, table_of_A)::!A.table let active c = MySet.mem c !t let elements () = MySet.elements !t end diff --git a/library/goptions.mli b/library/goptions.mli index 2e593e9d9e..381ba4d34a 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -76,7 +76,7 @@ end (** The functor [MakeRefTable] declares a new table of objects of type [A.t] practically denoted by [reference]; the encoding function - [encode : reference -> A.t] is typically a globalization function, + [encode : env -> reference -> A.t] is typically a globalization function, possibly with some restriction checks; the function [member_message] say what to print when invoking the "Test Toto Titi foo." command; at the end [title] is the table name printed @@ -139,19 +139,17 @@ val declare_bool_option_and_ref : depr:bool -> name:string -> key:option_name -> module OptionMap : CSig.MapS with type key = option_name -val get_string_table : - option_name -> - < add : string -> unit; - remove : string -> unit; - mem : string -> unit; - print : unit > +type 'a table_of_A = { + add : Environ.env -> 'a -> unit; + remove : Environ.env -> 'a -> unit; + mem : Environ.env -> 'a -> unit; + print : unit -> unit; +} +val get_string_table : + option_name -> string table_of_A val get_ref_table : - option_name -> - < add : qualid -> unit; - remove : qualid -> unit; - mem : qualid -> unit; - print : unit > + option_name -> qualid table_of_A (** The first argument is a locality flag. *) val set_int_option_value_gen : ?locality:option_locality -> option_name -> int option -> unit diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e44d68b87d..fa170e4104 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1732,29 +1732,29 @@ let vernac_set_option ~local export table v = match v with let vernac_add_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#add s - | QualidRefValue locqid -> (get_ref_table key)#add locqid + | StringRefValue s -> (get_string_table key).add (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).add (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_remove_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#remove s - | QualidRefValue locqid -> (get_ref_table key)#remove locqid + | StringRefValue s -> (get_string_table key).remove (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).remove (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_mem_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#mem s - | QualidRefValue locqid -> (get_ref_table key)#mem locqid + | StringRefValue s -> (get_string_table key).mem (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).mem (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_print_option key = - try (get_ref_table key)#print + try (get_ref_table key).print () with Not_found -> - try (get_string_table key)#print + try (get_string_table key).print () with Not_found -> try print_option_value key with Not_found -> error_undeclared_key key -- cgit v1.2.3 From ba5ea9fb6aaa3faace0960adca4d41fc74cb2ac7 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 1 May 2019 08:28:57 +0200 Subject: [comDefinition] Use prepare function from DeclareDef. We also update the plugin tutorial. This was already tried [in the same exact way] in #8811, however the bench time was not convincing then, but now things seem a bit better, likely due to the removal of some extra normalization somewhere. Some more changes from #8811 are still pending. --- doc/plugin_tutorial/tuto1/src/simple_declare.ml | 13 ++--------- vernac/comDefinition.ml | 31 ++++++++----------------- 2 files changed, 12 insertions(+), 32 deletions(-) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 23f8fbe888..3c0355c92d 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,17 +1,8 @@ -(* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = - let sigma = Evd.minimize_universes sigma in - let body = EConstr.to_constr sigma body in - let tyopt = Option.map (EConstr.to_constr sigma) tyopt in - let uvars_fold uvars c = - Univ.LSet.union uvars (Vars.universes_of_constr c) in - let uvars = List.fold_left uvars_fold Univ.LSet.empty - (Option.List.cons tyopt [body]) in - let sigma = Evd.restrict_universe_context sigma uvars in - let univs = Evd.check_univ_decl ~poly sigma udecl in + let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false + ~opaque ~poly sigma udecl ~types:tyopt ~body in let uctx = Evd.evar_universe_context sigma in let ubinders = Evd.universe_binders sigma in - let ce = Declare.definition_entry ?types:tyopt ~univs body in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index feaf47df18..12df3215ad 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -12,7 +12,6 @@ open Pp open Util open Entries open Redexpr -open Declare open Constrintern open Pretyping @@ -42,10 +41,9 @@ let check_imps ~impsty ~impsbody = if not b then warn_implicits_in_term () let interp_definition ~program_mode pl bl poly red_option c ctypopt = - let open EConstr in let env = Global.env() in (* Explicitly bound universes and constraints *) - let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in + let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) @@ -66,24 +64,15 @@ let interp_definition ~program_mode pl bl poly red_option c ctypopt = in (* Do the reduction *) let evd, c = red_constant_body red_option env_bl evd c in - (* universe minimization *) - let evd = Evd.minimize_universes evd in - (* Substitute evars and universes, and add parameters. - Note: in program mode some evars may remain. *) - let ctx = List.map Termops.(map_rel_decl (to_constr ~abort_on_undefined_evars:false evd)) ctx in - let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd c) ctx in - let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd ty) ctx) tyopt in - (* Keep only useful universes. *) - let uvars_fold uvars c = - Univ.LSet.union uvars (universes_of_constr evd (of_constr c)) - in - let uvars = List.fold_left uvars_fold Univ.LSet.empty (Option.List.cons tyopt [c]) in - let evd = Evd.restrict_universe_context evd uvars in - (* Check we conform to declared universes *) - let uctx = Evd.check_univ_decl ~poly evd decl in - (* We're done! *) - let ce = definition_entry ?types:tyopt ~univs:uctx c in - (ce, evd, decl, imps) + + (* Declare the definition *) + let c = EConstr.it_mkLambda_or_LetIn c ctx in + let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + + let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode + ~opaque:false ~poly evd udecl ~types:tyopt ~body:c in + + (ce, evd, udecl, imps) let check_definition ~program_mode (ce, evd, _, imps) = let env = Global.env () in -- cgit v1.2.3 From 75dace920133e147abd6463645068b52f431a690 Mon Sep 17 00:00:00 2001 From: Oliver Nash Date: Wed, 24 Apr 2019 12:23:20 +0100 Subject: Add PairUsualDecidableTypeFull A module allowing the user to build a UsualDecidableTypeFull from a pair of such, exactly analogous to the extant PairDecidableType and PairUsualDecidableType modules. Co-authored-by: Jean-Christophe Léchenet --- CHANGES.md | 2 ++ theories/Structures/EqualitiesFacts.v | 11 +++++++++++ 2 files changed, 13 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 3c8070d585..5ca16ae1fe 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -45,6 +45,8 @@ Unreleased changes **Standard library** +- Added Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull + **Infrastructure and dependencies** diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index c738b57f44..0f63855b55 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -212,3 +212,14 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Defined. End PairUsualDecidableType. + +(** And also for pairs of UsualDecidableTypeFull *) + +Module PairUsualDecidableTypeFull (D1 D2:UsualDecidableTypeFull) + <: UsualDecidableTypeFull. + + Module M := PairUsualDecidableType D1 D2. + Include Backport_DT (M). + Include HasEqDec2Bool. + +End PairUsualDecidableTypeFull. -- cgit v1.2.3 From a154a824f96a010acc00bedede888dc894ace2e7 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Thu, 2 May 2019 09:43:19 +0200 Subject: [opam] [dune] Fix opam build by correctly setting prefix. The OPAM build has been broken it seems since almost the beginning as OPAM doesn't substitute variables in the almost undocumented `build-env` form. Packages built this way worked as Coq used a different method to locate `coqlib`, however the value for `coqlib` was incorrect. We set instead the right prefix using an explicit configure call. --- coq.opam | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/coq.opam b/coq.opam index da3f1b518d..05b20e08b6 100644 --- a/coq.opam +++ b/coq.opam @@ -25,11 +25,8 @@ depends: [ "num" ] -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] -] - build: [ + [ "./configure" "-prefix" prefix "-native-compiler" "no" ] [ "dune" "build" "@vodeps" ] [ "dune" "exec" "coq_dune" "_build/default/.vfiles.d" ] [ "dune" "build" "-p" name "-j" jobs ] -- cgit v1.2.3 From 680facebace8718f651d6c46167359cebc85a8a4 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 2 May 2019 08:00:01 +0000 Subject: [CI/Azure/macOS] Fix install of OCaml through OPAM --- azure-pipelines.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index f09087b172..f2cec1eb19 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -59,8 +59,8 @@ jobs: - script: | set -e export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - opam init -a -j "$NJOBS" --compiler=$COMPILER - opam switch set $COMPILER + opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER + opam switch set ocaml-base-compiler.$COMPILER eval $(opam env) opam update opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 -- cgit v1.2.3 From ef0ef9f318a0af6542835b71ce7aaced021fff6d Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 24 Apr 2019 21:10:30 +0200 Subject: Document typeclasses_eauto --- tactics/class_tactics.mli | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index c950e3de3d..2d8b07b083 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -27,9 +27,18 @@ type search_strategy = Dfs | Bfs val set_typeclasses_strategy : search_strategy -> unit -val typeclasses_eauto : ?only_classes:bool -> ?st:TransparentState.t -> ?strategy:search_strategy -> - depth:(Int.t option) -> - Hints.hint_db_name list -> unit Proofview.tactic +val typeclasses_eauto : + ?only_classes:bool + (** Should non-class goals be shelved and resolved at the end *) + -> ?st:TransparentState.t + (** The transparent_state used when working with local hypotheses *) + -> ?strategy:search_strategy + (** Is a traversing-strategy specified? *) + -> depth:(Int.t option) + (** Bounded or unbounded search *) + -> Hints.hint_db_name list + (** The list of hint databases to use *) + -> unit Proofview.tactic val head_of_constr : Id.t -> constr -> unit Proofview.tactic -- cgit v1.2.3 From 016ed06128372e7b767efd4d3e1f71df9ca1e3d4 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 25 Apr 2019 10:32:39 +0200 Subject: Add union in Map interface --- clib/cSig.mli | 2 ++ clib/hMap.ml | 8 ++++++++ engine/uState.ml | 2 +- engine/univMinim.ml | 2 +- kernel/univ.ml | 17 +++++++---------- kernel/univ.mli | 4 ++-- 6 files changed, 21 insertions(+), 14 deletions(-) diff --git a/clib/cSig.mli b/clib/cSig.mli index 859018ca4b..0012bcef17 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -68,6 +68,8 @@ sig val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val union: + (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit diff --git a/clib/hMap.ml b/clib/hMap.ml index 09ffb39c21..db59ef47b0 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -290,6 +290,14 @@ struct in Int.Map.merge fm s1 s2 + let union f s1 s2 = + let fm h m1 m2 = + let m = Map.union f m1 m2 in + if Map.is_empty m then None + else Some m + in + Int.Map.union fm s1 s2 + let compare f s1 s2 = let fc m1 m2 = Map.compare f m1 m2 in Int.Map.compare fc s1 s2 diff --git a/engine/uState.ml b/engine/uState.ml index 6f4f40e2c5..aa14f66df6 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -85,7 +85,7 @@ let union ctx ctx' = let declarenew g = LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in - let names_rev = LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + let names_rev = LMap.lunion (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 46ff6340b4..fcbf305f9d 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -203,7 +203,7 @@ let minimize_univ_variables ctx us algs left right cstrs = (acc, [], LMap.empty, LMap.empty) l in let left = CList.uniquize (List.filter (not_lower lower) left) in - (acc, left, LMap.union newlow lower) + (acc, left, LMap.lunion newlow lower) in let instantiate_lbound lbound = let alg = LSet.mem u algs in diff --git a/kernel/univ.ml b/kernel/univ.ml index 8263c68bf5..b1bbc25fe6 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -231,18 +231,15 @@ module LMap = struct module M = HMap.Make (Level) include M - let union l r = - merge (fun _k l r -> - match l, r with - | Some _, _ -> l - | _, _ -> r) l r + let lunion l r = + union (fun _k l _r -> Some l) l r - let subst_union l r = - merge (fun _k l r -> + let subst_union l r = + union (fun _k l r -> match l, r with - | Some (Some _), _ -> l - | Some None, None -> l - | _, _ -> r) l r + | Some _, _ -> Some l + | None, None -> Some l + | _, _ -> Some r) l r let diff ext orig = fold (fun u v acc -> diff --git a/kernel/univ.mli b/kernel/univ.mli index 5543c35741..db178c4bb0 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -223,8 +223,8 @@ module LMap : sig include CMap.ExtS with type key = Level.t and module Set := LSet - val union : 'a t -> 'a t -> 'a t - (** [union x y] favors the bindings in the first map. *) + val lunion : 'a t -> 'a t -> 'a t + (** [lunion x y] favors the bindings in the first map. *) val diff : 'a t -> 'a t -> 'a t (** [diff x y] removes bindings from x that appear in y (whatever the value). *) -- cgit v1.2.3 From f947e80e029df35f31f065bede9f84fe20e1606b Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 25 Apr 2019 10:33:53 +0200 Subject: Use GlobRef.Map.t in hint databases --- tactics/hints.ml | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/tactics/hints.ml b/tactics/hints.ml index 11a8816159..efb7e66965 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -289,8 +289,6 @@ let lookup_tacs sigma concl st se = let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' -module Constr_map = Map.Make(GlobRef.Ordered) - let is_transparent_gr ts = function | VarRef id -> TransparentState.is_transparent_variable ts id | ConstRef cst -> TransparentState.is_transparent_constant ts cst @@ -532,7 +530,7 @@ struct hintdb_unfolds : Id.Set.t * Cset.t; hintdb_max_id : int; use_dn : bool; - hintdb_map : search_entry Constr_map.t; + hintdb_map : search_entry GlobRef.Map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) hintdb_nopat : (GlobRef.t option * stored_data) list; @@ -548,12 +546,12 @@ struct hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; - hintdb_map = Constr_map.empty; + hintdb_map = GlobRef.Map.empty; hintdb_nopat = []; hintdb_name = name; } let find key db = - try Constr_map.find key db.hintdb_map + try GlobRef.Map.find key db.hintdb_map with Not_found -> empty_se let realize_tac secvars (id,tac) = @@ -650,11 +648,11 @@ struct else db | Some gr -> let oval = find gr db in - { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = - { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; + { db with hintdb_map = GlobRef.Map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat @@ -693,7 +691,7 @@ struct let remove_list grs db = let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in - let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in + let hintmap = GlobRef.Map.map (remove_he db.hintdb_state filter) db.hintdb_map in let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } @@ -706,11 +704,11 @@ struct let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); - Constr_map.iter iter_se db.hintdb_map + GlobRef.Map.iter iter_se db.hintdb_map let fold f db accu = let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in - Constr_map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu + GlobRef.Map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu let transparent_state db = db.hintdb_state @@ -724,7 +722,7 @@ struct let add_mode gr m db = let se = find gr db in let se = { se with sentry_mode = m :: se.sentry_mode } in - { db with hintdb_map = Constr_map.add gr se db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr se db.hintdb_map } let cut db = db.hintdb_cut -- cgit v1.2.3 From 321d26480444c947ffdaaf849157fd373e40c988 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 25 Apr 2019 10:36:21 +0200 Subject: Fix #5752: `Hint Mode` ignored for type classes that appear as assumptions The creation of the local hint db now inherits the union of the modes from the dbs passed to `typeclasses eauto`. We could probably go further and define in a more systematic way the metadata that should be inherited. A lot of this code could also be cleaned-up by defining the merge of databases, so that the search code is parametrized by just one db (the merge of the input ones). --- CHANGES.md | 1 + doc/sphinx/addendum/type-classes.rst | 2 ++ tactics/class_tactics.ml | 56 ++++++++++++++++++++---------------- tactics/class_tactics.mli | 4 +-- tactics/hints.ml | 11 +++++++ tactics/hints.mli | 3 ++ 6 files changed, 51 insertions(+), 26 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 3c8070d585..fda77930ab 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -18,6 +18,7 @@ Unreleased changes **Tactic language** +- Modes are now taken into account by `typeclasses eauto` for local hypotheses. **SSReflect** diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index a5e9023732..77a6ee79cc 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -405,6 +405,8 @@ few other commands related to typeclasses. resolution with the local hypotheses use full conversion during unification. + + When considering local hypotheses, we use the union of all the modes + declared in the given databases. .. cmdv:: typeclasses eauto @num diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c1ac7d201a..575c1dba46 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -548,7 +548,7 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = make_apply_entry ~name env sigma flags pri false]) else [] -let make_hints g st only_classes sign = +let make_hints g (modes,st) only_classes sign = let hintlist = List.fold_left (fun hints hyp -> @@ -565,7 +565,9 @@ let make_hints g st only_classes sign = in hint @ hints else hints) ([]) sign - in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) + in + let db = Hint_db.add_modes modes @@ Hint_db.empty st true in + Hint_db.add_list (pf_env g) (project g) hintlist db module Search = struct type autoinfo = @@ -578,29 +580,29 @@ module Search = struct (** Local hints *) let autogoal_cache = Summary.ref ~name:"autogoal_cache" - (DirPath.empty, true, Context.Named.empty, + (DirPath.empty, true, Context.Named.empty, GlobRef.Map.empty, Hint_db.empty TransparentState.full true) - let make_autogoal_hints only_classes ?(st=TransparentState.full) g = + let make_autogoal_hints only_classes (modes,st as mst) g = let open Proofview in let open Tacmach.New in let sign = Goal.hyps g in - let (dir, onlyc, sign', cached_hints) = !autogoal_cache in + let (dir, onlyc, sign', cached_modes, cached_hints) = !autogoal_cache in let cwd = Lib.cwd () in let eq c1 c2 = EConstr.eq_constr (project g) c1 c2 in if DirPath.equal cwd dir && (onlyc == only_classes) && Context.Named.equal eq sign sign' && - Hint_db.transparent_state cached_hints == st + cached_modes == modes then cached_hints else let hints = make_hints {it = Goal.goal g; sigma = project g} - st only_classes sign + mst only_classes sign in - autogoal_cache := (cwd, only_classes, sign, hints); hints + autogoal_cache := (cwd, only_classes, sign, modes, hints); hints - let make_autogoal ?(st=TransparentState.full) only_classes dep cut i g = - let hints = make_autogoal_hints only_classes ~st g in + let make_autogoal mst only_classes dep cut i g = + let hints = make_autogoal_hints only_classes mst g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); search_dep = dep; @@ -695,7 +697,8 @@ module Search = struct if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in - make_autogoal_hints info.search_only_classes ~st gl' + let modes = Hint_db.modes info.search_hints in + make_autogoal_hints info.search_only_classes (modes,st) gl' else info.search_hints in let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal gl') gls in @@ -830,19 +833,19 @@ module Search = struct (fun e' -> let (e, info) = merge_exceptions e e' in Proofview.tclZERO ~info e)) - let search_tac_gl ?st only_classes dep hints depth i sigma gls gl : + let search_tac_gl mst only_classes dep hints depth i sigma gls gl : unit Proofview.tactic = let open Proofview in let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in - let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in + let info = make_autogoal mst only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info - let search_tac ?(st=TransparentState.full) only_classes dep hints depth = + let search_tac mst only_classes dep hints depth = let open Proofview in let tac sigma gls i = Goal.enter begin fun gl -> - search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl end + search_tac_gl mst only_classes dep hints depth (succ i) sigma gls gl end in Proofview.Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in @@ -867,11 +870,11 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac ?(st=TransparentState.full) ?(unique=false) + let eauto_tac mst ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = - let search = search_tac ~st only_classes dep hints in + let search = search_tac mst only_classes dep hints in let dfs = match strategy with | None -> not (get_typeclasses_iterative_deepening ()) @@ -915,8 +918,8 @@ module Search = struct | Some i -> str ", with depth limit " ++ int i)); tac - let eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints = - Hints.wrap_hint_warning @@ eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints + let eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints = + Hints.wrap_hint_warning @@ eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints let run_on_evars env evm p tac = match evars_to_goals p evm with @@ -968,8 +971,8 @@ module Search = struct else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found - let evars_eauto env evd depth only_classes unique dep st hints p = - let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let evars_eauto env evd depth only_classes unique dep mst hints p = + let eauto_tac = eauto_tac mst ~unique ~only_classes ~depth ~dep:(unique || dep) hints in let res = run_on_evars env evd p eauto_tac in match res with | None -> evd @@ -983,7 +986,9 @@ module Search = struct let typeclasses_resolve env evd debug depth unique p = let db = searchtable_map typeclasses_db in - typeclasses_eauto env evd ?depth unique (Hint_db.transparent_state db) [db] p + let st = Hint_db.transparent_state db in + let modes = Hint_db.modes db in + typeclasses_eauto env evd ?depth unique (modes,st) [db] p end (** Binding to either V85 or Search implementations. *) @@ -996,8 +1001,10 @@ let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) dbs in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + let modes = List.map Hint_db.modes dbs in + let modes = List.fold_left (GlobRef.Map.union (fun _ m1 m2 -> Some (m1@m2))) GlobRef.Map.empty modes in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in - Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs + Search.eauto_tac (modes,st) ~only_classes ?strategy ~depth ~dep:true dbs (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, @@ -1140,11 +1147,12 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in + let modes = Hint_db.modes hints in let depth = get_typeclasses_depth () in let gls' = try Proofview.V82.of_tactic - (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls + (Search.eauto_tac (modes,st) ~only_classes:true ~depth [hints] ~dep:true) gls with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 2d8b07b083..b9291f6124 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -50,8 +50,8 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:TransparentState.t - (** The transparent_state used when working with local hypotheses *) + Hints.hint_mode array list GlobRef.Map.t * TransparentState.t + (** The transparent_state and modes used when working with local hypotheses *) -> ?unique:bool (** Should we force a unique solution *) -> only_classes:bool diff --git a/tactics/hints.ml b/tactics/hints.ml index efb7e66965..cc56c1c425 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -518,6 +518,8 @@ val add_cut : hints_path -> t -> t val add_mode : GlobRef.t -> hint_mode array -> t -> t val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t +val add_modes : hint_mode array list GlobRef.Map.t -> t -> t +val modes : t -> hint_mode array list GlobRef.Map.t val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a @@ -728,6 +730,15 @@ struct let unfolds db = db.hintdb_unfolds + let add_modes modes db = + let f gr e me = + Some { e with sentry_mode = me.sentry_mode @ e.sentry_mode } + in + let mode_entries = GlobRef.Map.map (fun m -> { empty_se with sentry_mode = m }) modes in + { db with hintdb_map = GlobRef.Map.union f db.hintdb_map mode_entries } + + let modes db = GlobRef.Map.map (fun se -> se.sentry_mode) db.hintdb_map + let use_dn db = db.use_dn end diff --git a/tactics/hints.mli b/tactics/hints.mli index 90a8b7fe52..7b8f96cdd8 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -162,6 +162,9 @@ module Hint_db : val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t + + val add_modes : hint_mode array list GlobRef.Map.t -> t -> t + val modes : t -> hint_mode array list GlobRef.Map.t end type hint_db = Hint_db.t -- cgit v1.2.3 From afb58502f900554986aeee9a749871630f117edd Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 25 Apr 2019 10:44:56 +0200 Subject: Test case for #5752 --- test-suite/bugs/closed/bug_5752.v | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 test-suite/bugs/closed/bug_5752.v diff --git a/test-suite/bugs/closed/bug_5752.v b/test-suite/bugs/closed/bug_5752.v new file mode 100644 index 0000000000..b4218d66df --- /dev/null +++ b/test-suite/bugs/closed/bug_5752.v @@ -0,0 +1,8 @@ +Class C (A : Type) := c : A. + +Hint Mode C ! : typeclass_instances. + +Goal forall f : (forall A, C A -> C (list A)), True. +intros. + Check c. (* Loops if modes are ignored. *) +Abort. -- cgit v1.2.3 From 48b86574606b9500864a79ddc6a0a668e1aaf295 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 26 Apr 2019 09:41:04 +0200 Subject: Remove outdated comment --- tactics/class_tactics.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 575c1dba46..160e4f164e 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -991,8 +991,6 @@ module Search = struct typeclasses_eauto env evd ?depth unique (modes,st) [db] p end -(** Binding to either V85 or Search implementations. *) - let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) ?strategy ~depth dbs = let dbs = List.map_filter -- cgit v1.2.3 From 70e01149ad4c74d086f042f0cced74b1d0e228bf Mon Sep 17 00:00:00 2001 From: Paolo G. Giarrusso Date: Sat, 27 Apr 2019 16:11:05 +0200 Subject: Document _no_check tactics (#3225) Triggered by trying to understand https://gitlab.mpi-sws.org/iris/iris/merge_requests/235. - Add a new section at the end - Document change_no_check, and convert_concl_no_check, address review comments --- doc/sphinx/proof-engine/tactics.rst | 80 +++++++++++++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 8d9e99b9d5..02a0867341 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -4811,3 +4811,83 @@ references to automatically generated names. :name: Mangle Names Prefix Specifies the prefix to use when generating names. + +Performance-oriented tactic variants +------------------------------------ + +.. tacn:: change_no_check @term + :name: change_no_check + + For advanced usage. Similar to :n:`change @term`, but as an optimization, + it skips checking that :n:`@term` is convertible to the goal. + + Recall the Coq kernel typechecks proofs again when they are concluded to + ensure safety. Hence, using :tacn:`change` checks convertibility twice + overall, while :tacn:`convert_concl_no_check` can produce ill-typed terms, + but checks convertibility only once. + Hence, :tacn:`convert_concl_no_check` can be useful to speed up certain proof + scripts, especially if one knows by construction that the argument is + indeed convertible to the goal. + + In the following example, :tacn:`convert_concl_no_check` replaces :g:`False` by + :g:`True`, but :g:`Qed` then rejects the proof, ensuring consistency. + + .. example:: + + .. coqtop:: all abort + + Goal False. + change_no_check True. + exact I. + Fail Qed. + + .. tacv:: convert_concl_no_check @term + :name: convert_concl_no_check + + Deprecated old name for :tacn:`change_no_check`. Does not support any of its + variants. + +.. tacn:: exact_no_check @term + :name: exact_no_check + + For advanced usage. Similar to :n:`exact @term`, but as an optimization, + it skips checking that :n:`@term` has the goal's type, relying on the kernel + check instead. See :tacn:`convert_concl_no_check` for more explanations. + + .. example:: + + .. coqtop:: all abort + + Goal False. + exact_no_check I. + Fail Qed. + + .. tacv:: vm_cast_no_check @term + :name: vm_cast_no_check + + For advanced usage. Similar to :n:`exact_no_check @term`, but additionally + instructs the kernel to use :tacn:`vm_compute` to compare the + goal's type with the :n:`@term`'s type. + + .. example:: + + .. coqtop:: all abort + + Goal False. + vm_cast_no_check I. + Fail Qed. + + .. tacv:: native_cast_no_check @term + :name: native_cast_no_check + + for advanced usage. similar to :n:`exact_no_check @term`, but additionally + instructs the kernel to use :tacn:`native_compute` to compare the goal's + type with the :n:`@term`'s type. + + .. example:: + + .. coqtop:: all abort + + Goal False. + native_cast_no_check I. + Fail Qed. -- cgit v1.2.3 From 590ee35546f3528ac7ccb32306fb86e78fdce93b Mon Sep 17 00:00:00 2001 From: Paolo G. Giarrusso Date: Fri, 3 May 2019 01:13:48 +0200 Subject: Documentation for change_no_check untested variants Copy change's variants in change_no_check, since supposedly they should all be supported. But they haven't been tested, and my example fails. --- doc/sphinx/proof-engine/tactics.rst | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 02a0867341..bb7cac17b0 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -4841,6 +4841,26 @@ Performance-oriented tactic variants exact I. Fail Qed. + :tacn:`change_no_check` supports all of `change`'s variants. + + .. tacv:: change_no_check @term with @term’ + :undocumented: + + .. tacv:: change_no_check @term at {+ @num} with @term’ + :undocumented: + + .. tacv:: change_no_check @term {? {? at {+ @num}} with @term} in @ident + + .. example:: + + .. coqtop:: all abort + + Goal True -> False. + intro H. + change_no_check False in H. + exact H. + Fail Qed. + .. tacv:: convert_concl_no_check @term :name: convert_concl_no_check -- cgit v1.2.3 From f247ae382ccf7a292f15195646ff7302a7c2bd69 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Fri, 3 May 2019 03:27:05 +0200 Subject: Copy-editing from code review Co-Authored-By: Blaisorblade --- doc/sphinx/proof-engine/tactics.rst | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 02a0867341..1f339e7761 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -4821,15 +4821,15 @@ Performance-oriented tactic variants For advanced usage. Similar to :n:`change @term`, but as an optimization, it skips checking that :n:`@term` is convertible to the goal. - Recall the Coq kernel typechecks proofs again when they are concluded to + Recall that the Coq kernel typechecks proofs again when they are concluded to ensure safety. Hence, using :tacn:`change` checks convertibility twice - overall, while :tacn:`convert_concl_no_check` can produce ill-typed terms, + overall, while :tacn:`change_no_check` can produce ill-typed terms, but checks convertibility only once. - Hence, :tacn:`convert_concl_no_check` can be useful to speed up certain proof + Hence, :tacn:`change_no_check` can be useful to speed up certain proof scripts, especially if one knows by construction that the argument is indeed convertible to the goal. - In the following example, :tacn:`convert_concl_no_check` replaces :g:`False` by + In the following example, :tacn:`change_no_check` replaces :g:`False` by :g:`True`, but :g:`Qed` then rejects the proof, ensuring consistency. .. example:: @@ -4852,7 +4852,7 @@ Performance-oriented tactic variants For advanced usage. Similar to :n:`exact @term`, but as an optimization, it skips checking that :n:`@term` has the goal's type, relying on the kernel - check instead. See :tacn:`convert_concl_no_check` for more explanations. + check instead. See :tacn:`change_no_check` for more explanations. .. example:: -- cgit v1.2.3 From ca97b1a758a918dfa594e5759eda21b1da672265 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 3 May 2019 12:09:16 +0200 Subject: Fix #10054: Numeral Notations without the ltac plugin. It was fairly easy, the plugin defined an argument that was only used in a vernacular extension. Thus marking it as VERNAC was enough not to link to Ltac. --- plugins/syntax/g_numeral.mlg | 5 ++--- plugins/syntax/plugin_base.dune | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index baa4ae0306..0f0f3953da 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -16,18 +16,17 @@ open Notation open Numeral open Pp open Names -open Ltac_plugin open Stdarg open Pcoq.Prim -let pr_numnot_option _ _ _ = function +let pr_numnot_option = function | Nop -> mt () | Warning n -> str "(warning after " ++ str n ++ str ")" | Abstract n -> str "(abstract after " ++ str n ++ str ")" } -ARGUMENT EXTEND numnotoption +VERNAC ARGUMENT EXTEND numnotoption PRINTED BY { pr_numnot_option } | [ ] -> { Nop } | [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index aac46338ea..7a23581768 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -3,7 +3,7 @@ (public_name coq.plugins.numeral_notation) (synopsis "Coq numeral notation plugin") (modules g_numeral numeral) - (libraries coq.plugins.ltac)) + (libraries coq.vernac)) (library (name string_notation_plugin) -- cgit v1.2.3 From 24c570834dccc90c7ff14d3f6b9d33b818fa79c9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Apr 2019 18:50:47 +0200 Subject: Fix #9994: `revert dependent` is extremely slow. We add a fast path when generalizing over variables. --- tactics/tactics.ml | 18 +++++++++++------- test-suite/bugs/closed/bug_10025.v | 39 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 7 deletions(-) create mode 100644 test-suite/bugs/closed/bug_10025.v diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 16bede0d1b..35b3b38298 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2863,17 +2863,21 @@ let generalize_dep ?(with_let=false) c = | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in - let body = - if with_let then - match EConstr.kind sigma c with - | Var id -> id |> (fun id -> pf_get_hyp id gl) |> NamedDecl.get_value - | _ -> None - else None + let is_var, body = match EConstr.kind sigma c with + | Var id -> + let body = NamedDecl.get_value (pf_get_hyp id gl) in + let is_var = Option.is_empty body && not (List.mem id init_ids) in + if with_let then is_var, body else is_var, None + | _ -> false, None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (* Check that the generalization is indeed well-typed *) - let (evd, _) = Typing.type_of env evd cl'' in + let evd = + (* No need to retype for variables, term is statically well-typed *) + if is_var then evd + else fst (Typing.type_of env evd cl'') + in let args = Context.Named.to_instance mkVar to_quantify_rev in tclTHENLIST [ Proofview.Unsafe.tclEVARS evd; diff --git a/test-suite/bugs/closed/bug_10025.v b/test-suite/bugs/closed/bug_10025.v new file mode 100644 index 0000000000..1effc771b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_10025.v @@ -0,0 +1,39 @@ +Require Import Program. + +Axiom I : Type. + +Inductive S : Type := NT : I -> S. + +Axiom F : S -> Type. + +Axiom G : forall (s : S), F s -> Type. + +Section S. + +Variable init : I. +Variable my_s : F (NT init). + +Inductive foo : forall (s: S) (hole_sem: F s), Type := +| Foo : foo (NT init) my_s. + +Goal forall + (n : I) (s : F (NT n)) (ptz : foo (NT n) s) (pt : G (NT n) s) (x : unit), +match + match x with tt => tt end +with +| tt => + match + match ptz in foo x s return (forall _ : G x s, unit) with + | Foo => fun _ : G (NT init) my_s => tt + end pt + with + | tt => False + end +end. +Proof. +dependent destruction ptz. +(* Check well-typedness of goal *) +match goal with [ |- ?P ] => let t := type of P in idtac end. +Abort. + +End S. -- cgit v1.2.3 From dd60b4a292b870e08c23ddcb363630cbb2ed1227 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 2 May 2019 08:16:37 +0200 Subject: [primitive integers] Make div21 implems consistent with its specification There are three implementations of this primitive: * one in OCaml on 63 bits integer in kernel/uint63_amd64.ml * one in OCaml on Int64 in kernel/uint63_x86.ml * one in C on unsigned 64 bit integers in kernel/byterun/coq_uint63_native.h Its specification is the axiom `diveucl_21_spec` in theories/Numbers/Cyclic/Int63/Int63.v * comment the implementations with loop invariants to enable an easy pen&paper proof of correctness (note to reviewers: the one in uint63_amd64.ml might be the easiest to read) * make sure the three implementations are equivalent * fix the specification in Int63.v (only the lowest part of the result is actually returned) * make a little optimisation in div21 enabled by the proof of correctness (cmp is computed at the end of the first loop rather than at the beginning, potentially saving one loop iteration while remaining correct) * update the proofs in Int63.v and Cyclic63.v to take into account the new specifiation of div21 * add a test --- kernel/byterun/coq_interp.c | 39 +++-------------- kernel/byterun/coq_uint63_native.h | 53 +++++++++++++++-------- kernel/uint63.mli | 4 ++ kernel/uint63_amd64.ml | 26 ++++++++--- kernel/uint63_x86.ml | 25 ++++++++--- test-suite/arithmetic/diveucl_21.v | 8 ++++ test-suite/bugs/closed/bug_10031.v | 9 ++++ theories/Numbers/Cyclic/Int63/Cyclic63.v | 15 ------- theories/Numbers/Cyclic/Int63/Int63.v | 74 ++++++++++++++++++++++++-------- 9 files changed, 156 insertions(+), 97 deletions(-) create mode 100644 test-suite/bugs/closed/bug_10031.v diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 2293ae9dfd..e38d458b36 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -1374,40 +1374,11 @@ value coq_interprete Instruct (CHECKDIV21INT63) { print_instr("DIV21INT63"); CheckInt3(); - /* spiwack: takes three int31 (the two first ones represent an - int62) and performs the euclidian division of the - int62 by the int31 */ - /* TODO: implement this - bigint = UI64_of_value(accu); - bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); - uint64 divisor; - divisor = UI64_of_value(*sp++); - Alloc_small(accu, 2, 1); */ /* ( _ , arity, tag ) */ - /* if (I64_is_zero (divisor)) { - Field(accu, 0) = 1; */ /* 2*0+1 */ - /* Field(accu, 1) = 1; */ /* 2*0+1 */ - /* } - else { - uint64 quo, mod; - I64_udivmod(bigint, divisor, &quo, &mod); - Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); - Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); - } */ - int b; - Uint63_eq0(b, sp[1]); - if (b) { - AllocPair(); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[1]; - } - else { - Uint63_div21(accu, sp[0], sp[1], sp); - sp[1] = sp[0]; - Swap_accu_sp; - AllocPair(); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[0]; - } + Uint63_div21(accu, sp[0], sp[1], &(sp[1])); + Swap_accu_sp; + AllocPair(); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; sp += 2; Next; } diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index d431dc1e5c..8dee0d69d3 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -109,37 +109,56 @@ value uint63_mulc(value x, value y, value* h) { #define lt128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_lt(xl,yl))) #define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) -value uint63_div21(value xh, value xl, value y, value* q) { - xh = (uint64_t)xh >> 1; - xl = ((uint64_t)xl >> 1) | ((uint64_t)xh << 63); - xh = (uint64_t)xh >> 1; +#define maxuint63 ((uint64_t)0x7FFFFFFFFFFFFFFF) +/* precondition: y <> 0 */ +/* outputs r and sets ql to q % 2^63 s.t. x = q * y + r, r < y */ +static value uint63_div21_aux(value xh, value xl, value y, value* ql) { + xh = uint63_of_value(xh); + xl = uint63_of_value(xl); + y = uint63_of_value(y); uint64_t maskh = 0; uint64_t maskl = 1; uint64_t dh = 0; - uint64_t dl = (uint64_t)y >> 1; + uint64_t dl = y; int cmp = 1; - while (dh >= 0 && cmp) { + /* int n = 0 */ + /* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0, d < 2^(2*63) */ + while (!(dh >> (63 - 1)) && cmp) { + dh = (dh << 1) | (dl >> (63 - 1)); + dl = (dl << 1) & maxuint63; + maskh = (maskh << 1) | (maskl >> (63 - 1)); + maskl = (maskl << 1) & maxuint63; + /* ++n */ cmp = lt128(dh,dl,xh,xl); - dh = (dh << 1) | (dl >> 63); - dl = dl << 1; - maskh = (maskh << 1) | (maskl >> 63); - maskl = maskl << 1; } uint64_t remh = xh; uint64_t reml = xl; - uint64_t quotient = 0; + /* uint64_t quotienth = 0; */ + uint64_t quotientl = 0; + /* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 */ while (maskh | maskl) { - if (le128(dh,dl,remh,reml)) { - quotient = quotient | maskl; - if (uint63_lt(reml,dl)) {remh = remh - dh - 1;} else {remh = remh - dh;} + if (le128(dh,dl,remh,reml)) { /* if rem >= d, add one bit and subtract d */ + /* quotienth = quotienth | maskh */ + quotientl = quotientl | maskl; + remh = (uint63_lt(reml,dl)) ? (remh - dh - 1) : (remh - dh); reml = reml - dl; } - maskl = (maskl >> 1) | (maskh << 63); + maskl = (maskl >> 1) | ((maskh << (63 - 1)) & maxuint63); maskh = maskh >> 1; - dl = (dl >> 1) | (dh << 63); + dl = (dl >> 1) | ((dh << (63 - 1)) & maxuint63); dh = dh >> 1; + /* decr n */ } - *q = Val_int(quotient); + *ql = Val_int(quotientl); return Val_int(reml); } +value uint63_div21(value xh, value xl, value y, value* ql) { + if (uint63_of_value(y) == 0) { + *ql = Val_int(0); + return Val_int(0); + } else { + return uint63_div21_aux(xh, xl, y, ql); + } +} #define Uint63_div21(xh, xl, y, q) (accu = uint63_div21(xh, xl, y, q)) diff --git a/kernel/uint63.mli b/kernel/uint63.mli index b5f40ca804..f25f24512d 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -40,6 +40,10 @@ val rem : t -> t -> t (* Specific arithmetic operations *) val mulc : t -> t -> t * t val addmuldiv : t -> t -> t -> t + +(** [div21 xh xl y] returns [q % 2^63, r] + s.t. [xh * 2^63 + xl = q * y + r] and [r < y]. + When [y] is [0], returns [0, 0]. *) val div21 : t -> t -> t -> t * t (* comparison *) diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64.ml index 010b594de8..2d4d685775 100644 --- a/kernel/uint63_amd64.ml +++ b/kernel/uint63_amd64.ml @@ -102,26 +102,35 @@ let le128 xh xl yh yl = lt xh yh || (xh = yh && le xl yl) (* division of two numbers by one *) +(* precondition: y <> 0 *) +(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) let div21 xh xl y = let maskh = ref 0 in let maskl = ref 1 in let dh = ref 0 in let dl = ref y in let cmp = ref true in - while !dh >= 0 && !cmp do - cmp := lt128 !dh !dl xh xl; + (* n = ref 0 *) + (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) + while !dh >= 0 && !cmp do (* dh >= 0 tests that dh highest bit is zero *) (* We don't use addmuldiv below to avoid checks on 1 *) dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); dl := !dl lsl 1; maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); - maskl := !maskl lsl 1 - done; (* mask = 2^N, d = 2^N * d, d >= x *) + maskl := !maskl lsl 1; + (* incr n *) + cmp := lt128 !dh !dl xh xl; + done; (* mask = 2^n, d = 2^n * y, 2 * d > x *) let remh = ref xh in let reml = ref xl in - let quotient = ref 0 in + (* quotienth = ref 0 *) + let quotientl = ref 0 in + (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 *) while !maskh lor !maskl <> 0 do if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - quotient := !quotient lor !maskl; + (* quotienth := !quotienth lor !maskh *) + quotientl := !quotientl lor !maskl; remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; reml := !reml - !dl; end; @@ -129,8 +138,11 @@ let div21 xh xl y = maskh := !maskh lsr 1; dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); dh := !dh lsr 1; + (* decr n *) done; - !quotient, !reml + !quotientl, !reml + +let div21 xh xl y = if y = 0 then 0, 0 else div21 xh xl y (* exact multiplication *) (* TODO: check that none of these additions could be a logical or *) diff --git a/kernel/uint63_x86.ml b/kernel/uint63_x86.ml index 461184c432..fa45c90241 100644 --- a/kernel/uint63_x86.ml +++ b/kernel/uint63_x86.ml @@ -94,26 +94,35 @@ let le128 xh xl yh yl = lt xh yh || (xh = yh && le xl yl) (* division of two numbers by one *) +(* precondition: y <> 0 *) +(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) let div21 xh xl y = let maskh = ref zero in let maskl = ref one in let dh = ref zero in let dl = ref y in let cmp = ref true in - while le zero !dh && !cmp do - cmp := lt128 !dh !dl xh xl; + (* n = ref 0 *) + (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) + while Int64.equal (l_sr !dh (of_int (uint_size - 1))) zero && !cmp do (* We don't use addmuldiv below to avoid checks on 1 *) dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); dl := l_sl !dl one; maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); - maskl := l_sl !maskl one - done; (* mask = 2^N, d = 2^N * d, d >= x *) + maskl := l_sl !maskl one; + (* incr n *) + cmp := lt128 !dh !dl xh xl; + done; (* mask = 2^n, d = 2^n * d, 2 * d > x *) let remh = ref xh in let reml = ref xl in - let quotient = ref zero in + (* quotienth = ref 0 *) + let quotientl = ref zero in + (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 *) while not (Int64.equal (l_or !maskh !maskl) zero) do if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - quotient := l_or !quotient !maskl; + (* quotienth := !quotienth lor !maskh *) + quotientl := l_or !quotientl !maskl; remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; reml := sub !reml !dl end; @@ -121,9 +130,11 @@ let div21 xh xl y = maskh := l_sr !maskh one; dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); dh := l_sr !dh one + (* decr n *) done; - !quotient, !reml + !quotientl, !reml +let div21 xh xl y = if Int64.equal y zero then zero, zero else div21 xh xl y (* exact multiplication *) let mulc x y = diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/arithmetic/diveucl_21.v index 7e12a08906..b888c97be3 100644 --- a/test-suite/arithmetic/diveucl_21.v +++ b/test-suite/arithmetic/diveucl_21.v @@ -15,3 +15,11 @@ Check (eq_refl (4611686018427387904, 1) <: diveucl_21 3 1 2 = (46116860184273879 Check (eq_refl (4611686018427387904, 1) <<: diveucl_21 3 1 2 = (4611686018427387904, 1)). Definition compute2 := Eval compute in diveucl_21 3 1 2. Check (eq_refl compute2 : (4611686018427387904, 1) = (4611686018427387904, 1)). + +Check (eq_refl : diveucl_21 1 1 0 = (0,0)). +Check (eq_refl (0,0) <: diveucl_21 1 1 0 = (0,0)). +Check (eq_refl (0,0) <<: diveucl_21 1 1 0 = (0,0)). + +Check (eq_refl : diveucl_21 9223372036854775807 0 1 = (0,0)). +Check (eq_refl (0,0) <: diveucl_21 9223372036854775807 0 1 = (0,0)). +Check (eq_refl (0,0) <<: diveucl_21 9223372036854775807 0 1 = (0,0)). diff --git a/test-suite/bugs/closed/bug_10031.v b/test-suite/bugs/closed/bug_10031.v new file mode 100644 index 0000000000..15b53de00d --- /dev/null +++ b/test-suite/bugs/closed/bug_10031.v @@ -0,0 +1,9 @@ +Require Import Int63 ZArith. + +Open Scope int63_scope. + +Goal False. +cut (let (q, r) := (0, 0) in ([|q|], [|r|]) = (9223372036854775808%Z, 0%Z)); + [discriminate| ]. +Fail (change (0, 0) with (diveucl_21 1 0 1); apply diveucl_21_spec). +Abort. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 3b431d5b47..c03e6615cb 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -177,21 +177,6 @@ Proof. inversion W;rewrite Zmult_comm;trivial. Qed. -Lemma diveucl_21_spec_aux : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := diveucl_21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. -Proof. - intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). - assert (W1:= to_Z_bounded a1). - assert ([|b|]>0) by (auto with zarith). - generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). - destruct (diveucl_21 a1 a2 b);destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). - inversion W;rewrite (Zmult_comm [|b|]);trivial. -Qed. - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = a mod 2 ^ p. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index eac26add03..3c96130bf3 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -387,7 +387,8 @@ Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. Axiom diveucl_21_spec : forall a1 a2 b, let (q,r) := diveucl_21 a1 a2 b in - ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|]. + let (q',r') := Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|] in + [|q|] = Z.modulo q' wB /\ [|r|] = r'. Axiom addmuldiv_def_spec : forall p x y, addmuldiv p x y = addmuldiv_def p x y. @@ -1413,12 +1414,51 @@ Proof. apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. Qed. -Lemma div2_phi ih il j: - [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|]. -Proof. - generalize (diveucl_21_spec ih il j). - case diveucl_21; intros q r Heq. - simpl zn2z_to_Z;unfold Z.div;rewrite <- Heq;trivial. +Lemma diveucl_21_spec_aux : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := diveucl_21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). + assert (W1:= to_Z_bounded a1). + assert (W2:= to_Z_bounded a2). + assert (Wb:= to_Z_bounded b). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). + revert W. + destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). + intros (H', H''); rewrite H', H''; clear H' H''. + intros (H', H''); split; [ |exact H'']. + rewrite H', Zmult_comm, Z.mod_small; [reflexivity| ]. + split. + { revert H'; case z; [now simpl..|intros p H']. + exfalso; apply (Z.lt_irrefl 0), (Z.le_lt_trans _ ([|a1|] * wB + [|a2|])). + { now apply Z.add_nonneg_nonneg; [apply Z.mul_nonneg_nonneg| ]. } + rewrite H'; apply (Zplus_lt_reg_r _ _ (- z0)); ring_simplify. + apply (Z.le_lt_trans _ (- [|b|])); [ |now auto with zarith]. + rewrite Z.opp_eq_mul_m1; apply Zmult_le_compat_l; [ |now apply Wb]. + rewrite <-!Pos2Z.opp_pos, <-Z.opp_le_mono. + now change 1 with (Z.succ 0); apply Zlt_le_succ. } + rewrite <-Z.nle_gt; intro Hz; revert H2; apply Zle_not_lt. + rewrite (Z.div_unique_pos (wB * [|a1|] + [|a2|]) wB [|a1|] [|a2|]); + [ |now simpl..]. + rewrite Z.mul_comm, H'. + rewrite (Z.div_unique_pos (wB * [|b|] + z0) wB [|b|] z0) at 1; + [ |split; [ |apply (Z.lt_trans _ [|b|])]; now simpl|reflexivity]. + apply Z_div_le; [now simpl| ]; rewrite Z.mul_comm; apply Zplus_le_compat_r. + now apply Zmult_le_compat_l. +Qed. + +Lemma div2_phi ih il j: (2^62 <= [|j|] -> [|ih|] < [|j|] -> + [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|])%Z. +Proof. + intros Hj Hj1. + generalize (diveucl_21_spec_aux ih il j Hj Hj1). + case diveucl_21; intros q r (Hq, Hr). + apply Zdiv_unique with [|r|]; auto with zarith. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt2_step_correct rec ih il j: @@ -1436,9 +1476,9 @@ Proof. case (to_Z_bounded il); intros Hil1 _. case (to_Z_bounded j); intros _ Hj1. assert (Hp3: (0 < [||WW ih il||])). - simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. + {simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. + refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } cbv zeta. case_eq (ih < j)%int63;intros Heq. rewrite -> ltb_spec in Heq. @@ -1450,28 +1490,28 @@ Proof. 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. case (Zle_or_lt (2^(Z_of_nat size -1)) [|j|]); intros Hjj. case_eq (fst (diveucl_21 ih il j) < j)%int63;intros Heq0. - 2: rewrite <-not_true_iff_false, ltb_spec, div2_phi in Heq0. + 2: rewrite <-not_true_iff_false, ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. 2: split; auto; apply sqrt_test_true; auto with zarith. - rewrite -> ltb_spec, div2_phi in Heq0. + rewrite -> ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. match goal with |- context[rec _ _ ?X] => set (u := X) end. assert (H: [|u|] = ([|j|] + ([||WW ih il||])/([|j|]))/2). - unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); - case addc;unfold interp_carry;rewrite div2_phi;simpl zn2z_to_Z. - intros i H;rewrite lsr_spec, H;trivial. + { unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); + case addc;unfold interp_carry;rewrite (div2_phi _ _ _ Hjj Heq);simpl zn2z_to_Z. + { intros i H;rewrite lsr_spec, H;trivial. } intros i H;rewrite <- H. case (to_Z_bounded i); intros H1i H2i. rewrite -> add_spec, Zmod_small, lsr_spec. - change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. - rewrite Z_div_plus_full_l; auto with zarith. + { change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. + rewrite Z_div_plus_full_l; auto with zarith. } change wB with (2 * (wB/2))%Z; auto. replace [|(1 << (digits - 1))|] with (wB/2); auto. rewrite lsr_spec; auto. replace (2^[|1|]) with 2%Z; auto. split; auto with zarith. assert ([|i|]/2 < wB/2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. } apply Hrec; rewrite H; clear u H. assert (Hf1: 0 <= [||WW ih il||]/ [|j|]) by (apply Z_div_pos; auto with zarith). case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. -- cgit v1.2.3 From 09cdf7b1fad8761cdf7048bf38a468c8558eb0d5 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 2 May 2019 08:41:45 +0200 Subject: Remove now useless commented code --- kernel/byterun/coq_interp.c | 15 +-------------- kernel/byterun/coq_uint63_emul.h | 2 ++ kernel/byterun/coq_uint63_native.h | 1 + 3 files changed, 4 insertions(+), 14 deletions(-) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index e38d458b36..1b348ae777 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -29,13 +29,6 @@ #include "coq_uint63_emul.h" #endif -/* spiwack: I append here a few macros for value/number manipulation */ -#define uint32_of_value(val) (((uint32_t)(val)) >> 1) -#define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64_t)((uint32_t)(lo))) -#define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) -/* /spiwack */ - /* Registers for the abstract machine: @@ -1298,12 +1291,6 @@ value coq_interprete /*returns the multiplication on a pair */ print_instr("MULCINT63"); CheckInt2(); - /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - /* TODO: implement - p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); - AllocPair(); */ - /* Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; */ /*higher part*/ - /* Field(accu, 1) = (value)(I64_to_int32(p)|1); */ /*lower part*/ Uint63_mulc(accu, *sp, sp); *--sp = accu; AllocPair(); @@ -1587,7 +1574,7 @@ value coq_push_vstack(value stk, value max_stack_size) { print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); sp = coq_sp; - CHECK_STACK(uint32_of_value(max_stack_size)); + CHECK_STACK(uint_of_value(max_stack_size)); return Val_unit; } diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index d982f67566..528cc6fc1f 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -6,6 +6,8 @@ #define Is_uint63(v) (Tag_val(v) == Custom_tag) +#define uint_of_value(val) (((uint32_t)(val)) >> 1) + # define DECLARE_NULLOP(name) \ value uint63_##name() { \ static value* cb = 0; \ diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 8dee0d69d3..1fdafc9d8f 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -1,5 +1,6 @@ #define Is_uint63(v) (Is_long(v)) +#define uint_of_value(val) (((uint64_t)(val)) >> 1) #define uint63_of_value(val) ((uint64_t)(val) >> 1) /* 2^63 * y + x as a value */ -- cgit v1.2.3 From ee1e3685100a98925a272de31ea1c6147e24512f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 30 Apr 2019 12:15:44 +0200 Subject: Updating CHANGES. --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 5ca16ae1fe..f6806de9d0 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -15,6 +15,8 @@ Unreleased changes **Tactics** +- New variant change_no_check of change (usable as a documented + replacement of convert_concl_no_check). **Tactic language** -- cgit v1.2.3 From a0cfcc318919b315b142abab7604f04e8dd6420f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 3 May 2019 21:27:19 +0200 Subject: Tactics: fixing "change_no_check in". (Merge of the initial version with #9983 was broken) --- tactics/tactics.ml | 4 ++-- test-suite/success/change.v | 11 ++++++++--- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 35b3b38298..5e8869f9b0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -833,7 +833,7 @@ let change_in_hyp ?(check=true) occl t id = (* FIXME: we set the [check] flag only to reorder hypotheses in case of introduction of dependencies in new variables. We should separate this check from the conversion function. *) - e_change_in_hyp ~check:true (fun x -> change_on_subterm check Reduction.CONV x t occl) id + e_change_in_hyp ~check (fun x -> change_on_subterm check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -855,7 +855,7 @@ let change ?(check=true) chg c cls = let redfun deep env sigma t = change_on_subterm check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in - e_change_in_hyps ~check:true f hyps + e_change_in_hyps ~check f hyps end let change_concl t = diff --git a/test-suite/success/change.v b/test-suite/success/change.v index 5a8f735151..2f676cf9ad 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -71,8 +71,13 @@ Qed. (* Mini-check that no_check does not check *) -Goal False. -change_no_check True. -exact I. +Goal True -> False. +intro H. +change_no_check nat. +apply S. +change_no_check nat with bool. +change_no_check nat in H. +change_no_check nat with (bool->bool) in H. +exact (H true). Fail Qed. Abort. -- cgit v1.2.3 From 62b19246a81adbd07992cca91009faf012c5e9dd Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Fri, 3 May 2019 23:22:56 -0700 Subject: CoqIDE: recognize qualified identifiers as words. Fixes coq/coq#10062. The implementation is rough, and does not deal with leading, trailing, or doubled periods, but the same can be said of the current handling of leading numbers or primes. --- ide/gtk_parsing.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index d554bebdd3..82a5e9cdf6 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -10,11 +10,11 @@ let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0) - +let dot = Glib.Utf8.to_unichar "." ~pos:(ref 0) (* TODO: avoid num and prime at the head of a word *) let is_word_char c = - Glib.Unichar.isalnum c || c = underscore || c = prime + Glib.Unichar.isalnum c || c = underscore || c = prime || c = dot let starts_word (it:GText.iter) = -- cgit v1.2.3 From 30d6ffdd4546d56c517bef5b31a862c5454240f0 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 16 Apr 2019 18:27:14 +0200 Subject: New infrastructure for the unreleased changelog. Move existing entries. --- .github/PULL_REQUEST_TEMPLATE.md | 2 +- CHANGES.md | 63 ---------------------- dev/build/windows/makecoq_mingw.sh | 1 - dev/doc/MERGING.md | 5 +- doc/changelog/00000-title.rst | 2 + doc/changelog/09984-pairusualdecidabletypefull.rst | 3 ++ doc/changelog/09995-notations.rst | 8 +++ doc/changelog/09996-hint-mode.rst | 5 ++ doc/changelog/10059-change-no-check.rst | 7 +++ doc/changelog/README.md | 40 ++++++++++++++ doc/dune | 6 +++ doc/sphinx/changes.rst | 2 + 12 files changed, 77 insertions(+), 67 deletions(-) delete mode 100644 CHANGES.md create mode 100644 doc/changelog/00000-title.rst create mode 100644 doc/changelog/09984-pairusualdecidabletypefull.rst create mode 100644 doc/changelog/09995-notations.rst create mode 100644 doc/changelog/09996-hint-mode.rst create mode 100644 doc/changelog/10059-change-no-check.rst create mode 100644 doc/changelog/README.md diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 73b61ee0d9..3bd3342329 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -16,4 +16,4 @@ Fixes / closes #???? - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). -- [ ] Entry added in CHANGES.md. +- [ ] Entry added in the changelog (see https://github.com/coq/coq/tree/master/doc/changelog#unreleased-changelog for details). diff --git a/CHANGES.md b/CHANGES.md deleted file mode 100644 index 28ea84e4e3..0000000000 --- a/CHANGES.md +++ /dev/null @@ -1,63 +0,0 @@ -Unreleased changes -================== - - - -**Kernel** - - -**Specification language, type inference** - - -**Notations** - - -**Tactics** - -- New variant change_no_check of change (usable as a documented - replacement of convert_concl_no_check). - -**Tactic language** - -- Modes are now taken into account by `typeclasses eauto` for local hypotheses. - -**SSReflect** - -- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. - -- New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion - class, simplified `predType` interface: `pred_class` and `mkPredType` - deprecated, `{pred T}` and `PredType` should be used instead. - -- `if c return t then ...` now expects `c` to be a variable bound in `t`. - -- New `nonPropType` interface matching types that do _not_ have sort `Prop`. - -- New `relpre R f` definition for the preimage of a relation R under f. - - -**Commands and options** - - -**Tools** - - -**CoqIDE** - - -**Standard library** - -- Added Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull - - -**Infrastructure and dependencies** - - -**Miscellaneous** - - -Released changes -================ - -See . diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 4c5bd29236..ea9af60330 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1316,7 +1316,6 @@ function copy_coq_license { # FIXME: this is not the micromega license # It only applies to code that was copied into one single file! install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D CHANGES.md "$PREFIXCOQ/license_readme/coq/Changes.md" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 3f1b470878..c9eceb1270 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -71,8 +71,9 @@ those external projects should have been prepared (cf. the relevant sub-section in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). -Moreover the PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) or -the [`dev/doc/changes.md`](changes.md) file. +Moreover the PR author *must* add an entry to the [unreleased +changelog](../../doc/changelog/README.md) or to the +[`dev/doc/changes.md`](changes.md) file. If overlays are missing, ask the author to prepare them and label the PR with the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. diff --git a/doc/changelog/00000-title.rst b/doc/changelog/00000-title.rst new file mode 100644 index 0000000000..628d9c8578 --- /dev/null +++ b/doc/changelog/00000-title.rst @@ -0,0 +1,2 @@ +Unreleased changes +------------------ diff --git a/doc/changelog/09984-pairusualdecidabletypefull.rst b/doc/changelog/09984-pairusualdecidabletypefull.rst new file mode 100644 index 0000000000..732c088f45 --- /dev/null +++ b/doc/changelog/09984-pairusualdecidabletypefull.rst @@ -0,0 +1,3 @@ +- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` + (`#9984 `_, + by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/09995-notations.rst b/doc/changelog/09995-notations.rst new file mode 100644 index 0000000000..3dfc45242d --- /dev/null +++ b/doc/changelog/09995-notations.rst @@ -0,0 +1,8 @@ +- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + `if c return t then ...` now expects `c` to be a variable bound in `t`. + New `nonPropType` interface matching types that do _not_ have sort `Prop`. + New `relpre R f` definition for the preimage of a relation R under f + (`#9995 `_, by Georges Gonthier). diff --git a/doc/changelog/09996-hint-mode.rst b/doc/changelog/09996-hint-mode.rst new file mode 100644 index 0000000000..06e9059b45 --- /dev/null +++ b/doc/changelog/09996-hint-mode.rst @@ -0,0 +1,5 @@ +- Modes are now taken into account by :tacn:`typeclasses eauto` for + local hypotheses + (`#9996 `_, + fixes `#5752 `_, + by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/10059-change-no-check.rst b/doc/changelog/10059-change-no-check.rst new file mode 100644 index 0000000000..987b2a8ccd --- /dev/null +++ b/doc/changelog/10059-change-no-check.rst @@ -0,0 +1,7 @@ +- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a + documented replacement of :tacn:`convert_concl_no_check` + (`#10012 `_, + `#10017 `_, + `#10053 `_, and + `#10059 `_, + by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/README.md b/doc/changelog/README.md new file mode 100644 index 0000000000..64359e45ba --- /dev/null +++ b/doc/changelog/README.md @@ -0,0 +1,40 @@ +# Unreleased changelog # + +## When to add an entry? ## + +All new features, user-visible changes to features, user-visible or +otherwise important infrastructure changes, and important bug fixes +should get a changelog entry. + +Compatibility-breaking changes should always get a changelog entry, +which should explain what compatibility-breakage is to expect. + +Pull requests changing the ML API in significant ways should add an +entry in [`dev/doc/changes.md`](../../dev/doc/changes.md). + +## How to add an entry? ## + +You should create a file in this folder. The name of the file should +be `NNNNN-identifier.rst` where `NNNNN` is the number of the pull +request on five digits and `identifier` is whatever you want. + +This file should use the same format as the reference manual (as it +will be copied in there). You may reference the documentation you just +added with `:ref:`, `:tacn:`, `:cmd:`, `:opt:`, `:token:`, etc. See +the [documentation of the Sphinx format](../sphinx/README.rst) of the +manual for details. + +The entry should be written using the following structure: + +``` rst +- Description of the changes, with possible link to + :ref:`relevant-section` of the updated documentation + (`#PRNUM `_, + [fixes `#ISSUE1 `_ + [ and `#ISSUE2 `_],] + by Full Name[, with help / review of Full Name]). +``` + +The description should be kept rather short and the only additional +required meta-information are the link to the pull request and the +full name of the author. diff --git a/doc/dune b/doc/dune index bd40104725..06f78013aa 100644 --- a/doc/dune +++ b/doc/dune @@ -11,6 +11,7 @@ (package coq) (source_tree sphinx) (source_tree tools) + unreleased.rst (env_var SPHINXWARNOPT)) (action (run env COQLIB=%{project_root} sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) @@ -19,6 +20,11 @@ (name refman-html) (deps sphinx_build)) +(rule + (targets unreleased.rst) + (deps (source_tree changelog)) + (action (with-stdout-to %{targets} (bash "cat changelog/*.rst")))) + ; The install target still needs more work. ; (install ; (section doc) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 1c4c748295..5704587ae0 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -2,6 +2,8 @@ Recent changes -------------- +.. include:: ../unreleased.rst + Version 8.10 ------------ -- cgit v1.2.3 From 81301b55df9c52fe5503421eb9527bb04a1643e0 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 30 Apr 2019 11:42:23 +0200 Subject: Create categories in changelog. --- .gitattributes | 1 + doc/changelog/00-title.rst | 2 ++ doc/changelog/00000-title.rst | 2 -- doc/changelog/01-kernel/00000-title.rst | 3 +++ doc/changelog/02-specification-language/00000-title.rst | 3 +++ doc/changelog/03-notations/00000-title.rst | 3 +++ doc/changelog/04-tactics/00000-title.rst | 3 +++ doc/changelog/04-tactics/09996-hint-mode.rst | 5 +++++ doc/changelog/04-tactics/10059-change-no-check.rst | 7 +++++++ doc/changelog/05-tactic-language/00000-title.rst | 3 +++ doc/changelog/06-ssreflect/00000-title.rst | 3 +++ doc/changelog/06-ssreflect/09995-notations.rst | 8 ++++++++ doc/changelog/07-commands-and-options/00000-title.rst | 3 +++ doc/changelog/08-tools/00000-title.rst | 3 +++ doc/changelog/09-coqide/00000-title.rst | 3 +++ doc/changelog/09984-pairusualdecidabletypefull.rst | 3 --- doc/changelog/09995-notations.rst | 8 -------- doc/changelog/09996-hint-mode.rst | 5 ----- doc/changelog/10-standard-library/00000-title.rst | 3 +++ .../10-standard-library/09984-pairusualdecidabletypefull.rst | 3 +++ doc/changelog/10059-change-no-check.rst | 7 ------- doc/changelog/11-infrastructure-and-dependencies/00000-title.rst | 3 +++ doc/changelog/12-misc/00000-title.rst | 3 +++ doc/changelog/README.md | 7 ++++--- doc/dune | 2 +- 25 files changed, 67 insertions(+), 29 deletions(-) create mode 100644 doc/changelog/00-title.rst delete mode 100644 doc/changelog/00000-title.rst create mode 100644 doc/changelog/01-kernel/00000-title.rst create mode 100644 doc/changelog/02-specification-language/00000-title.rst create mode 100644 doc/changelog/03-notations/00000-title.rst create mode 100644 doc/changelog/04-tactics/00000-title.rst create mode 100644 doc/changelog/04-tactics/09996-hint-mode.rst create mode 100644 doc/changelog/04-tactics/10059-change-no-check.rst create mode 100644 doc/changelog/05-tactic-language/00000-title.rst create mode 100644 doc/changelog/06-ssreflect/00000-title.rst create mode 100644 doc/changelog/06-ssreflect/09995-notations.rst create mode 100644 doc/changelog/07-commands-and-options/00000-title.rst create mode 100644 doc/changelog/08-tools/00000-title.rst create mode 100644 doc/changelog/09-coqide/00000-title.rst delete mode 100644 doc/changelog/09984-pairusualdecidabletypefull.rst delete mode 100644 doc/changelog/09995-notations.rst delete mode 100644 doc/changelog/09996-hint-mode.rst create mode 100644 doc/changelog/10-standard-library/00000-title.rst create mode 100644 doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst delete mode 100644 doc/changelog/10059-change-no-check.rst create mode 100644 doc/changelog/11-infrastructure-and-dependencies/00000-title.rst create mode 100644 doc/changelog/12-misc/00000-title.rst diff --git a/.gitattributes b/.gitattributes index 58b1a31d36..260e3f96b6 100644 --- a/.gitattributes +++ b/.gitattributes @@ -54,6 +54,7 @@ dune* whitespace=blank-at-eol,tab-in-indent .gitattributes whitespace=blank-at-eol,tab-in-indent _CoqProject whitespace=blank-at-eol,tab-in-indent Dockerfile whitespace=blank-at-eol,tab-in-indent +00000-title.rst -whitespace # tabs are allowed in Makefiles. Makefile* whitespace=blank-at-eol diff --git a/doc/changelog/00-title.rst b/doc/changelog/00-title.rst new file mode 100644 index 0000000000..628d9c8578 --- /dev/null +++ b/doc/changelog/00-title.rst @@ -0,0 +1,2 @@ +Unreleased changes +------------------ diff --git a/doc/changelog/00000-title.rst b/doc/changelog/00000-title.rst deleted file mode 100644 index 628d9c8578..0000000000 --- a/doc/changelog/00000-title.rst +++ /dev/null @@ -1,2 +0,0 @@ -Unreleased changes ------------------- diff --git a/doc/changelog/01-kernel/00000-title.rst b/doc/changelog/01-kernel/00000-title.rst new file mode 100644 index 0000000000..f680628a05 --- /dev/null +++ b/doc/changelog/01-kernel/00000-title.rst @@ -0,0 +1,3 @@ + +**Kernel** + diff --git a/doc/changelog/02-specification-language/00000-title.rst b/doc/changelog/02-specification-language/00000-title.rst new file mode 100644 index 0000000000..99bd2c5b44 --- /dev/null +++ b/doc/changelog/02-specification-language/00000-title.rst @@ -0,0 +1,3 @@ + +**Specification language, type inference** + diff --git a/doc/changelog/03-notations/00000-title.rst b/doc/changelog/03-notations/00000-title.rst new file mode 100644 index 0000000000..abc532df11 --- /dev/null +++ b/doc/changelog/03-notations/00000-title.rst @@ -0,0 +1,3 @@ + +**Notations** + diff --git a/doc/changelog/04-tactics/00000-title.rst b/doc/changelog/04-tactics/00000-title.rst new file mode 100644 index 0000000000..3c7802d632 --- /dev/null +++ b/doc/changelog/04-tactics/00000-title.rst @@ -0,0 +1,3 @@ + +**Tactics** + diff --git a/doc/changelog/04-tactics/09996-hint-mode.rst b/doc/changelog/04-tactics/09996-hint-mode.rst new file mode 100644 index 0000000000..06e9059b45 --- /dev/null +++ b/doc/changelog/04-tactics/09996-hint-mode.rst @@ -0,0 +1,5 @@ +- Modes are now taken into account by :tacn:`typeclasses eauto` for + local hypotheses + (`#9996 `_, + fixes `#5752 `_, + by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/10059-change-no-check.rst b/doc/changelog/04-tactics/10059-change-no-check.rst new file mode 100644 index 0000000000..987b2a8ccd --- /dev/null +++ b/doc/changelog/04-tactics/10059-change-no-check.rst @@ -0,0 +1,7 @@ +- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a + documented replacement of :tacn:`convert_concl_no_check` + (`#10012 `_, + `#10017 `_, + `#10053 `_, and + `#10059 `_, + by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/05-tactic-language/00000-title.rst b/doc/changelog/05-tactic-language/00000-title.rst new file mode 100644 index 0000000000..b34d190298 --- /dev/null +++ b/doc/changelog/05-tactic-language/00000-title.rst @@ -0,0 +1,3 @@ + +**Tactic language** + diff --git a/doc/changelog/06-ssreflect/00000-title.rst b/doc/changelog/06-ssreflect/00000-title.rst new file mode 100644 index 0000000000..2e724627ec --- /dev/null +++ b/doc/changelog/06-ssreflect/00000-title.rst @@ -0,0 +1,3 @@ + +**SSReflect** + diff --git a/doc/changelog/06-ssreflect/09995-notations.rst b/doc/changelog/06-ssreflect/09995-notations.rst new file mode 100644 index 0000000000..3dfc45242d --- /dev/null +++ b/doc/changelog/06-ssreflect/09995-notations.rst @@ -0,0 +1,8 @@ +- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + `if c return t then ...` now expects `c` to be a variable bound in `t`. + New `nonPropType` interface matching types that do _not_ have sort `Prop`. + New `relpre R f` definition for the preimage of a relation R under f + (`#9995 `_, by Georges Gonthier). diff --git a/doc/changelog/07-commands-and-options/00000-title.rst b/doc/changelog/07-commands-and-options/00000-title.rst new file mode 100644 index 0000000000..1a0272983e --- /dev/null +++ b/doc/changelog/07-commands-and-options/00000-title.rst @@ -0,0 +1,3 @@ + +**Commands and options** + diff --git a/doc/changelog/08-tools/00000-title.rst b/doc/changelog/08-tools/00000-title.rst new file mode 100644 index 0000000000..bf462744fb --- /dev/null +++ b/doc/changelog/08-tools/00000-title.rst @@ -0,0 +1,3 @@ + +**Tools** + diff --git a/doc/changelog/09-coqide/00000-title.rst b/doc/changelog/09-coqide/00000-title.rst new file mode 100644 index 0000000000..0fc27cf380 --- /dev/null +++ b/doc/changelog/09-coqide/00000-title.rst @@ -0,0 +1,3 @@ + +**CoqIDE** + diff --git a/doc/changelog/09984-pairusualdecidabletypefull.rst b/doc/changelog/09984-pairusualdecidabletypefull.rst deleted file mode 100644 index 732c088f45..0000000000 --- a/doc/changelog/09984-pairusualdecidabletypefull.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` - (`#9984 `_, - by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/09995-notations.rst b/doc/changelog/09995-notations.rst deleted file mode 100644 index 3dfc45242d..0000000000 --- a/doc/changelog/09995-notations.rst +++ /dev/null @@ -1,8 +0,0 @@ -- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. - New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion - class, simplified `predType` interface: `pred_class` and `mkPredType` - deprecated, `{pred T}` and `PredType` should be used instead. - `if c return t then ...` now expects `c` to be a variable bound in `t`. - New `nonPropType` interface matching types that do _not_ have sort `Prop`. - New `relpre R f` definition for the preimage of a relation R under f - (`#9995 `_, by Georges Gonthier). diff --git a/doc/changelog/09996-hint-mode.rst b/doc/changelog/09996-hint-mode.rst deleted file mode 100644 index 06e9059b45..0000000000 --- a/doc/changelog/09996-hint-mode.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Modes are now taken into account by :tacn:`typeclasses eauto` for - local hypotheses - (`#9996 `_, - fixes `#5752 `_, - by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/10-standard-library/00000-title.rst b/doc/changelog/10-standard-library/00000-title.rst new file mode 100644 index 0000000000..d517a0e709 --- /dev/null +++ b/doc/changelog/10-standard-library/00000-title.rst @@ -0,0 +1,3 @@ + +**Standard library** + diff --git a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst new file mode 100644 index 0000000000..732c088f45 --- /dev/null +++ b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst @@ -0,0 +1,3 @@ +- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` + (`#9984 `_, + by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/10059-change-no-check.rst b/doc/changelog/10059-change-no-check.rst deleted file mode 100644 index 987b2a8ccd..0000000000 --- a/doc/changelog/10059-change-no-check.rst +++ /dev/null @@ -1,7 +0,0 @@ -- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a - documented replacement of :tacn:`convert_concl_no_check` - (`#10012 `_, - `#10017 `_, - `#10053 `_, and - `#10059 `_, - by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst new file mode 100644 index 0000000000..6b301f59d3 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst @@ -0,0 +1,3 @@ + +**Infrastructure and dependencies** + diff --git a/doc/changelog/12-misc/00000-title.rst b/doc/changelog/12-misc/00000-title.rst new file mode 100644 index 0000000000..5e709e2b27 --- /dev/null +++ b/doc/changelog/12-misc/00000-title.rst @@ -0,0 +1,3 @@ + +**Miscellaneous** + diff --git a/doc/changelog/README.md b/doc/changelog/README.md index 64359e45ba..2891eb207e 100644 --- a/doc/changelog/README.md +++ b/doc/changelog/README.md @@ -14,9 +14,10 @@ entry in [`dev/doc/changes.md`](../../dev/doc/changes.md). ## How to add an entry? ## -You should create a file in this folder. The name of the file should -be `NNNNN-identifier.rst` where `NNNNN` is the number of the pull -request on five digits and `identifier` is whatever you want. +You should create a file in one of the sub-directories. The name of +the file should be `NNNNN-identifier.rst` where `NNNNN` is the number +of the pull request on five digits and `identifier` is whatever you +want. This file should use the same format as the reference manual (as it will be copied in there). You may reference the documentation you just diff --git a/doc/dune b/doc/dune index 06f78013aa..3a8efbb36d 100644 --- a/doc/dune +++ b/doc/dune @@ -23,7 +23,7 @@ (rule (targets unreleased.rst) (deps (source_tree changelog)) - (action (with-stdout-to %{targets} (bash "cat changelog/*.rst")))) + (action (with-stdout-to %{targets} (bash "cat changelog/00-title.rst changelog/*/*.rst")))) ; The install target still needs more work. ; (install -- cgit v1.2.3 From d50433a9ca321ed0b28996567f72ac9654bf4422 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sat, 4 May 2019 14:18:22 +0200 Subject: [make] build unreleased.rst --- Makefile.doc | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Makefile.doc b/Makefile.doc index 23aa66a1b8..25d146000b 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -66,7 +66,7 @@ SPHINX_DEPS := coq endif # refman-html and refman-latex -refman-%: $(SPHINX_DEPS) +refman-%: $(SPHINX_DEPS) doc/unreleased.rst $(SHOW)'SPHINXBUILD doc/sphinx ($*)' $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \ $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$* @@ -116,6 +116,12 @@ plugin-tutorial: states tools doc/common/version.tex: config/Makefile printf '\\newcommand{\\coqversion}{$(VERSION)}' > doc/common/version.tex +### Changelog + +doc/unreleased.rst: $(wildcard doc/changelog/00-title.rst doc/changelog/*/*.rst) + $(SHOW)'AGGREGATE $@' + $(HIDE)cat doc/changelog/00-title.rst doc/changelog/*/*.rst > $@ + ###################################################################### # Standard library ###################################################################### -- cgit v1.2.3 From 50b148154fada66bb1145aaba696d9b427511592 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Sun, 5 May 2019 11:49:50 +0200 Subject: Add changelog entry about moving changelog to refman. --- doc/changelog/12-misc/09964-changes.rst | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 doc/changelog/12-misc/09964-changes.rst diff --git a/doc/changelog/12-misc/09964-changes.rst b/doc/changelog/12-misc/09964-changes.rst new file mode 100644 index 0000000000..1113782180 --- /dev/null +++ b/doc/changelog/12-misc/09964-changes.rst @@ -0,0 +1,13 @@ +- Changelog has been moved from a specific file `CHANGES.md` to the + reference manual; former Credits chapter of the reference manual has + been split in two parts: a History chapter which was enriched with + additional historical information about Coq versions 1 to 5, and a + Changes chapter which was enriched with the content formerly in + `CHANGES.md` and `COMPATIBILITY` + (`#9133 `_, + `#9668 `_, + `#9939 `_, + `#9964 `_, + by Théo Zimmermann, + with help and ideas from Emilio Jesús Gallego Arias, + Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). -- cgit v1.2.3 From 23cd71a9d75e8307b0d85e9e287706cbc7b96ae9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 6 May 2019 00:35:56 +0200 Subject: Coqchk: encapsulating an anomaly NotConvertible into a proper typing error. Detected incidentally in "validate" check for #8893. --- checker/mod_checking.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b86d491d72..1dd16f1630 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -33,7 +33,8 @@ let check_constant_declaration env kn cb = match Environ.body_of_constant_body env cb with | Some bd -> let j = infer env' (fst bd) in - conv_leq env' j.uj_type ty + (try conv_leq env' j.uj_type ty + with NotConvertible -> Type_errors.error_actual_type env j ty) | None -> () in let env = -- cgit v1.2.3 From 9779c0bf4945693bfd37b141e2c9f0fea200ba4d Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 25 Apr 2019 14:09:42 +0200 Subject: Integrate build and documentation of Ltac2 Since Ltac2 cannot be put under the stdlib logical root (some file names would clash), we move it to the `user-contrib` directory, to avoid adding another hardcoded path in `coqinit.ml`, following a suggestion by @ejgallego. Thanks to @Zimmi48 for the thorough documentation review and the numerous suggestions. --- .gitlab-ci.yml | 4 +- Makefile | 2 +- Makefile.build | 33 +- Makefile.common | 9 +- Makefile.vofiles | 8 +- doc/sphinx/biblio.bib | 17 + doc/sphinx/index.html.rst | 1 + doc/sphinx/index.latex.rst | 1 + doc/sphinx/proof-engine/ltac.rst | 4 +- doc/sphinx/proof-engine/ltac2.rst | 992 ++++++++++++++++++++ dune | 5 +- test-suite/Makefile | 5 +- test-suite/ltac2/compat.v | 58 ++ test-suite/ltac2/errors.v | 12 + test-suite/ltac2/example1.v | 27 + test-suite/ltac2/example2.v | 281 ++++++ test-suite/ltac2/matching.v | 71 ++ test-suite/ltac2/quot.v | 26 + test-suite/ltac2/rebind.v | 34 + test-suite/ltac2/stuff/ltac2.v | 143 +++ test-suite/ltac2/tacticals.v | 34 + test-suite/ltac2/typing.v | 72 ++ tools/coq_dune.ml | 18 +- tools/coqdep.ml | 5 + tools/coqdep_boot.ml | 4 + user-contrib/Ltac2/Array.v | 14 + user-contrib/Ltac2/Char.v | 12 + user-contrib/Ltac2/Constr.v | 72 ++ user-contrib/Ltac2/Control.v | 76 ++ user-contrib/Ltac2/Env.v | 26 + user-contrib/Ltac2/Fresh.v | 26 + user-contrib/Ltac2/Ident.v | 17 + user-contrib/Ltac2/Init.v | 69 ++ user-contrib/Ltac2/Int.v | 18 + user-contrib/Ltac2/Ltac1.v | 36 + user-contrib/Ltac2/Ltac2.v | 24 + user-contrib/Ltac2/Message.v | 25 + user-contrib/Ltac2/Notations.v | 556 ++++++++++++ user-contrib/Ltac2/Pattern.v | 145 +++ user-contrib/Ltac2/Std.v | 259 ++++++ user-contrib/Ltac2/String.v | 14 + user-contrib/Ltac2/g_ltac2.mlg | 933 +++++++++++++++++++ user-contrib/Ltac2/ltac2_plugin.mlpack | 14 + user-contrib/Ltac2/plugin_base.dune | 6 + user-contrib/Ltac2/tac2core.ml | 1446 ++++++++++++++++++++++++++++++ user-contrib/Ltac2/tac2core.mli | 30 + user-contrib/Ltac2/tac2dyn.ml | 27 + user-contrib/Ltac2/tac2dyn.mli | 34 + user-contrib/Ltac2/tac2entries.ml | 938 +++++++++++++++++++ user-contrib/Ltac2/tac2entries.mli | 93 ++ user-contrib/Ltac2/tac2env.ml | 298 ++++++ user-contrib/Ltac2/tac2env.mli | 146 +++ user-contrib/Ltac2/tac2expr.mli | 190 ++++ user-contrib/Ltac2/tac2extffi.ml | 40 + user-contrib/Ltac2/tac2extffi.mli | 16 + user-contrib/Ltac2/tac2ffi.ml | 382 ++++++++ user-contrib/Ltac2/tac2ffi.mli | 189 ++++ user-contrib/Ltac2/tac2intern.ml | 1545 ++++++++++++++++++++++++++++++++ user-contrib/Ltac2/tac2intern.mli | 46 + user-contrib/Ltac2/tac2interp.ml | 227 +++++ user-contrib/Ltac2/tac2interp.mli | 37 + user-contrib/Ltac2/tac2match.ml | 232 +++++ user-contrib/Ltac2/tac2match.mli | 33 + user-contrib/Ltac2/tac2print.ml | 488 ++++++++++ user-contrib/Ltac2/tac2print.mli | 46 + user-contrib/Ltac2/tac2qexpr.mli | 173 ++++ user-contrib/Ltac2/tac2quote.ml | 465 ++++++++++ user-contrib/Ltac2/tac2quote.mli | 102 +++ user-contrib/Ltac2/tac2stdlib.ml | 572 ++++++++++++ user-contrib/Ltac2/tac2stdlib.mli | 9 + user-contrib/Ltac2/tac2tactics.ml | 447 +++++++++ user-contrib/Ltac2/tac2tactics.mli | 122 +++ user-contrib/Ltac2/tac2types.mli | 92 ++ vendor/Ltac2/.gitignore | 18 - vendor/Ltac2/.travis.yml | 40 - vendor/Ltac2/LICENSE | 458 ---------- vendor/Ltac2/Makefile | 14 - vendor/Ltac2/README.md | 25 - vendor/Ltac2/_CoqProject | 51 -- vendor/Ltac2/doc/ltac2.md | 1036 --------------------- vendor/Ltac2/dune | 3 - vendor/Ltac2/dune-project | 3 - vendor/Ltac2/ltac2.opam | 18 - vendor/Ltac2/src/dune | 11 - vendor/Ltac2/src/g_ltac2.mlg | 933 ------------------- vendor/Ltac2/src/ltac2_plugin.mlpack | 14 - vendor/Ltac2/src/tac2core.ml | 1446 ------------------------------ vendor/Ltac2/src/tac2core.mli | 30 - vendor/Ltac2/src/tac2dyn.ml | 27 - vendor/Ltac2/src/tac2dyn.mli | 34 - vendor/Ltac2/src/tac2entries.ml | 938 ------------------- vendor/Ltac2/src/tac2entries.mli | 93 -- vendor/Ltac2/src/tac2env.ml | 298 ------ vendor/Ltac2/src/tac2env.mli | 146 --- vendor/Ltac2/src/tac2expr.mli | 190 ---- vendor/Ltac2/src/tac2extffi.ml | 40 - vendor/Ltac2/src/tac2extffi.mli | 16 - vendor/Ltac2/src/tac2ffi.ml | 382 -------- vendor/Ltac2/src/tac2ffi.mli | 189 ---- vendor/Ltac2/src/tac2intern.ml | 1545 -------------------------------- vendor/Ltac2/src/tac2intern.mli | 46 - vendor/Ltac2/src/tac2interp.ml | 227 ----- vendor/Ltac2/src/tac2interp.mli | 37 - vendor/Ltac2/src/tac2match.ml | 232 ----- vendor/Ltac2/src/tac2match.mli | 33 - vendor/Ltac2/src/tac2print.ml | 488 ---------- vendor/Ltac2/src/tac2print.mli | 46 - vendor/Ltac2/src/tac2qexpr.mli | 173 ---- vendor/Ltac2/src/tac2quote.ml | 465 ---------- vendor/Ltac2/src/tac2quote.mli | 102 --- vendor/Ltac2/src/tac2stdlib.ml | 578 ------------ vendor/Ltac2/src/tac2stdlib.mli | 9 - vendor/Ltac2/src/tac2tactics.ml | 455 ---------- vendor/Ltac2/src/tac2tactics.mli | 124 --- vendor/Ltac2/src/tac2types.mli | 92 -- vendor/Ltac2/tests/Makefile | 16 - vendor/Ltac2/tests/compat.v | 58 -- vendor/Ltac2/tests/errors.v | 12 - vendor/Ltac2/tests/example1.v | 27 - vendor/Ltac2/tests/example2.v | 281 ------ vendor/Ltac2/tests/matching.v | 71 -- vendor/Ltac2/tests/quot.v | 26 - vendor/Ltac2/tests/rebind.v | 34 - vendor/Ltac2/tests/stuff/ltac2.v | 143 --- vendor/Ltac2/tests/tacticals.v | 34 - vendor/Ltac2/tests/typing.v | 72 -- vendor/Ltac2/theories/Array.v | 14 - vendor/Ltac2/theories/Char.v | 12 - vendor/Ltac2/theories/Constr.v | 72 -- vendor/Ltac2/theories/Control.v | 76 -- vendor/Ltac2/theories/Env.v | 27 - vendor/Ltac2/theories/Fresh.v | 26 - vendor/Ltac2/theories/Ident.v | 17 - vendor/Ltac2/theories/Init.v | 69 -- vendor/Ltac2/theories/Int.v | 18 - vendor/Ltac2/theories/Ltac1.v | 36 - vendor/Ltac2/theories/Ltac2.v | 24 - vendor/Ltac2/theories/Message.v | 25 - vendor/Ltac2/theories/Notations.v | 568 ------------ vendor/Ltac2/theories/Pattern.v | 145 --- vendor/Ltac2/theories/Std.v | 263 ------ vendor/Ltac2/theories/String.v | 14 - vendor/Ltac2/theories/dune | 6 - 143 files changed, 12642 insertions(+), 13322 deletions(-) create mode 100644 doc/sphinx/proof-engine/ltac2.rst create mode 100644 test-suite/ltac2/compat.v create mode 100644 test-suite/ltac2/errors.v create mode 100644 test-suite/ltac2/example1.v create mode 100644 test-suite/ltac2/example2.v create mode 100644 test-suite/ltac2/matching.v create mode 100644 test-suite/ltac2/quot.v create mode 100644 test-suite/ltac2/rebind.v create mode 100644 test-suite/ltac2/stuff/ltac2.v create mode 100644 test-suite/ltac2/tacticals.v create mode 100644 test-suite/ltac2/typing.v create mode 100644 user-contrib/Ltac2/Array.v create mode 100644 user-contrib/Ltac2/Char.v create mode 100644 user-contrib/Ltac2/Constr.v create mode 100644 user-contrib/Ltac2/Control.v create mode 100644 user-contrib/Ltac2/Env.v create mode 100644 user-contrib/Ltac2/Fresh.v create mode 100644 user-contrib/Ltac2/Ident.v create mode 100644 user-contrib/Ltac2/Init.v create mode 100644 user-contrib/Ltac2/Int.v create mode 100644 user-contrib/Ltac2/Ltac1.v create mode 100644 user-contrib/Ltac2/Ltac2.v create mode 100644 user-contrib/Ltac2/Message.v create mode 100644 user-contrib/Ltac2/Notations.v create mode 100644 user-contrib/Ltac2/Pattern.v create mode 100644 user-contrib/Ltac2/Std.v create mode 100644 user-contrib/Ltac2/String.v create mode 100644 user-contrib/Ltac2/g_ltac2.mlg create mode 100644 user-contrib/Ltac2/ltac2_plugin.mlpack create mode 100644 user-contrib/Ltac2/plugin_base.dune create mode 100644 user-contrib/Ltac2/tac2core.ml create mode 100644 user-contrib/Ltac2/tac2core.mli create mode 100644 user-contrib/Ltac2/tac2dyn.ml create mode 100644 user-contrib/Ltac2/tac2dyn.mli create mode 100644 user-contrib/Ltac2/tac2entries.ml create mode 100644 user-contrib/Ltac2/tac2entries.mli create mode 100644 user-contrib/Ltac2/tac2env.ml create mode 100644 user-contrib/Ltac2/tac2env.mli create mode 100644 user-contrib/Ltac2/tac2expr.mli create mode 100644 user-contrib/Ltac2/tac2extffi.ml create mode 100644 user-contrib/Ltac2/tac2extffi.mli create mode 100644 user-contrib/Ltac2/tac2ffi.ml create mode 100644 user-contrib/Ltac2/tac2ffi.mli create mode 100644 user-contrib/Ltac2/tac2intern.ml create mode 100644 user-contrib/Ltac2/tac2intern.mli create mode 100644 user-contrib/Ltac2/tac2interp.ml create mode 100644 user-contrib/Ltac2/tac2interp.mli create mode 100644 user-contrib/Ltac2/tac2match.ml create mode 100644 user-contrib/Ltac2/tac2match.mli create mode 100644 user-contrib/Ltac2/tac2print.ml create mode 100644 user-contrib/Ltac2/tac2print.mli create mode 100644 user-contrib/Ltac2/tac2qexpr.mli create mode 100644 user-contrib/Ltac2/tac2quote.ml create mode 100644 user-contrib/Ltac2/tac2quote.mli create mode 100644 user-contrib/Ltac2/tac2stdlib.ml create mode 100644 user-contrib/Ltac2/tac2stdlib.mli create mode 100644 user-contrib/Ltac2/tac2tactics.ml create mode 100644 user-contrib/Ltac2/tac2tactics.mli create mode 100644 user-contrib/Ltac2/tac2types.mli delete mode 100644 vendor/Ltac2/.gitignore delete mode 100644 vendor/Ltac2/.travis.yml delete mode 100644 vendor/Ltac2/LICENSE delete mode 100644 vendor/Ltac2/Makefile delete mode 100644 vendor/Ltac2/README.md delete mode 100644 vendor/Ltac2/_CoqProject delete mode 100644 vendor/Ltac2/doc/ltac2.md delete mode 100644 vendor/Ltac2/dune delete mode 100644 vendor/Ltac2/dune-project delete mode 100644 vendor/Ltac2/ltac2.opam delete mode 100644 vendor/Ltac2/src/dune delete mode 100644 vendor/Ltac2/src/g_ltac2.mlg delete mode 100644 vendor/Ltac2/src/ltac2_plugin.mlpack delete mode 100644 vendor/Ltac2/src/tac2core.ml delete mode 100644 vendor/Ltac2/src/tac2core.mli delete mode 100644 vendor/Ltac2/src/tac2dyn.ml delete mode 100644 vendor/Ltac2/src/tac2dyn.mli delete mode 100644 vendor/Ltac2/src/tac2entries.ml delete mode 100644 vendor/Ltac2/src/tac2entries.mli delete mode 100644 vendor/Ltac2/src/tac2env.ml delete mode 100644 vendor/Ltac2/src/tac2env.mli delete mode 100644 vendor/Ltac2/src/tac2expr.mli delete mode 100644 vendor/Ltac2/src/tac2extffi.ml delete mode 100644 vendor/Ltac2/src/tac2extffi.mli delete mode 100644 vendor/Ltac2/src/tac2ffi.ml delete mode 100644 vendor/Ltac2/src/tac2ffi.mli delete mode 100644 vendor/Ltac2/src/tac2intern.ml delete mode 100644 vendor/Ltac2/src/tac2intern.mli delete mode 100644 vendor/Ltac2/src/tac2interp.ml delete mode 100644 vendor/Ltac2/src/tac2interp.mli delete mode 100644 vendor/Ltac2/src/tac2match.ml delete mode 100644 vendor/Ltac2/src/tac2match.mli delete mode 100644 vendor/Ltac2/src/tac2print.ml delete mode 100644 vendor/Ltac2/src/tac2print.mli delete mode 100644 vendor/Ltac2/src/tac2qexpr.mli delete mode 100644 vendor/Ltac2/src/tac2quote.ml delete mode 100644 vendor/Ltac2/src/tac2quote.mli delete mode 100644 vendor/Ltac2/src/tac2stdlib.ml delete mode 100644 vendor/Ltac2/src/tac2stdlib.mli delete mode 100644 vendor/Ltac2/src/tac2tactics.ml delete mode 100644 vendor/Ltac2/src/tac2tactics.mli delete mode 100644 vendor/Ltac2/src/tac2types.mli delete mode 100644 vendor/Ltac2/tests/Makefile delete mode 100644 vendor/Ltac2/tests/compat.v delete mode 100644 vendor/Ltac2/tests/errors.v delete mode 100644 vendor/Ltac2/tests/example1.v delete mode 100644 vendor/Ltac2/tests/example2.v delete mode 100644 vendor/Ltac2/tests/matching.v delete mode 100644 vendor/Ltac2/tests/quot.v delete mode 100644 vendor/Ltac2/tests/rebind.v delete mode 100644 vendor/Ltac2/tests/stuff/ltac2.v delete mode 100644 vendor/Ltac2/tests/tacticals.v delete mode 100644 vendor/Ltac2/tests/typing.v delete mode 100644 vendor/Ltac2/theories/Array.v delete mode 100644 vendor/Ltac2/theories/Char.v delete mode 100644 vendor/Ltac2/theories/Constr.v delete mode 100644 vendor/Ltac2/theories/Control.v delete mode 100644 vendor/Ltac2/theories/Env.v delete mode 100644 vendor/Ltac2/theories/Fresh.v delete mode 100644 vendor/Ltac2/theories/Ident.v delete mode 100644 vendor/Ltac2/theories/Init.v delete mode 100644 vendor/Ltac2/theories/Int.v delete mode 100644 vendor/Ltac2/theories/Ltac1.v delete mode 100644 vendor/Ltac2/theories/Ltac2.v delete mode 100644 vendor/Ltac2/theories/Message.v delete mode 100644 vendor/Ltac2/theories/Notations.v delete mode 100644 vendor/Ltac2/theories/Pattern.v delete mode 100644 vendor/Ltac2/theories/Std.v delete mode 100644 vendor/Ltac2/theories/String.v delete mode 100644 vendor/Ltac2/theories/dune diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3c427793e2..fba68f633e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -172,9 +172,7 @@ after_script: - not-a-real-job script: - cd _install_ci - - find lib/coq/ -name '*.vo' -print0 > vofiles - - for regexp in 's/.vo//' 's:lib/coq/plugins:Coq:' 's:lib/coq/theories:Coq:' 's:/:.:g'; do sed -z -i "$regexp" vofiles; done - - xargs -0 --arg-file=vofiles bin/coqchk -silent -o -m -coqlib lib/coq/ + - find lib/coq/ -name '*.vo' -print0 | xargs -0 bin/coqchk -silent -o -m -coqlib lib/coq/ .ci-template: stage: test diff --git a/Makefile b/Makefile index 2b5d2cea16..c4404d13c7 100644 --- a/Makefile +++ b/Makefile @@ -66,7 +66,7 @@ FIND_SKIP_DIRS:='(' \ ')' -prune -o define find - $(shell find . $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') + $(shell find . user-contrib/Ltac2 $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') endef define findindir diff --git a/Makefile.build b/Makefile.build index 2a071fd820..034c9ea03c 100644 --- a/Makefile.build +++ b/Makefile.build @@ -158,11 +158,14 @@ endif VDFILE := .vfiles MLDFILE := .mlfiles PLUGMLDFILE := plugins/.mlfiles +USERCONTRIBMLDFILE := user-contrib/.mlfiles MLLIBDFILE := .mllibfiles PLUGMLLIBDFILE := plugins/.mllibfiles +USERCONTRIBMLLIBDFILE := user-contrib/.mllibfiles DEPENDENCIES := \ - $(addsuffix .d, $(MLDFILE) $(MLLIBDFILE) $(PLUGMLDFILE) $(PLUGMLLIBDFILE) $(CFILES) $(VDFILE)) + $(addsuffix .d, $(MLDFILE) $(MLLIBDFILE) $(PLUGMLDFILE) $(PLUGMLLIBDFILE) \ + $(USERCONTRIBMLDFILE) $(USERCONTRIBMLLIBDFILE) $(CFILES) $(VDFILE)) -include $(DEPENDENCIES) @@ -209,12 +212,14 @@ BOOTCOQC=$(TIMER) $(COQC) -coqlib . -q $(COQOPTS) LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) MLINCLUDES=$(LOCALINCLUDES) +USERCONTRIBINCLUDES=$(addprefix -I user-contrib/,$(USERCONTRIBDIRS)) + OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) -DEPFLAGS=$(LOCALINCLUDES) -map gramlib/.pack/gramlib.ml $(if $(filter plugins/%,$@),, -I ide -I ide/protocol) +DEPFLAGS=$(LOCALINCLUDES) -map gramlib/.pack/gramlib.ml $(if $(filter plugins/% user-contrib/%,$@),, -I ide -I ide/protocol) # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) @@ -442,11 +447,11 @@ tools/coqdep_boot.cmx : tools/coqdep_common.cmx $(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I tools -package unix) + $(HIDE)$(call bestocaml, -I tools -package unix -package str) $(COQDEPBOOTBYTE): $(COQDEPBOOTSRC) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(call ocamlbyte, -I tools -package unix) + $(HIDE)$(call ocamlbyte, -I tools -package unix -package str) $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) $(SHOW)'OCAMLBEST -o $@' @@ -567,7 +572,7 @@ VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m -coqlib . validate: $(CHICKEN) | $(ALLVO:.$(VO)=.vo) $(SHOW)'COQCHK ' - $(HIDE)$(CHICKEN) $(VALIDOPTS) $(ALLMODS) + $(HIDE)$(CHICKEN) $(VALIDOPTS) $(ALLVO) $(ALLSTDLIB).v: $(SHOW)'MAKE $(notdir $@)' @@ -743,6 +748,10 @@ plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< +user-contrib/%.cmx: user-contrib/%.ml + $(SHOW)'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< + kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 %.cmx: %.ml @@ -776,8 +785,8 @@ kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 # Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .mlpack -MAINMLFILES := $(filter-out gramlib/.pack/% checker/% plugins/%, $(MLFILES) $(MLIFILES)) -MAINMLLIBFILES := $(filter-out gramlib/.pack/% checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) +MAINMLFILES := $(filter-out gramlib/.pack/% checker/% plugins/% user-contrib/%, $(MLFILES) $(MLIFILES)) +MAINMLLIBFILES := $(filter-out gramlib/.pack/% checker/% plugins/% user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) $(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) $(GENGRAMFILES) $(SHOW)'OCAMLDEP MLFILES MLIFILES' @@ -796,6 +805,14 @@ $(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $( $(SHOW)'OCAMLLIBDEP plugins/MLLIBFILES plugins/MLPACKFILES' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(filter plugins/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) +$(USERCONTRIBMLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter user-contrib/%, $(MLFILES) $(MLIFILES)) $(D_DEPEND_AFTER_SRC) $(GENFILES) + $(SHOW)'OCAMLDEP user-contrib/MLFILES user-contrib/MLIFILES' + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(filter user-contrib/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) + +$(USERCONTRIBMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP user-contrib/MLLIBFILES user-contrib/MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(filter user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) + ########################################################################### # Compilation of .v files ########################################################################### @@ -861,7 +878,7 @@ endif $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) $(VFILES) $(TOTARGET) + $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) -Q user-contrib "" $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.common b/Makefile.common index bd0e19cd00..ee3bfb43c5 100644 --- a/Makefile.common +++ b/Makefile.common @@ -104,10 +104,14 @@ PLUGINDIRS:=\ rtauto nsatz syntax btauto \ ssrmatching ltac ssr +USERCONTRIBDIRS:=\ + Ltac2 + SRCDIRS:=\ $(CORESRCDIRS) \ tools tools/coqdoc \ - $(addprefix plugins/, $(PLUGINDIRS)) + $(addprefix plugins/, $(PLUGINDIRS)) \ + $(addprefix user-contrib/, $(USERCONTRIBDIRS)) COQRUN := coqrun LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a @@ -149,13 +153,14 @@ DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo +LTAC2CMO:=user-contrib/Ltac2/ltac2_plugin.cmo PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(SYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.vofiles b/Makefile.vofiles index a71d68e565..e05822c889 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -13,7 +13,7 @@ endif ########################################################################### THEORIESVO := $(patsubst %.v,%.$(VO),$(shell find theories -type f -name "*.v")) -PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins user-contrib -type f -name "*.v")) ALLVO := $(THEORIESVO) $(PLUGINSVO) VFILES := $(ALLVO:.$(VO)=.v) @@ -24,16 +24,16 @@ THEORIESLIGHTVO:= \ # convert a (stdlib) filename into a module name: # remove .vo, replace theories and plugins by Coq, and replace slashes by dots -vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=)))) +vo_to_mod = $(subst /,.,$(patsubst user-contrib/%,%,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=))))) ALLMODS:=$(call vo_to_mod,$(ALLVO:.$(VO)=.vo)) # Converting a stdlib filename into native compiler filenames # Used for install targets -vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*))))) +vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*)))))) -vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o))))) +vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o)))))) ifdef QUICK GLOBFILES:= diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index 0467852b19..85b02013d8 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -551,3 +551,20 @@ the Calculus of Inductive Constructions}}, biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, bibsource = {dblp computer science bibliography, http://dblp.org} } + +@inproceedings{MilnerPrincipalTypeSchemes, + author = {Damas, Luis and Milner, Robin}, + title = {Principal Type-schemes for Functional Programs}, + booktitle = {Proceedings of the 9th ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages}, + series = {POPL '82}, + year = {1982}, + isbn = {0-89791-065-6}, + location = {Albuquerque, New Mexico}, + pages = {207--212}, + numpages = {6}, + url = {http://doi.acm.org/10.1145/582153.582176}, + doi = {10.1145/582153.582176}, + acmid = {582176}, + publisher = {ACM}, + address = {New York, NY, USA}, +} diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index a91c6a9c5f..0a20d1c47b 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -42,6 +42,7 @@ Contents proof-engine/proof-handling proof-engine/tactics proof-engine/ltac + proof-engine/ltac2 proof-engine/detailed-tactic-examples proof-engine/ssreflect-proof-language diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index 708820fff7..5562736997 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -41,6 +41,7 @@ The proof engine proof-engine/proof-handling proof-engine/tactics proof-engine/ltac + proof-engine/ltac2 proof-engine/detailed-tactic-examples proof-engine/ssreflect-proof-language diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 0322b43694..d3562b52c5 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1,7 +1,7 @@ .. _ltac: -The tactic language -=================== +Ltac +==== This chapter gives a compact documentation of |Ltac|, the tactic language available in |Coq|. We start by giving the syntax, and next, we present the diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst new file mode 100644 index 0000000000..6e33862b39 --- /dev/null +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -0,0 +1,992 @@ +.. _ltac2: + +.. coqtop:: none + + From Ltac2 Require Import Ltac2. + +Ltac2 +===== + +The Ltac tactic language is probably one of the ingredients of the success of +Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: + +- has often unclear semantics +- is very non-uniform due to organic growth +- lacks expressivity (data structures, combinators, types, ...) +- is slow +- is error-prone and fragile +- has an intricate implementation + +Following the need of users that start developing huge projects relying +critically on Ltac, we believe that we should offer a proper modern language +that features at least the following: + +- at least informal, predictable semantics +- a typing system +- standard programming facilities (i.e. datatypes) + +This new language, called Ltac2, is described in this chapter. It is still +experimental but we encourage nonetheless users to start testing it, +especially wherever an advanced tactic language is needed. The previous +implementation of Ltac, described in the previous chapter, will be referred to +as Ltac1. + +.. _ltac2_design: + +General design +-------------- + +There are various alternatives to Ltac1, such that Mtac or Rtac for instance. +While those alternatives can be quite distinct from Ltac1, we designed +Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +aforementioned defects. + +In particular, Ltac2 is: + +- a member of the ML family of languages, i.e. + + * a call-by-value functional language + * with effects + * together with Hindley-Milner type system + +- a language featuring meta-programming facilities for the manipulation of + Coq-side terms +- a language featuring notation facilities to help writing palatable scripts + +We describe more in details each point in the remainder of this document. + +ML component +------------ + +Overview +~~~~~~~~ + +Ltac2 is a member of the ML family of languages, in the sense that it is an +effectful call-by-value functional language, with static typing à la +Hindley-Milner (see :cite:`MilnerPrincipalTypeSchemes`). It is commonly accepted +that ML constitutes a sweet spot in PL design, as it is relatively expressive +while not being either too lax (unlike dynamic typing) nor too strict +(unlike, say, dependent types). + +The main goal of Ltac2 is to serve as a meta-language for Coq. As such, it +naturally fits in the ML lineage, just as the historical ML was designed as +the tactic language for the LCF prover. It can also be seen as a general-purpose +language, by simply forgetting about the Coq-specific features. + +Sticking to a standard ML type system can be considered somewhat weak for a +meta-language designed to manipulate Coq terms. In particular, there is no +way to statically guarantee that a Coq term resulting from an Ltac2 +computation will be well-typed. This is actually a design choice, motivated +by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +dynamic checks, allowing many primitive functions to fail whenever they are +provided with an ill-typed term. + +The language is naturally effectful as it manipulates the global state of the +proof engine. This allows to think of proof-modifying primitives as effects +in a straightforward way. Semantically, proof manipulation lives in a monad, +which allows to ensure that Ltac2 satisfies the same equations as a generic ML +with unspecified effects would do, e.g. function reduction is substitution +by a value. + +Type Syntax +~~~~~~~~~~~ + +At the level of terms, we simply elaborate on Ltac1 syntax, which is quite +close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. + +The non-terminal :production:`lident` designates identifiers starting with a +lowercase. + +.. productionlist:: coq + ltac2_type : ( `ltac2_type`, ... , `ltac2_type` ) `ltac2_typeconst` + : ( `ltac2_type` * ... * `ltac2_type` ) + : `ltac2_type` -> `ltac2_type` + : `ltac2_typevar` + ltac2_typeconst : ( `modpath` . )* `lident` + ltac2_typevar : '`lident` + ltac2_typeparams : ( `ltac2_typevar`, ... , `ltac2_typevar` ) + +The set of base types can be extended thanks to the usual ML type +declarations such as algebraic datatypes and records. + +Built-in types include: + +- ``int``, machine integers (size not specified, in practice inherited from OCaml) +- ``string``, mutable strings +- ``'a array``, mutable arrays +- ``exn``, exceptions +- ``constr``, kernel-side terms +- ``pattern``, term patterns +- ``ident``, well-formed identifiers + +Type declarations +~~~~~~~~~~~~~~~~~ + +One can define new types by the following commands. + +.. cmd:: Ltac2 Type @ltac2_typeparams @lident + :name: Ltac2 Type + + This command defines an abstract type. It has no use for the end user and + is dedicated to types representing data coming from the OCaml world. + +.. cmdv:: Ltac2 Type {? rec} @ltac2_typeparams @lident := @ltac2_typedef + + This command defines a type with a manifest. There are four possible + kinds of such definitions: alias, variant, record and open variant types. + + .. productionlist:: coq + ltac2_typedef : `ltac2_type` + : [ `ltac2_constructordef` | ... | `ltac2_constructordef` ] + : { `ltac2_fielddef` ; ... ; `ltac2_fielddef` } + : [ .. ] + ltac2_constructordef : `uident` [ ( `ltac2_type` , ... , `ltac2_type` ) ] + ltac2_fielddef : [ mutable ] `ident` : `ltac2_type` + + Aliases are just a name for a given type expression and are transparently + unfoldable to it. They cannot be recursive. The non-terminal + :production:`uident` designates identifiers starting with an uppercase. + + Variants are sum types defined by constructors and eliminated by + pattern-matching. They can be recursive, but the `rec` flag must be + explicitly set. Pattern-maching must be exhaustive. + + Records are product types with named fields and eliminated by projection. + Likewise they can be recursive if the `rec` flag is set. + + .. cmdv:: Ltac2 Type @ltac2_typeparams @ltac2_qualid := [ @ltac2_constructordef ] + + Open variants are a special kind of variant types whose constructors are not + statically defined, but can instead be extended dynamically. A typical example + is the standard `exn` type. Pattern-matching must always include a catch-all + clause. They can be extended by this command. + +Term Syntax +~~~~~~~~~~~ + +The syntax of the functional fragment is very close to the one of Ltac1, except +that it adds a true pattern-matching feature, as well as a few standard +constructions from ML. + +.. productionlist:: coq + ltac2_var : `lident` + ltac2_qualid : ( `modpath` . )* `lident` + ltac2_constructor: `uident` + ltac2_term : `ltac2_qualid` + : `ltac2_constructor` + : `ltac2_term` `ltac2_term` ... `ltac2_term` + : fun `ltac2_var` => `ltac2_term` + : let `ltac2_var` := `ltac2_term` in `ltac2_term` + : let rec `ltac2_var` := `ltac2_term` in `ltac2_term` + : match `ltac2_term` with `ltac2_branch` ... `ltac2_branch` end + : `int` + : `string` + : `ltac2_term` ; `ltac2_term` + : [| `ltac2_term` ; ... ; `ltac2_term` |] + : ( `ltac2_term` , ... , `ltac2_term` ) + : { `ltac2_field` `ltac2_field` ... `ltac2_field` } + : `ltac2_term` . ( `ltac2_qualid` ) + : `ltac2_term` . ( `ltac2_qualid` ) := `ltac2_term` + : [; `ltac2_term` ; ... ; `ltac2_term` ] + : `ltac2_term` :: `ltac2_term` + : ... + ltac2_branch : `ltac2_pattern` => `ltac2_term` + ltac2_pattern : `ltac2_var` + : _ + : ( `ltac2_pattern` , ... , `ltac2_pattern` ) + : `ltac2_constructor` `ltac2_pattern` ... `ltac2_pattern` + : [ ] + : `ltac2_pattern` :: `ltac2_pattern` + ltac2_field : `ltac2_qualid` := `ltac2_term` + +In practice, there is some additional syntactic sugar that allows e.g. to +bind a variable and match on it at the same time, in the usual ML style. + +There is a dedicated syntax for list and array literals. + +.. note:: + + For now, deep pattern matching is not implemented. + +Ltac Definitions +~~~~~~~~~~~~~~~~ + +.. cmd:: Ltac2 {? mutable} {? rec} @lident := @ltac2_term + :name: Ltac2 + + This command defines a new global Ltac2 value. + + For semantic reasons, the body of the Ltac2 definition must be a syntactical + value, i.e. a function, a constant or a pure constructor recursively applied to + values. + + If ``rec`` is set, the tactic is expanded into a recursive binding. + + If ``mutable`` is set, the definition can be redefined at a later stage (see below). + +.. cmd:: Ltac2 Set @qualid := @ltac2_term + :name: Ltac2 Set + + This command redefines a previous ``mutable`` definition. + Mutable definitions act like dynamic binding, i.e. at runtime, the last defined + value for this entry is chosen. This is useful for global flags and the like. + +Reduction +~~~~~~~~~ + +We use the usual ML call-by-value reduction, with an otherwise unspecified +evaluation order. This is a design choice making it compatible with OCaml, +if ever we implement native compilation. The expected equations are as follows:: + + (fun x => t) V ≡ t{x := V} (βv) + + let x := V in t ≡ t{x := V} (let) + + match C V₀ ... Vₙ with ... | C x₀ ... xₙ => t | ... end ≡ t {xᵢ := Vᵢ} (ι) + + (t any term, V values, C constructor) + +Note that call-by-value reduction is already a departure from Ltac1 which uses +heuristics to decide when evaluating an expression. For instance, the following +expressions do not evaluate the same way in Ltac1. + +:n:`foo (idtac; let x := 0 in bar)` + +:n:`foo (let x := 0 in bar)` + +Instead of relying on the :n:`idtac` idiom, we would now require an explicit thunk +not to compute the argument, and :n:`foo` would have e.g. type +:n:`(unit -> unit) -> unit`. + +:n:`foo (fun () => let x := 0 in bar)` + +Typing +~~~~~~ + +Typing is strict and follows Hindley-Milner system. Unlike Ltac1, there +are no type casts at runtime, and one has to resort to conversion +functions. See notations though to make things more palatable. + +In this setting, all usual argument-free tactics have type :n:`unit -> unit`, but +one can return as well a value of type :n:`t` thanks to terms of type :n:`unit -> t`, +or take additional arguments. + +Effects +~~~~~~~ + +Effects in Ltac2 are straightforward, except that instead of using the +standard IO monad as the ambient effectful world, Ltac2 is going to use the +tactic monad. + +Note that the order of evaluation of application is *not* specified and is +implementation-dependent, as in OCaml. + +We recall that the `Proofview.tactic` monad is essentially a IO monad together +with backtracking state representing the proof state. + +Intuitively a thunk of type :n:`unit -> 'a` can do the following: + +- It can perform non-backtracking IO like printing and setting mutable variables +- It can fail in a non-recoverable way +- It can use first-class backtrack. The proper way to figure that is that we + morally have the following isomorphism: + :n:`(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` + i.e. thunks can produce a lazy list of results where each + tail is waiting for a continuation exception. +- It can access a backtracking proof state, made out amongst other things of + the current evar assignation and the list of goals under focus. + +We describe more thoroughly the various effects existing in Ltac2 hereafter. + +Standard IO ++++++++++++ + +The Ltac2 language features non-backtracking IO, notably mutable data and +printing operations. + +Mutable fields of records can be modified using the set syntax. Likewise, +built-in types like `string` and `array` feature imperative assignment. See +modules `String` and `Array` respectively. + +A few printing primitives are provided in the `Message` module, allowing to +display information to the user. + +Fatal errors +++++++++++++ + +The Ltac2 language provides non-backtracking exceptions, also known as *panics*, +through the following primitive in module `Control`.:: + + val throw : exn -> 'a + +Unlike backtracking exceptions from the next section, this kind of error +is never caught by backtracking primitives, that is, throwing an exception +destroys the stack. This is materialized by the following equation, where `E` +is an evaluation context.:: + + E[throw e] ≡ throw e + + (e value) + +There is currently no way to catch such an exception and it is a design choice. +There might be at some future point a way to catch it in a brutal way, +destroying all backtrack and return values. + +Backtrack ++++++++++ + +In Ltac2, we have the following backtracking primitives, defined in the +`Control` module.:: + + Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. + + val zero : exn -> 'a + val plus : (unit -> 'a) -> (exn -> 'a) -> 'a + val case : (unit -> 'a) -> ('a * (exn -> 'a)) result + +If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +list concatenation, while `case` is pattern-matching. + +The backtracking is first-class, i.e. one can write +:n:`plus (fun () => "x") (fun _ => "y") : string` producing a backtracking string. + +These operations are expected to satisfy a few equations, most notably that they +form a monoid compatible with sequentialization.:: + + plus t zero ≡ t () + plus (fun () => zero e) f ≡ f e + plus (plus t f) g ≡ plus t (fun e => plus (f e) g) + + case (fun () => zero e) ≡ Err e + case (fun () => plus (fun () => t) f) ≡ Val (t,f) + + let x := zero e in u ≡ zero e + let x := plus t f in u ≡ plus (fun () => let x := t in u) (fun e => let x := f e in u) + + (t, u, f, g, e values) + +Goals ++++++ + +A goal is given by the data of its conclusion and hypotheses, i.e. it can be +represented as `[Γ ⊢ A]`. + +The tactic monad naturally operates over the whole proofview, which may +represent several goals, including none. Thus, there is no such thing as +*the current goal*. Goals are naturally ordered, though. + +It is natural to do the same in Ltac2, but we must provide a way to get access +to a given goal. This is the role of the `enter` primitive, that applies a +tactic to each currently focused goal in turn.:: + + val enter : (unit -> unit) -> unit + +It is guaranteed that when evaluating `enter f`, `f` is called with exactly one +goal under focus. Note that `f` may be called several times, or never, depending +on the number of goals under focus before the call to `enter`. + +Accessing the goal data is then implicit in the Ltac2 primitives, and may panic +if the invariants are not respected. The two essential functions for observing +goals are given below.:: + + val hyp : ident -> constr + val goal : unit -> constr + +The two above functions panic if there is not exactly one goal under focus. +In addition, `hyp` may also fail if there is no hypothesis with the +corresponding name. + +Meta-programming +---------------- + +Overview +~~~~~~~~ + +One of the major implementation issues of Ltac1 is the fact that it is +never clear whether an object refers to the object world or the meta-world. +This is an incredible source of slowness, as the interpretation must be +aware of bound variables and must use heuristics to decide whether a variable +is a proper one or referring to something in the Ltac context. + +Likewise, in Ltac1, constr parsing is implicit, so that ``foo 0`` is +not ``foo`` applied to the Ltac integer expression ``0`` (Ltac does have a +notion of integers, though it is not first-class), but rather the Coq term +:g:`Datatypes.O`. + +The implicit parsing is confusing to users and often gives unexpected results. +Ltac2 makes these explicit using quoting and unquoting notation, although there +are notations to do it in a short and elegant way so as not to be too cumbersome +to the user. + +Generic Syntax for Quotations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In general, quotations can be introduced in terms using the following syntax, where +:production:`quotentry` is some parsing entry. + +.. prodn:: + ltac2_term += @ident : ( @quotentry ) + +Built-in quotations ++++++++++++++++++++ + +The current implementation recognizes the following built-in quotations: + +- ``ident``, which parses identifiers (type ``Init.ident``). +- ``constr``, which parses Coq terms and produces an-evar free term at runtime + (type ``Init.constr``). +- ``open_constr``, which parses Coq terms and produces a term potentially with + holes at runtime (type ``Init.constr`` as well). +- ``pattern``, which parses Coq patterns and produces a pattern used for term + matching (type ``Init.pattern``). +- ``reference``, which parses either a :n:`@qualid` or :n:`& @ident`. Qualified names + are globalized at internalization into the corresponding global reference, + while ``&id`` is turned into ``Std.VarRef id``. This produces at runtime a + ``Std.reference``. + +The following syntactic sugar is provided for two common cases. + +- ``@id`` is the same as ``ident:(id)`` +- ``'t`` is the same as ``open_constr:(t)`` + +Strict vs. non-strict mode +++++++++++++++++++++++++++ + +Depending on the context, quotations producing terms (i.e. ``constr`` or +``open_constr``) are not internalized in the same way. There are two possible +modes, respectively called the *strict* and the *non-strict* mode. + +- In strict mode, all simple identifiers appearing in a term quotation are + required to be resolvable statically. That is, they must be the short name of + a declaration which is defined globally, excluding section variables and + hypotheses. If this doesn't hold, internalization will fail. To work around + this error, one has to specifically use the ``&`` notation. +- In non-strict mode, any simple identifier appearing in a term quotation which + is not bound in the global context is turned into a dynamic reference to a + hypothesis. That is to say, internalization will succeed, but the evaluation + of the term at runtime will fail if there is no such variable in the dynamic + context. + +Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +mode is only set when evaluating Ltac2 snippets in interactive proof mode. The +rationale is that it is cumbersome to explicitly add ``&`` interactively, while it +is expected that global tactics enforce more invariants on their code. + +Term Antiquotations +~~~~~~~~~~~~~~~~~~~ + +Syntax +++++++ + +One can also insert Ltac2 code into Coq terms, similarly to what is possible in +Ltac1. + +.. prodn:: + term += ltac2:( @ltac2_term ) + +Antiquoted terms are expected to have type ``unit``, as they are only evaluated +for their side-effects. + +Semantics ++++++++++ + +Interpretation of a quoted Coq term is done in two phases, internalization and +evaluation. + +- Internalization is part of the static semantics, i.e. it is done at Ltac2 + typing time. +- Evaluation is part of the dynamic semantics, i.e. it is done when + a term gets effectively computed by Ltac2. + +Note that typing of Coq terms is a *dynamic* process occurring at Ltac2 +evaluation time, and not at Ltac2 typing time. + +Static semantics +**************** + +During internalization, Coq variables are resolved and antiquotations are +type-checked as Ltac2 terms, effectively producing a ``glob_constr`` in Coq +implementation terminology. Note that although it went through the +type-checking of **Ltac2**, the resulting term has not been fully computed and +is potentially ill-typed as a runtime **Coq** term. + +.. example:: + + The following term is valid (with type `unit -> constr`), but will fail at runtime: + + .. coqtop:: in + + Ltac2 myconstr () := constr:(nat -> 0). + +Term antiquotations are type-checked in the enclosing Ltac2 typing context +of the corresponding term expression. + +.. example:: + + The following will type-check, with type `constr`. + + .. coqdoc:: + + let x := '0 in constr:(1 + ltac2:(exact x)) + +Beware that the typing environment of antiquotations is **not** +expanded by the Coq binders from the term. + + .. example:: + + The following Ltac2 expression will **not** type-check:: + + `constr:(fun x : nat => ltac2:(exact x))` + `(* Error: Unbound variable 'x' *)` + +There is a simple reason for that, which is that the following expression would +not make sense in general. + +`constr:(fun x : nat => ltac2:(clear @x; exact x))` + +Indeed, a hypothesis can suddenly disappear from the runtime context if some +other tactic pulls the rug from under you. + +Rather, the tactic writer has to resort to the **dynamic** goal environment, +and must write instead explicitly that she is accessing a hypothesis, typically +as follows. + +`constr:(fun x : nat => ltac2:(exact (hyp @x)))` + +This pattern is so common that we provide dedicated Ltac2 and Coq term notations +for it. + +- `&x` as an Ltac2 expression expands to `hyp @x`. +- `&x` as a Coq constr expression expands to + `ltac2:(Control.refine (fun () => hyp @x))`. + +Dynamic semantics +***************** + +During evaluation, a quoted term is fully evaluated to a kernel term, and is +in particular type-checked in the current environment. + +Evaluation of a quoted term goes as follows. + +- The quoted term is first evaluated by the pretyper. +- Antiquotations are then evaluated in a context where there is exactly one goal + under focus, with the hypotheses coming from the current environment extended + with the bound variables of the term, and the resulting term is fed into the + quoted term. + +Relative orders of evaluation of antiquotations and quoted term are not +specified. + +For instance, in the following example, `tac` will be evaluated in a context +with exactly one goal under focus, whose last hypothesis is `H : nat`. The +whole expression will thus evaluate to the term :g:`fun H : nat => H`. + +`let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ()))` + +Many standard tactics perform type-checking of their argument before going +further. It is your duty to ensure that terms are well-typed when calling +such tactics. Failure to do so will result in non-recoverable exceptions. + +**Trivial Term Antiquotations** + +It is possible to refer to a variable of type `constr` in the Ltac2 environment +through a specific syntax consistent with the antiquotations presented in +the notation section. + +.. prodn:: term += $@lident + +In a Coq term, writing :g:`$x` is semantically equivalent to +:g:`ltac2:(Control.refine (fun () => x))`, up to re-typechecking. It allows to +insert in a concise way an Ltac2 variable of type :n:`constr` into a Coq term. + +Match over terms +~~~~~~~~~~~~~~~~ + +Ltac2 features a construction similar to Ltac1 :n:`match` over terms, although +in a less hard-wired way. + +.. productionlist:: coq + ltac2_term : match! `ltac2_term` with `constrmatching` .. `constrmatching` end + : lazy_match! `ltac2_term` with `constrmatching` .. `constrmatching` end + : multi_match! `ltac2_term` with `constrmatching` .. `constrmatching` end + constrmatching : | `constrpattern` => `ltac2_term` + constrpattern : `term` + : context [ `term` ] + : context `lident` [ `term` ] + +This construction is not primitive and is desugared at parsing time into +calls to term matching functions from the `Pattern` module. Internally, it is +implemented thanks to a specific scope accepting the :n:`@constrmatching` syntax. + +Variables from the :n:`@constrpattern` are statically bound in the body of the branch, to +values of type `constr` for the variables from the :n:`@constr` pattern and to a +value of type `Pattern.context` for the variable :n:`@lident`. + +Note that unlike Ltac, only lowercase identifiers are valid as Ltac2 +bindings, so that there will be a syntax error if one of the bound variables +starts with an uppercase character. + +The semantics of this construction is otherwise the same as the corresponding +one from Ltac1, except that it requires the goal to be focused. + +Match over goals +~~~~~~~~~~~~~~~~ + +Similarly, there is a way to match over goals in an elegant way, which is +just a notation desugared at parsing time. + +.. productionlist:: coq + ltac2_term : match! [ reverse ] goal with `goalmatching` ... `goalmatching` end + : lazy_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end + : multi_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end + goalmatching : | [ `hypmatching` ... `hypmatching` |- `constrpattern` ] => `ltac2_term` + hypmatching : `lident` : `constrpattern` + : _ : `constrpattern` + +Variables from :n:`@hypmatching` and :n:`@constrpattern` are bound in the body of the +branch. Their types are: + +- ``constr`` for pattern variables appearing in a :n:`@term` +- ``Pattern.context`` for variables binding a context +- ``ident`` for variables binding a hypothesis name. + +The same identifier caveat as in the case of matching over constr applies, and +this features has the same semantics as in Ltac1. In particular, a ``reverse`` +flag can be specified to match hypotheses from the more recently introduced to +the least recently introduced one. + +Notations +--------- + +Notations are the crux of the usability of Ltac1. We should be able to recover +a feeling similar to the old implementation by using and abusing notations. + +Scopes +~~~~~~ + +A scope is a name given to a grammar entry used to produce some Ltac2 expression +at parsing time. Scopes are described using a form of S-expression. + +.. prodn:: + ltac2_scope ::= @string %| @integer %| @lident ({+, @ltac2_scope}) + +A few scopes contain antiquotation features. For sake of uniformity, all +antiquotations are introduced by the syntax :n:`$@lident`. + +The following scopes are built-in. + +- :n:`constr`: + + + parses :n:`c = @term` and produces :n:`constr:(c)` + +- :n:`ident`: + + + parses :n:`id = @ident` and produces :n:`ident:(id)` + + parses :n:`$(x = @ident)` and produces the variable :n:`x` + +- :n:`list0(@ltac2_scope)`: + + + if :n:`@ltac2_scope` parses :production:`entry`, parses :n:`(@entry__0, ..., @entry__n)` and produces + :n:`[@entry__0; ...; @entry__n]`. + +- :n:`list0(@ltac2_scope, sep = @string__sep)`: + + + if :n:`@ltac2_scope` parses :n:`@entry`, parses :n:`(@entry__0 @string__sep ... @string__sep @entry__n)` + and produces :n:`[@entry__0; ...; @entry__n]`. + +- :n:`list1`: same as :n:`list0` (with or without separator) but parses :n:`{+ @entry}` instead + of :n:`{* @entry}`. + +- :n:`opt(@ltac2_scope)` + + + if :n:`@ltac2_scope` parses :n:`@entry`, parses :n:`{? @entry}` and produces either :n:`None` or + :n:`Some x` where :n:`x` is the parsed expression. + +- :n:`self`: + + + parses a Ltac2 expression at the current level and return it as is. + +- :n:`next`: + + + parses a Ltac2 expression at the next level and return it as is. + +- :n:`tactic(n = @integer)`: + + + parses a Ltac2 expression at the provided level :n:`n` and return it as is. + +- :n:`thunk(@ltac2_scope)`: + + + parses the same as :n:`scope`, and if :n:`e` is the parsed expression, returns + :n:`fun () => e`. + +- :n:`STRING`: + + + parses the corresponding string as an identifier and returns :n:`()`. + +- :n:`keyword(s = @string)`: + + + parses the string :n:`s` as a keyword and returns `()`. + +- :n:`terminal(s = @string)`: + + + parses the string :n:`s` as a keyword, if it is already a + keyword, otherwise as an :n:`@ident`. Returns `()`. + +- :n:`seq(@ltac2_scope__1, ..., @ltac2_scope__2)`: + + + parses :n:`scope__1`, ..., :n:`scope__n` in this order, and produces a tuple made + out of the parsed values in the same order. As an optimization, all + subscopes of the form :n:`STRING` are left out of the returned tuple, instead + of returning a useless unit value. It is forbidden for the various + subscopes to refer to the global entry using self or next. + +A few other specific scopes exist to handle Ltac1-like syntax, but their use is +discouraged and they are thus not documented. + +For now there is no way to declare new scopes from Ltac2 side, but this is +planned. + +Notations +~~~~~~~~~ + +The Ltac2 parser can be extended by syntactic notations. + +.. cmd:: Ltac2 Notation {+ @lident (@ltac2_scope) %| @string } {? : @integer} := @ltac2_term + :name: Ltac2 Notation + + A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded + to the provided body where every token from the notation is let-bound to the + corresponding generated expression. + + .. example:: + + Assume we perform: + + .. coqdoc:: + + Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. + + Then the following expression + + `let y := @X in foo (nat -> nat) x $y` + + will expand at parsing time to + + `let y := @X in` + `let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids` + + Beware that the order of evaluation of multiple let-bindings is not specified, + so that you may have to resort to thunking to ensure that side-effects are + performed at the right time. + +Abbreviations +~~~~~~~~~~~~~ + +.. cmdv:: Ltac2 Notation @lident := @ltac2_term + + This command introduces a special kind of notations, called abbreviations, + that is designed so that it does not add any parsing rules. It is similar in + spirit to Coq abbreviations, insofar as its main purpose is to give an + absolute name to a piece of pure syntax, which can be transparently referred + by this name as if it were a proper definition. + + The abbreviation can then be manipulated just as a normal Ltac2 definition, + except that it is expanded at internalization time into the given expression. + Furthermore, in order to make this kind of construction useful in practice in + an effectful language such as Ltac2, any syntactic argument to an abbreviation + is thunked on-the-fly during its expansion. + +For instance, suppose that we define the following. + +:n:`Ltac2 Notation foo := fun x => x ().` + +Then we have the following expansion at internalization time. + +:n:`foo 0 ↦ (fun x => x ()) (fun _ => 0)` + +Note that abbreviations are not typechecked at all, and may result in typing +errors after expansion. + +Evaluation +---------- + +Ltac2 features a toplevel loop that can be used to evaluate expressions. + +.. cmd:: Ltac2 Eval @ltac2_term + :name: Ltac2 Eval + + This command evaluates the term in the current proof if there is one, or in the + global environment otherwise, and displays the resulting value to the user + together with its type. This command is pure in the sense that it does not + modify the state of the proof, and in particular all side-effects are discarded. + +Debug +----- + +.. opt:: Ltac2 Backtrace + + When this option is set, toplevel failures will be printed with a backtrace. + +Compatibility layer with Ltac1 +------------------------------ + +Ltac1 from Ltac2 +~~~~~~~~~~~~~~~~ + +Simple API +++++++++++ + +One can call Ltac1 code from Ltac2 by using the :n:`ltac1` quotation. It parses +a Ltac1 expression, and semantics of this quotation is the evaluation of the +corresponding code for its side effects. In particular, it cannot return values, +and the quotation has type :n:`unit`. + +Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited +to the use of standalone function calls. + +Low-level API ++++++++++++++ + +There exists a lower-level FFI into Ltac1 that is not recommended for daily use, +which is available in the `Ltac2.Ltac1` module. This API allows to directly +manipulate dynamically-typed Ltac1 values, either through the function calls, +or using the `ltac1val` quotation. The latter parses the same as `ltac1`, but +has type `Ltac2.Ltac1.t` instead of `unit`, and dynamically behaves as an Ltac1 +thunk, i.e. `ltac1val:(foo)` corresponds to the tactic closure that Ltac1 +would generate from `idtac; foo`. + +Due to intricate dynamic semantics, understanding when Ltac1 value quotations +focus is very hard. This is why some functions return a continuation-passing +style value, as it can dispatch dynamically between focused and unfocused +behaviour. + +Ltac2 from Ltac1 +~~~~~~~~~~~~~~~~ + +Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation +instead. + +Note that the tactic expression is evaluated eagerly, if one wants to use it as +an argument to a Ltac1 function, she has to resort to the good old +:n:`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately +and won't print anything. + +.. coqtop:: in + + From Ltac2 Require Import Ltac2. + Set Default Proof Mode "Classic". + +.. coqtop:: all + + Ltac mytac tac := idtac "wow"; tac. + + Goal True. + Proof. + Fail mytac ltac2:(fail). + +Transition from Ltac1 +--------------------- + +Owing to the use of a lot of notations, the transition should not be too +difficult. In particular, it should be possible to do it incrementally. That +said, we do *not* guarantee you it is going to be a blissful walk either. +Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq +will help you. + +We list the major changes and the transition strategies hereafter. + +Syntax changes +~~~~~~~~~~~~~~ + +Due to conflicts, a few syntactic rules have changed. + +- The dispatch tactical :n:`tac; [foo|bar]` is now written :n:`tac > [foo|bar]`. +- Levels of a few operators have been revised. Some tacticals now parse as if + they were a normal function, i.e. one has to put parentheses around the + argument when it is complex, e.g an abstraction. List of affected tacticals: + :n:`try`, :n:`repeat`, :n:`do`, :n:`once`, :n:`progress`, :n:`time`, :n:`abstract`. +- :n:`idtac` is no more. Either use :n:`()` if you expect nothing to happen, + :n:`(fun () => ())` if you want a thunk (see next section), or use printing + primitives from the :n:`Message` module if you want to display something. + +Tactic delay +~~~~~~~~~~~~ + +Tactics are not magically delayed anymore, neither as functions nor as +arguments. It is your responsibility to thunk them beforehand and apply them +at the call site. + +A typical example of a delayed function: + +:n:`Ltac foo := blah.` + +becomes + +:n:`Ltac2 foo () := blah.` + +All subsequent calls to `foo` must be applied to perform the same effect as +before. + +Likewise, for arguments: + +:n:`Ltac bar tac := tac; tac; tac.` + +becomes + +:n:`Ltac2 bar tac := tac (); tac (); tac ().` + +We recommend the use of syntactic notations to ease the transition. For +instance, the first example can alternatively be written as: + +:n:`Ltac2 foo0 () := blah.` +:n:`Ltac2 Notation foo := foo0 ().` + +This allows to keep the subsequent calls to the tactic as-is, as the +expression `foo` will be implicitly expanded everywhere into `foo0 ()`. Such +a trick also works for arguments, as arguments of syntactic notations are +implicitly thunked. The second example could thus be written as follows. + +:n:`Ltac2 bar0 tac := tac (); tac (); tac ().` +:n:`Ltac2 Notation bar := bar0.` + +Variable binding +~~~~~~~~~~~~~~~~ + +Ltac1 relies on complex dynamic trickery to be able to tell apart bound +variables from terms, hypotheses, etc. There is no such thing in Ltac2, +as variables are recognized statically and other constructions do not live in +the same syntactic world. Due to the abuse of quotations, it can sometimes be +complicated to know what a mere identifier represents in a tactic expression. We +recommend tracking the context and letting the compiler print typing errors to +understand what is going on. + +We list below the typical changes one has to perform depending on the static +errors produced by the typechecker. + +In Ltac expressions ++++++++++++++++++++ + +.. exn:: Unbound ( value | constructor ) X + + * if `X` is meant to be a term from the current stactic environment, replace + the problematic use by `'X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +In quotations ++++++++++++++ + +.. exn:: The reference X was not found in the current environment + + * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, + replace the problematic use by `$X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +Exception catching +~~~~~~~~~~~~~~~~~~ + +Ltac2 features a proper exception-catching mechanism. For this reason, the +Ltac1 mechanism relying on `fail` taking integers, and tacticals decreasing it, +has been removed. Now exceptions are preserved by all tacticals, and it is +your duty to catch them and reraise them depending on your use. diff --git a/dune b/dune index 787c3c3674..4beba1c14f 100644 --- a/dune +++ b/dune @@ -18,8 +18,9 @@ (targets .vfiles.d) (deps (source_tree theories) - (source_tree plugins)) - (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins -type f -name *.v`")))) + (source_tree plugins) + (source_tree user-contrib)) + (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins user-contrib -type f -name *.v`")))) (alias (name vodeps) diff --git a/test-suite/Makefile b/test-suite/Makefile index ba591ede20..94011447d7 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -99,7 +99,7 @@ INTERACTIVE := interactive UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ - coqdoc ssr arithmetic + coqdoc ssr arithmetic ltac2 # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) @@ -181,6 +181,7 @@ summary: $(call summary_dir, "tools/ tests", tools); \ $(call summary_dir, "Unit tests", unit-tests); \ $(call summary_dir, "Machine arithmetic tests", arithmetic); \ + $(call summary_dir, "Ltac2 tests", ltac2); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -319,7 +320,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v } > "$@" ssr: $(wildcard ssr/*.v:%.v=%.v.log) -$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v)): %.v.log: %.v $(PREREQUISITELOG) +$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v ltac2/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ diff --git a/test-suite/ltac2/compat.v b/test-suite/ltac2/compat.v new file mode 100644 index 0000000000..489fa638e4 --- /dev/null +++ b/test-suite/ltac2/compat.v @@ -0,0 +1,58 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +(** Test calls to Ltac1 from Ltac2 *) + +Ltac2 foo () := ltac1:(discriminate). + +Goal true = false -> False. +Proof. +foo (). +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(match goal with [ H : ?P |- _ ] => rewrite H end); reflexivity. +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(rewrite H); reflexivity. +Abort. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac2 bar nay := ltac1:(discriminate nay). + +Fail Ltac2 pose1 (v : constr) := + ltac1:(pose $v). + +(** Test calls to Ltac2 from Ltac1 *) + +Set Default Proof Mode "Classic". + +Ltac foo := ltac2:(foo ()). + +Goal true = false -> False. +Proof. +ltac2:(foo ()). +Qed. + +Goal true = false -> False. +Proof. +foo. +Qed. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac bar x := ltac2:(foo x). + +Ltac mytac tac := idtac "wow". + +Goal True. +Proof. +(** Fails because quotation is evaluated eagerly *) +Fail mytac ltac2:(fail). +(** One has to thunk thanks to the idtac trick *) +let t := idtac; ltac2:(fail) in mytac t. +constructor. +Qed. diff --git a/test-suite/ltac2/errors.v b/test-suite/ltac2/errors.v new file mode 100644 index 0000000000..c677f6af5d --- /dev/null +++ b/test-suite/ltac2/errors.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Ltac2. + +Goal True. +Proof. +let x := Control.plus + (fun () => let _ := constr:(nat -> 0) in 0) + (fun e => match e with Not_found => 1 | _ => 2 end) in +match Int.equal x 2 with +| true => () +| false => Control.throw (Tactic_failure None) +end. +Abort. diff --git a/test-suite/ltac2/example1.v b/test-suite/ltac2/example1.v new file mode 100644 index 0000000000..023791050f --- /dev/null +++ b/test-suite/ltac2/example1.v @@ -0,0 +1,27 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Control. + +(** Alternative implementation of the hyp primitive *) +Ltac2 get_hyp_by_name x := + let h := hyps () in + let rec find x l := match l with + | [] => zero Not_found + | p :: l => + match p with + | (id, _, t) => + match Ident.equal x id with + | true => t + | false => find x l + end + end + end in + find x h. + +Print Ltac2 get_hyp_by_name. + +Goal forall n m, n + m = 0 -> n = 0. +Proof. +refine (fun () => '(fun n m H => _)). +let t := get_hyp_by_name @H in Message.print (Message.of_constr t). +Abort. diff --git a/test-suite/ltac2/example2.v b/test-suite/ltac2/example2.v new file mode 100644 index 0000000000..c953d25061 --- /dev/null +++ b/test-suite/ltac2/example2.v @@ -0,0 +1,281 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Set Default Goal Selector "all". + +Goal exists n, n = 0. +Proof. +split with (x := 0). +reflexivity. +Qed. + +Goal exists n, n = 0. +Proof. +split with 0. +split. +Qed. + +Goal exists n, n = 0. +Proof. +let myvar := Std.NamedHyp @x in split with ($myvar := 0). +split. +Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +eelim &H. +split. +Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +elim &H with 0. +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +Fail apply &H. +apply &H with (m := 0). +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> (0 = 1) -> P 0. +Proof. +intros P H e. +apply &H with (m := 1) in e. +exact e. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +eapply &H. +split. +Qed. + +Goal exists n, n = 0. +Proof. +Fail constructor 1. +constructor 1 with (x := 0). +split. +Qed. + +Goal exists n, n = 0. +Proof. +econstructor 1. +split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +induction &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +induction &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +destruct &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +destruct &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall b1 b2, andb b1 b2 = andb b2 b1. +Proof. +intros b1 b2. +destruct &b1 as [|], &b2 as [|]; split. +Qed. + +Goal forall n m, n = 0 -> n + m = m. +Proof. +intros n m Hn. +rewrite &Hn; split. +Qed. + +Goal forall n m p, n = m -> p = m -> 0 = n -> p = 0. +Proof. +intros n m p He He' Hn. +rewrite &He, <- &He' in Hn. +rewrite &Hn. +split. +Qed. + +Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. +Proof. +intros n m He He' He''. +rewrite <- &He by assumption. +Control.refine (fun () => &He''). +Qed. + +Goal forall n (r := if true then n else 0), r = n. +Proof. +intros n r. +hnf in r. +split. +Qed. + +Goal 1 = 0 -> 0 = 0. +Proof. +intros H. +pattern 0 at 1. +let occ := 2 in pattern 1 at 1, 0 at $occ in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +vm_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +native_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2 - 0 -> True. +Proof. +intros H. +vm_compute plus in H. +reflexivity. +Qed. + +Goal 1 = 0 -> True /\ True. +Proof. +intros H. +split; fold (1 + 0) (1 + 0) in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +cbv [ Nat.add ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +let x := reference:(Nat.add) in +cbn beta iota delta [ $x ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +simpl beta. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +lazy. +reflexivity. +Qed. + +Goal let x := 1 + 1 - 1 in x = x. +Proof. +intros x. +unfold &x at 1. +let x := reference:(Nat.sub) in unfold Nat.add, $x in x. +reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +exists 0, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +eexists _, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +refine '(let x := 0 in _). +eexists; exists &x; reflexivity. +Qed. + +Goal True. +Proof. +pose (X := True). +constructor. +Qed. + +Goal True. +Proof. +pose True as X. +constructor. +Qed. + +Goal True. +Proof. +let x := @foo in +set ($x := True) in * |-. +constructor. +Qed. + +Goal 0 = 0. +Proof. +remember 0 as n eqn: foo at 1. +rewrite foo. +reflexivity. +Qed. + +Goal True. +Proof. +assert (H := 0 + 0). +constructor. +Qed. + +Goal True. +Proof. +assert (exists n, n = 0) as [n Hn]. ++ exists 0; reflexivity. ++ exact I. +Qed. + +Goal True -> True. +Proof. +assert (H : 0 + 0 = 0) by reflexivity. +intros x; exact x. +Qed. + +Goal 1 + 1 = 2. +Proof. +change (?a + 1 = 2) with (2 = $a + 1). +reflexivity. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl). +destruct H. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl) as []. +Qed. diff --git a/test-suite/ltac2/matching.v b/test-suite/ltac2/matching.v new file mode 100644 index 0000000000..4338cbd32f --- /dev/null +++ b/test-suite/ltac2/matching.v @@ -0,0 +1,71 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 Type exn ::= [ Nope ]. + +Ltac2 check_id id id' := match Ident.equal id id' with +| true => () +| false => Control.throw Nope +end. + +Goal True -> False. +Proof. +Fail +let b := { contents := true } in +let f c := + match b.(contents) with + | true => Message.print (Message.of_constr c); b.(contents) := false; fail + | false => () + end +in +(** This fails because the matching is not allowed to backtrack once + it commits to a branch*) +lazy_match! '(nat -> bool) with context [?a] => f a end. +lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. + +(** This one works by taking the second match context, i.e. ?a := nat *) +let b := { contents := true } in +let f c := + match b.(contents) with + | true => b.(contents) := false; fail + | false => Message.print (Message.of_constr c) + end +in +match! '(nat -> bool) with context [?a] => f a end. +Abort. + +Goal forall (i j : unit) (x y : nat) (b : bool), True. +Proof. +Fail match! goal with +| [ h : ?t, h' : ?t |- _ ] => () +end. +intros i j x y b. +match! goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @x; + check_id h' @y +end. +match! reverse goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @j; + check_id h' @i +end. +Abort. + +(* Check #79 *) +Goal 2 = 3. + Control.plus + (fun () + => lazy_match! goal with + | [ |- 2 = 3 ] => Control.zero (Tactic_failure None) + | [ |- 2 = _ ] => Control.zero (Tactic_failure (Some (Message.of_string "should not be printed"))) + end) + (fun e + => match e with + | Tactic_failure c + => match c with + | None => () + | _ => Control.zero e + end + | e => Control.zero e + end). +Abort. diff --git a/test-suite/ltac2/quot.v b/test-suite/ltac2/quot.v new file mode 100644 index 0000000000..624c4ad0c1 --- /dev/null +++ b/test-suite/ltac2/quot.v @@ -0,0 +1,26 @@ +Require Import Ltac2.Ltac2. + +(** Test for quotations *) + +Ltac2 ref0 () := reference:(&x). +Ltac2 ref1 () := reference:(nat). +Ltac2 ref2 () := reference:(Datatypes.nat). +Fail Ltac2 ref () := reference:(i_certainly_dont_exist). +Fail Ltac2 ref () := reference:(And.Me.neither). + +Goal True. +Proof. +let x := constr:(I) in +let y := constr:((fun z => z) $x) in +Control.refine (fun _ => y). +Qed. + +Goal True. +Proof. +(** Here, Ltac2 should not put its variables in the same environment as + Ltac1 otherwise the second binding fails as x is bound but not an + ident. *) +let x := constr:(I) in +let y := constr:((fun x => x) $x) in +Control.refine (fun _ => y). +Qed. diff --git a/test-suite/ltac2/rebind.v b/test-suite/ltac2/rebind.v new file mode 100644 index 0000000000..e1c20a2059 --- /dev/null +++ b/test-suite/ltac2/rebind.v @@ -0,0 +1,34 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 mutable foo () := constructor. + +Goal True. +Proof. +foo (). +Qed. + +Ltac2 Set foo := fun _ => fail. + +Goal True. +Proof. +Fail foo (). +constructor. +Qed. + +(** Not the right type *) +Fail Ltac2 Set foo := 0. + +Ltac2 bar () := (). + +(** Cannot redefine non-mutable tactics *) +Fail Ltac2 Set bar := fun _ => (). + +(** Subtype check *) + +Ltac2 mutable rec f x := f x. + +Fail Ltac2 Set f := fun x => x. + +Ltac2 mutable g x := x. + +Ltac2 Set g := f. diff --git a/test-suite/ltac2/stuff/ltac2.v b/test-suite/ltac2/stuff/ltac2.v new file mode 100644 index 0000000000..370bc70d15 --- /dev/null +++ b/test-suite/ltac2/stuff/ltac2.v @@ -0,0 +1,143 @@ +Require Import Ltac2.Ltac2. + +Ltac2 foo (_ : int) := + let f (x : int) := x in + let _ := f 0 in + f 1. + +Print Ltac2 foo. + +Import Control. + +Ltac2 exact x := refine (fun () => x). + +Print Ltac2 refine. +Print Ltac2 exact. + +Ltac2 foo' () := ident:(bla). + +Print Ltac2 foo'. + +Ltac2 bar x h := match x with +| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) +| Some x => x +end. + +Print Ltac2 bar. + +Ltac2 qux := Some 0. + +Print Ltac2 qux. + +Ltac2 Type foo := [ Foo (int) ]. + +Fail Ltac2 qux0 := Foo None. + +Ltac2 Type 'a ref := { mutable contents : 'a }. + +Fail Ltac2 qux0 := { contents := None }. +Ltac2 foo0 () := { contents := None }. + +Print Ltac2 foo0. + +Ltac2 qux0 x := x.(contents). +Ltac2 qux1 x := x.(contents) := x.(contents). + +Ltac2 qux2 := ([1;2], true). + +Print Ltac2 qux0. +Print Ltac2 qux1. +Print Ltac2 qux2. + +Import Control. + +Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). + +Print Ltac2 qux3. + +Ltac2 Type rec nat := [ O | S (nat) ]. + +Ltac2 message_of_nat n := +let rec aux n := +match n with +| O => Message.of_string "O" +| S n => Message.concat (Message.of_string "S") (aux n) +end in aux n. + +Print Ltac2 message_of_nat. + +Ltac2 numgoals () := + let r := { contents := O } in + enter (fun () => r.(contents) := S (r.(contents))); + r.(contents). + +Print Ltac2 numgoals. + +Goal True /\ False. +Proof. +let n := numgoals () in Message.print (message_of_nat n). +refine (fun () => open_constr:((fun x => conj _ _) 0)); (). +let n := numgoals () in Message.print (message_of_nat n). + +Fail (hyp ident:(x)). +Fail (enter (fun () => hyp ident:(There_is_no_spoon); ())). + +enter (fun () => Message.print (Message.of_string "foo")). + +enter (fun () => Message.print (Message.of_constr (goal ()))). +Fail enter (fun () => Message.print (Message.of_constr (qux3 ident:(x)))). +enter (fun () => plus (fun () => constr:(_); ()) (fun _ => ())). +plus + (fun () => enter (fun () => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). +let x := { contents := 0 } in +let x := x.(contents) := x.(contents) in x. +Abort. + +Ltac2 Type exn ::= [ Foo ]. + +Goal True. +Proof. +plus (fun () => zero Foo) (fun _ => ()). +Abort. + +Ltac2 Type exn ::= [ Bar (string) ]. + +Goal True. +Proof. +Fail zero (Bar "lol"). +Abort. + +Ltac2 Notation "refine!" c(thunk(constr)) := refine c. + +Goal True. +Proof. +refine! I. +Abort. + +Goal True. +Proof. +let x () := plus (fun () => 0) (fun _ => 1) in +match case x with +| Val x => + match x with + | (x, k) => Message.print (Message.of_int (k Not_found)) + end +| Err x => Message.print (Message.of_string "Err") +end. +Abort. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +refine (fun () => '(fun H => _)). +Std.case true (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). +refine (fun () => 'eq_refl). +Qed. + +Goal forall x, 1 + x = x + 1. +Proof. +refine (fun () => '(fun x => _)). +Std.cbv { + Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; + Std.rZeta := true; Std.rDelta := true; Std.rConst := []; +} { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. +Abort. diff --git a/test-suite/ltac2/tacticals.v b/test-suite/ltac2/tacticals.v new file mode 100644 index 0000000000..1a2fbcbb37 --- /dev/null +++ b/test-suite/ltac2/tacticals.v @@ -0,0 +1,34 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Goal True. +Proof. +Fail fail. +Fail solve [ () ]. +try fail. +repeat fail. +repeat (). +solve [ constructor ]. +Qed. + +Goal True. +Proof. +first [ + Message.print (Message.of_string "Yay"); fail +| constructor +| Message.print (Message.of_string "I won't be printed") +]. +Qed. + +Goal True /\ True. +Proof. +Fail split > [ split | |]. +split > [split | split]. +Qed. + +Goal True /\ (True -> True) /\ True. +Proof. +split > [ | split] > [split | .. | split]. +intros H; refine &H. +Qed. diff --git a/test-suite/ltac2/typing.v b/test-suite/ltac2/typing.v new file mode 100644 index 0000000000..9f18292716 --- /dev/null +++ b/test-suite/ltac2/typing.v @@ -0,0 +1,72 @@ +Require Import Ltac2.Ltac2. + +(** Ltac2 is typed à la ML. *) + +Ltac2 test0 n := Int.add n 1. + +Print Ltac2 test0. + +Ltac2 test1 () := test0 0. + +Print Ltac2 test1. + +Fail Ltac2 test2 () := test0 true. + +Fail Ltac2 test2 () := test0 0 0. + +Ltac2 test3 f x := x, (f x, x). + +Print Ltac2 test3. + +(** Polymorphism *) + +Ltac2 rec list_length l := +match l with +| [] => 0 +| x :: l => Int.add 1 (list_length l) +end. + +Print Ltac2 list_length. + +(** Pattern-matching *) + +Ltac2 ifb b f g := match b with +| true => f () +| false => g () +end. + +Print Ltac2 ifb. + +Ltac2 if_not_found e f g := match e with +| Not_found => f () +| _ => g () +end. + +Fail Ltac2 ifb' b f g := match b with +| true => f () +end. + +Fail Ltac2 if_not_found' e f g := match e with +| Not_found => f () +end. + +(** Reimplementing 'do'. Return value of the function useless. *) + +Ltac2 rec do n tac := match Int.equal n 0 with +| true => () +| false => tac (); do (Int.sub n 1) tac +end. + +Print Ltac2 do. + +(** Non-function pure values are OK. *) + +Ltac2 tuple0 := ([1; 2], true, (fun () => "yay")). + +Print Ltac2 tuple0. + +(** Impure values are not. *) + +Fail Ltac2 not_a_value := { contents := 0 }. +Fail Ltac2 not_a_value := "nope". +Fail Ltac2 not_a_value := list_length []. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index fa8b771a74..6ddc503542 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -214,7 +214,7 @@ let record_dune d ff = if Sys.file_exists sd && Sys.is_directory sd then let out = open_out (bpath [sd;"dune"]) in let fmt = formatter_of_out_channel out in - if List.nth d 0 = "plugins" then + if List.nth d 0 = "plugins" || List.nth d 0 = "user-contrib" then fprintf fmt "(include plugin_base.dune)@\n"; out_install fmt d ff; List.iter (pp_dep d fmt) ff; @@ -224,17 +224,20 @@ let record_dune d ff = eprintf "error in coq_dune, a directory disappeared: %s@\n%!" sd (* File Scanning *) -let scan_mlg m d = - let dir = ["plugins"; d] in +let scan_mlg ~root m d = + let dir = [root; d] in let m = DirMap.add dir [] m in let mlg = Sys.(List.filter (fun f -> Filename.(check_suffix f ".mlg")) Array.(to_list @@ readdir (bpath dir))) in - List.fold_left (fun m f -> add_map_list ["plugins"; d] (MLG f) m) m mlg + List.fold_left (fun m f -> add_map_list [root; d] (MLG f) m) m mlg -let scan_plugins m = +let scan_dir ~root m = let is_plugin_directory dir = Sys.(is_directory dir && file_exists (bpath [dir;"plugin_base.dune"])) in - let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath ["plugins";f]) Array.(to_list @@ readdir "plugins")) in - List.fold_left scan_mlg m dirs + let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath [root;f]) Array.(to_list @@ readdir root)) in + List.fold_left (scan_mlg ~root) m dirs + +let scan_plugins m = scan_dir ~root:"plugins" m +let scan_usercontrib m = scan_dir ~root:"user-contrib" m (* This will be removed when we drop support for Make *) let fix_cmo_cma file = @@ -291,5 +294,6 @@ let exec_ifile f = let _ = exec_ifile (fun ic -> let map = scan_plugins DirMap.empty in + let map = scan_usercontrib map in let map = read_vfiles ic map in out_map map) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 7114965a11..8823206252 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -529,6 +529,11 @@ let coqdep () = add_rec_dir_import add_known "plugins" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; + let user = "user-contrib" in + if Sys.file_exists user then begin + add_rec_dir_no_import add_known user []; + add_rec_dir_no_import (fun _ -> add_caml_known) user []; + end; end else begin (* option_boot is actually always false in this branch *) Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index aa023e6986..a638906c11 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -17,6 +17,9 @@ open Coqdep_common options (see for instance [option_natdynlk] below). *) +let split_period = Str.split (Str.regexp (Str.quote ".")) +let add_q_include path l = add_rec_dir_no_import add_known path (split_period l) + let rec parse = function | "-dyndep" :: "no" :: ll -> option_dynlink := No; parse ll | "-dyndep" :: "opt" :: ll -> option_dynlink := Opt; parse ll @@ -33,6 +36,7 @@ let rec parse = function add_caml_dir r; norec_dirs := StrSet.add r !norec_dirs; parse ll + | "-Q" :: r :: ln :: ll -> add_q_include r ln; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () diff --git a/user-contrib/Ltac2/Array.v b/user-contrib/Ltac2/Array.v new file mode 100644 index 0000000000..11b64e3515 --- /dev/null +++ b/user-contrib/Ltac2/Array.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'a array := "ltac2" "array_make". +Ltac2 @external length : 'a array -> int := "ltac2" "array_length". +Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". +Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/user-contrib/Ltac2/Char.v b/user-contrib/Ltac2/Char.v new file mode 100644 index 0000000000..29fef60f2c --- /dev/null +++ b/user-contrib/Ltac2/Char.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char := "ltac2" "char_of_int". +Ltac2 @external to_int : char -> int := "ltac2" "char_to_int". diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v new file mode 100644 index 0000000000..d8d222730e --- /dev/null +++ b/user-contrib/Ltac2/Constr.v @@ -0,0 +1,72 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr := "ltac2" "constr_type". +(** Return the type of a term *) + +Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". +(** Strict syntactic equality: only up to α-conversion and evar expansion *) + +Module Unsafe. + +(** Low-level access to kernel terms. Use with care! *) + +Ltac2 Type case. + +Ltac2 Type kind := [ +| Rel (int) +| Var (ident) +| Meta (meta) +| Evar (evar, constr array) +| Sort (sort) +| Cast (constr, cast, constr) +| Prod (ident option, constr, constr) +| Lambda (ident option, constr, constr) +| LetIn (ident option, constr, constr, constr) +| App (constr, constr array) +| Constant (constant, instance) +| Ind (inductive, instance) +| Constructor (constructor, instance) +| Case (case, constr, constr, constr array) +| Fix (int array, int, ident option array, constr array, constr array) +| CoFix (int, ident option array, constr array, constr array) +| Proj (projection, constr) +]. + +Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". + +Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". + +Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". +(** Checks that a constr generated by unsafe means is indeed safe in the + current environment, and returns it, or the error otherwise. Panics if + not focussed. *) + +Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". +(** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with + [r₁;...;rₙ] in [c]. *) + +Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "constr_closenl". +(** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with + [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) + +Ltac2 @ external case : inductive -> case := "ltac2" "constr_case". +(** Generate the case information for a given inductive type. *) + +Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "constr_constructor". +(** Generate the i-th constructor for a given inductive type. Indexing starts + at 0. Panics if there is no such constructor. *) + +End Unsafe. + +Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". +(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a + focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is + the proof built by the tactic. *) diff --git a/user-contrib/Ltac2/Control.v b/user-contrib/Ltac2/Control.v new file mode 100644 index 0000000000..071c2ea8ce --- /dev/null +++ b/user-contrib/Ltac2/Control.v @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a := "ltac2" "throw". +(** Fatal exception throwing. This does not induce backtracking. *) + +(** Generic backtracking control *) + +Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". +Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". +Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". +Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". +Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". +Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". +Ltac2 @ external case : (unit -> 'a) -> ('a * (exn -> 'a)) result := "ltac2" "case". + +(** Proof state manipulation *) + +Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". +Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". +Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". + +Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". +(** Adds the given evar to the list of goals as the last one. If it is + already defined in the current state, don't do anything. Panics if the + evar is not in the current state. *) + +Ltac2 @ external progress : (unit -> 'a) -> 'a := "ltac2" "progress". + +(** Goal inspection *) + +Ltac2 @ external goal : unit -> constr := "ltac2" "goal". +(** Panics if there is not exactly one goal under focus. Otherwise returns + the conclusion of this goal. *) + +Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, looks for the section variable with the given name. + If there is one, looks for the hypothesis with the given name. *) + +Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" "hyps". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, returns the list of section variables. + If there is one, returns the list of hypotheses. In both cases, the + list is ordered with rightmost values being last introduced. *) + +(** Refinement *) + +Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". + +(** Evars *) + +Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_holes". +(** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if + all evars generated by the call to [x] have not been solved when [f] + returns. *) + +(** Misc *) + +Ltac2 @ external time : string option -> (unit -> 'a) -> 'a := "ltac2" "time". +(** Displays the time taken by a tactic to evaluate. *) + +Ltac2 @ external abstract : ident option -> (unit -> unit) -> unit := "ltac2" "abstract". +(** Abstract a subgoal. *) + +Ltac2 @ external check_interrupt : unit -> unit := "ltac2" "check_interrupt". +(** For internal use. *) diff --git a/user-contrib/Ltac2/Env.v b/user-contrib/Ltac2/Env.v new file mode 100644 index 0000000000..4aa1718c9a --- /dev/null +++ b/user-contrib/Ltac2/Env.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Std.reference option := "ltac2" "env_get". +(** Returns the global reference corresponding to the absolute name given as + argument if it exists. *) + +Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". +(** Returns the list of all global references whose absolute name contains + the argument list as a prefix. *) + +Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". +(** Returns the absolute name of the given reference. Panics if the reference + does not exist. *) + +Ltac2 @ external instantiate : Std.reference -> constr := "ltac2" "env_instantiate". +(** Returns a fresh instance of the corresponding reference, in particular + generating fresh universe variables and constraints when this reference is + universe-polymorphic. *) diff --git a/user-contrib/Ltac2/Fresh.v b/user-contrib/Ltac2/Fresh.v new file mode 100644 index 0000000000..5e876bb077 --- /dev/null +++ b/user-contrib/Ltac2/Fresh.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> t := "ltac2" "fresh_free_union". + +Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". + +Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". + +End Free. + +Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". +(** Generate a fresh identifier with the given base name which is not a + member of the provided set of free variables. *) diff --git a/user-contrib/Ltac2/Ident.v b/user-contrib/Ltac2/Ident.v new file mode 100644 index 0000000000..55456afbe2 --- /dev/null +++ b/user-contrib/Ltac2/Ident.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> bool := "ltac2" "ident_equal". + +Ltac2 @ external of_string : string -> t option := "ltac2" "ident_of_string". + +Ltac2 @ external to_string : t -> string := "ltac2" "ident_to_string". diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v new file mode 100644 index 0000000000..16e7d7a6f9 --- /dev/null +++ b/user-contrib/Ltac2/Init.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> bool := "ltac2" "int_equal". +Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". +Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". +Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". +Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". +Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/user-contrib/Ltac2/Ltac1.v b/user-contrib/Ltac2/Ltac1.v new file mode 100644 index 0000000000..c4e0b606d0 --- /dev/null +++ b/user-contrib/Ltac2/Ltac1.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t := "ltac2" "ltac1_ref". +(** Returns the Ltac1 definition with the given absolute name. *) + +Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". +(** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning + anything. *) + +Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". +(** Applies an Ltac1 value to a list of arguments, and provides the result in + CPS style. It does **not** run the returned value. *) + +(** Conversion functions *) + +Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". +Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". + +Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". +Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/user-contrib/Ltac2/Ltac2.v b/user-contrib/Ltac2/Ltac2.v new file mode 100644 index 0000000000..ac90f63560 --- /dev/null +++ b/user-contrib/Ltac2/Ltac2.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit := "ltac2" "print". + +Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". + +Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". + +Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". + +Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/user-contrib/Ltac2/Notations.v b/user-contrib/Ltac2/Notations.v new file mode 100644 index 0000000000..0eab36df82 --- /dev/null +++ b/user-contrib/Ltac2/Notations.v @@ -0,0 +1,556 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* f e +| Val ans => + let (x, k) := ans in + Control.plus (fun _ => x) k +end. + +Ltac2 ifcatch t s f := +match Control.case t with +| Err e => f e +| Val ans => + let (x, k) := ans in + Control.plus (fun _ => s x) (fun e => s (k e)) +end. + +Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero (Tactic_failure None)). + +Ltac2 Notation fail := fail0 (). + +Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). + +Ltac2 Notation try := try0. + +Ltac2 rec repeat0 (t : unit -> unit) := + Control.enter (fun () => + ifcatch (fun _ => Control.progress t) + (fun _ => Control.check_interrupt (); repeat0 t) (fun _ => ())). + +Ltac2 Notation repeat := repeat0. + +Ltac2 dispatch0 t (head, tail) := + match tail with + | None => Control.enter (fun _ => t (); Control.dispatch head) + | Some tacs => + let (def, rem) := tacs in + Control.enter (fun _ => t (); Control.extend head def rem) + end. + +Ltac2 Notation t(thunk(self)) ">" "[" l(dispatch) "]" : 4 := dispatch0 t l. + +Ltac2 do0 n t := + let rec aux n t := match Int.equal n 0 with + | true => () + | false => t (); aux (Int.sub n 1) t + end in + aux (n ()) t. + +Ltac2 Notation do := do0. + +Ltac2 Notation once := Control.once. + +Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). + +Ltac2 Notation progress := progress0. + +Ltac2 rec first0 tacs := +match tacs with +| [] => Control.zero (Tactic_failure None) +| tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) +end. + +Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs. + +Ltac2 complete tac := + let ans := tac () in + Control.enter (fun () => Control.zero (Tactic_failure None)); + ans. + +Ltac2 rec solve0 tacs := +match tacs with +| [] => Control.zero (Tactic_failure None) +| tac :: tacs => + Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) +end. + +Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. + +Ltac2 time0 tac := Control.time None tac. + +Ltac2 Notation time := time0. + +Ltac2 abstract0 tac := Control.abstract None tac. + +Ltac2 Notation abstract := abstract0. + +(** Base tactics *) + +(** Note that we redeclare notations that can be parsed as mere identifiers + as abbreviations, so that it allows to parse them as function arguments + without having to write them within parentheses. *) + +(** Enter and check evar resolution *) +Ltac2 enter_h ev f arg := +match ev with +| true => Control.enter (fun () => f ev (arg ())) +| false => + Control.enter (fun () => + Control.with_holes arg (fun x => f ev x)) +end. + +Ltac2 intros0 ev p := + Control.enter (fun () => Std.intros false p). + +Ltac2 Notation "intros" p(intropatterns) := intros0 false p. +Ltac2 Notation intros := intros. + +Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. +Ltac2 Notation eintros := eintros. + +Ltac2 split0 ev bnd := + enter_h ev Std.split bnd. + +Ltac2 Notation "split" bnd(thunk(with_bindings)) := split0 false bnd. +Ltac2 Notation split := split. + +Ltac2 Notation "esplit" bnd(thunk(with_bindings)) := split0 true bnd. +Ltac2 Notation esplit := esplit. + +Ltac2 exists0 ev bnds := match bnds with +| [] => split0 ev (fun () => Std.NoBindings) +| _ => + let rec aux bnds := match bnds with + | [] => () + | bnd :: bnds => split0 ev bnd; aux bnds + end in + aux bnds +end. + +Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. +(* Ltac2 Notation exists := exists. *) + +Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. +Ltac2 Notation eexists := eexists. + +Ltac2 left0 ev bnd := enter_h ev Std.left bnd. + +Ltac2 Notation "left" bnd(thunk(with_bindings)) := left0 false bnd. +Ltac2 Notation left := left. + +Ltac2 Notation "eleft" bnd(thunk(with_bindings)) := left0 true bnd. +Ltac2 Notation eleft := eleft. + +Ltac2 right0 ev bnd := enter_h ev Std.right bnd. + +Ltac2 Notation "right" bnd(thunk(with_bindings)) := right0 false bnd. +Ltac2 Notation right := right. + +Ltac2 Notation "eright" bnd(thunk(with_bindings)) := right0 true bnd. +Ltac2 Notation eright := eright. + +Ltac2 constructor0 ev n bnd := + enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. + +Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). +Ltac2 Notation constructor := constructor. +Ltac2 Notation "constructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 false n bnd. + +Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). +Ltac2 Notation econstructor := econstructor. +Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. + +Ltac2 specialize0 c pat := + enter_h false (fun _ c => Std.specialize c pat) c. + +Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("as", intropattern))) := + specialize0 c ipat. + +Ltac2 elim0 ev c bnd use := + let f ev (c, bnd, use) := Std.elim ev (c, bnd) use in + enter_h ev f (fun () => c (), bnd (), use ()). + +Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := + elim0 false c bnd use. + +Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := + elim0 true c bnd use. + +Ltac2 apply0 adv ev cb cl := + Std.apply adv ev cb cl. + +Ltac2 Notation "eapply" + cb(list1(thunk(seq(constr, with_bindings)), ",")) + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := + apply0 true true cb cl. + +Ltac2 Notation "apply" + cb(list1(thunk(seq(constr, with_bindings)), ",")) + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := + apply0 true false cb cl. + +Ltac2 default_on_concl cl := +match cl with +| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 pose0 ev p := + enter_h ev (fun ev (na, p) => Std.pose na p) p. + +Ltac2 Notation "pose" p(thunk(pose)) := + pose0 false p. + +Ltac2 Notation "epose" p(thunk(pose)) := + pose0 true p. + +Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := + Std.set false p (default_on_concl cl). + +Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := + Std.set true p (default_on_concl cl). + +Ltac2 assert0 ev ast := + enter_h ev (fun _ ast => Std.assert ast) ast. + +Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. + +Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. + +Ltac2 default_everywhere cl := +match cl with +| None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 Notation "remember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember false na c pat (default_everywhere cl). + +Ltac2 Notation "eremember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember true na c pat (default_everywhere cl). + +Ltac2 induction0 ev ic use := + let f ev use := Std.induction ev ic use in + enter_h ev f use. + +Ltac2 Notation "induction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + induction0 false ic use. + +Ltac2 Notation "einduction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + induction0 true ic use. + +Ltac2 generalize0 gen := + enter_h false (fun _ gen => Std.generalize gen) gen. + +Ltac2 Notation "generalize" + gen(thunk(list1(seq (open_constr, occurrences, opt(seq("as", ident))), ","))) := + generalize0 gen. + +Ltac2 destruct0 ev ic use := + let f ev use := Std.destruct ev ic use in + enter_h ev f use. + +Ltac2 Notation "destruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + destruct0 false ic use. + +Ltac2 Notation "edestruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + destruct0 true ic use. + +Ltac2 Notation "simple" "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.SimpleInversion arg pat ids. + +Ltac2 Notation "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversion arg pat ids. + +Ltac2 Notation "inversion_clear" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversionClear arg pat ids. + +Ltac2 Notation "red" cl(opt(clause)) := + Std.red (default_on_concl cl). +Ltac2 Notation red := red. + +Ltac2 Notation "hnf" cl(opt(clause)) := + Std.hnf (default_on_concl cl). +Ltac2 Notation hnf := hnf. + +Ltac2 Notation "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.simpl s pl (default_on_concl cl). +Ltac2 Notation simpl := simpl. + +Ltac2 Notation "cbv" s(strategy) cl(opt(clause)) := + Std.cbv s (default_on_concl cl). +Ltac2 Notation cbv := cbv. + +Ltac2 Notation "cbn" s(strategy) cl(opt(clause)) := + Std.cbn s (default_on_concl cl). +Ltac2 Notation cbn := cbn. + +Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := + Std.lazy s (default_on_concl cl). +Ltac2 Notation lazy := lazy. + +Ltac2 Notation "unfold" pl(list1(seq(reference, occurrences), ",")) cl(opt(clause)) := + Std.unfold pl (default_on_concl cl). + +Ltac2 fold0 pl cl := + let cl := default_on_concl cl in + Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). + +Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := + fold0 pl cl. + +Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := + Std.pattern pl (default_on_concl cl). + +Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.vm pl (default_on_concl cl). +Ltac2 Notation vm_compute := vm_compute. + +Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.native pl (default_on_concl cl). +Ltac2 Notation native_compute := native_compute. + +Ltac2 change0 p cl := + let (pat, c) := p in + Std.change pat c (default_on_concl cl). + +Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. + +Ltac2 rewrite0 ev rw cl tac := + let cl := default_on_concl cl in + Std.rewrite ev rw cl tac. + +Ltac2 Notation "rewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 false rw cl tac. + +Ltac2 Notation "erewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 true rw cl tac. + +(** coretactics *) + +Ltac2 exact0 ev c := + Control.enter (fun _ => + match ev with + | true => + let c := c () in + Control.refine (fun _ => c) + | false => + Control.with_holes c (fun c => Control.refine (fun _ => c)) + end + ). + +Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. +Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. + +Ltac2 Notation "intro" id(opt(ident)) mv(opt(move_location)) := Std.intro id mv. +Ltac2 Notation intro := intro. + +Ltac2 Notation "move" id(ident) mv(move_location) := Std.move id mv. + +Ltac2 Notation reflexivity := Std.reflexivity (). + +Ltac2 symmetry0 cl := + Std.symmetry (default_on_concl cl). + +Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. +Ltac2 Notation symmetry := symmetry. + +Ltac2 Notation "revert" ids(list1(ident)) := Std.revert ids. + +Ltac2 Notation assumption := Std.assumption (). + +Ltac2 Notation etransitivity := Std.etransitivity (). + +Ltac2 Notation admit := Std.admit (). + +Ltac2 clear0 ids := match ids with +| [] => Std.keep [] +| _ => Std.clear ids +end. + +Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. +Ltac2 Notation "clear" "-" ids(list1(ident)) := Std.keep ids. +Ltac2 Notation clear := clear. + +Ltac2 Notation refine := Control.refine. + +(** extratactics *) + +Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). + +Ltac2 Notation "absurd" c(thunk(open_constr)) := absurd0 c. + +Ltac2 subst0 ids := match ids with +| [] => Std.subst_all () +| _ => Std.subst ids +end. + +Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. +Ltac2 Notation subst := subst. + +Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := + Std.discriminate false arg. +Ltac2 Notation discriminate := discriminate. + +Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := + Std.discriminate true arg. +Ltac2 Notation ediscriminate := ediscriminate. + +Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection false ipat arg. + +Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection true ipat arg. + +(** Auto *) + +Ltac2 default_db dbs := match dbs with +| None => Some [] +| Some dbs => + match dbs with + | None => None + | Some l => Some l + end +end. + +Ltac2 default_list use := match use with +| None => [] +| Some use => use +end. + +Ltac2 trivial0 use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.trivial Std.Off use dbs. + +Ltac2 Notation "trivial" + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := trivial0 use dbs. + +Ltac2 Notation trivial := trivial. + +Ltac2 auto0 n use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.auto Std.Off n use dbs. + +Ltac2 Notation "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := auto0 n use dbs. + +Ltac2 Notation auto := auto. + +Ltac2 new_eauto0 n use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.new_auto Std.Off n use dbs. + +Ltac2 Notation "new" "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := new_eauto0 n use dbs. + +Ltac2 eauto0 n p use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.eauto Std.Off n p use dbs. + +Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := eauto0 n p use dbs. + +Ltac2 Notation eauto := eauto. + +Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto None n dbs. + +Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto (Some Std.BFS) n dbs. + +Ltac2 Notation typeclasses_eauto := typeclasses_eauto. + +(** Congruence *) + +Ltac2 f_equal0 () := ltac1:(f_equal). +Ltac2 Notation f_equal := f_equal0 (). + +(** now *) + +Ltac2 now0 t := t (); ltac1:(easy). +Ltac2 Notation "now" t(thunk(self)) := now0 t. diff --git a/user-contrib/Ltac2/Pattern.v b/user-contrib/Ltac2/Pattern.v new file mode 100644 index 0000000000..8d1fb0cd8a --- /dev/null +++ b/user-contrib/Ltac2/Pattern.v @@ -0,0 +1,145 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* context := + "ltac2" "pattern_empty_context". +(** A trivial context only made of the hole. *) + +Ltac2 @ external matches : t -> constr -> (ident * constr) list := + "ltac2" "pattern_matches". +(** If the term matches the pattern, returns the bound variables. If it doesn't, + fail with [Match_failure]. Panics if not focussed. *) + +Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := + "ltac2" "pattern_matches_subterm". +(** Returns a stream of results corresponding to all of the subterms of the term + that matches the pattern as in [matches]. The stream is encoded as a + backtracking value whose last exception is [Match_failure]. The additional + value compared to [matches] is the context of the match, to be filled with + the instantiate function. *) + +Ltac2 @ external matches_vect : t -> constr -> constr array := + "ltac2" "pattern_matches_vect". +(** Internal version of [matches] that does not return the identifiers. *) + +Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := + "ltac2" "pattern_matches_subterm_vect". +(** Internal version of [matches_subterms] that does not return the identifiers. *) + +Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t) -> + ident array * context array * constr array * context := + "ltac2" "pattern_matches_goal". +(** Given a list of patterns [hpats] for hypotheses and one pattern [cpat] for the + conclusion, [matches_goal rev hpats cpat] produces (a stream of) tuples of: + - An array of idents, whose size is the length of [hpats], corresponding to the + name of matched hypotheses. + - An array of contexts, whose size is the length of [hpats], corresponding to + the contexts matched for every hypothesis pattern. In case the match kind of + a hypothesis was [MatchPattern], the corresponding context is ensured to be empty. + - An array of terms, whose size is the total number of pattern variables without + duplicates. Terms are ordered by identifier order, e.g. ?a comes before ?b. + - A context corresponding to the conclusion, which is ensured to be empty if + the kind of [cpat] was [MatchPattern]. + This produces a backtracking stream of results containing all the possible + result combinations. The order of considered hypotheses is reversed if [rev] + is true. +*) + +Ltac2 @ external instantiate : context -> constr -> constr := + "ltac2" "pattern_instantiate". +(** Fill the hole of a context with the given term. *) + +(** Implementation of Ltac matching over terms and goals *) + +Ltac2 lazy_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (knd, pat, f) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + fun _ => f context bind) + | MatchContext => + (fun _ => + let (context, bind) := matches_subterm_vect pat t in + fun _ => f context bind) + end in + Control.plus p next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (knd, pat, f) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + f context bind) + | MatchContext => + (fun _ => + let (context, bind) := matches_subterm_vect pat t in + f context bind) + end in + Control.plus p next + end in + interp pats. + +Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). + +Ltac2 lazy_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (pat, f) := p in + let (phyps, pconcl) := pat in + let cur _ := + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in + fun _ => f hids hctx subst cctx + in + Control.plus cur next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (pat, f) := p in + let (phyps, pconcl) := pat in + let cur _ := + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in + f hids hctx subst cctx + in + Control.plus cur next + end in + interp pats. + +Ltac2 one_goal_match0 rev pats := Control.once (fun _ => multi_goal_match0 rev pats). diff --git a/user-contrib/Ltac2/Std.v b/user-contrib/Ltac2/Std.v new file mode 100644 index 0000000000..6c3f465f33 --- /dev/null +++ b/user-contrib/Ltac2/Std.v @@ -0,0 +1,259 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr), intro_pattern) +| IntroRewrite (bool) +] +with or_and_intro_pattern := [ +| IntroOrPattern (intro_pattern list list) +| IntroAndPattern (intro_pattern list) +]. + +Ltac2 Type destruction_arg := [ +| ElimOnConstr (unit -> constr_with_bindings) +| ElimOnIdent (ident) +| ElimOnAnonHyp (int) +]. + +Ltac2 Type induction_clause := { + indcl_arg : destruction_arg; + indcl_eqn : intro_pattern_naming option; + indcl_as : or_and_intro_pattern option; + indcl_in : clause option; +}. + +Ltac2 Type assertion := [ +| AssertType (intro_pattern option, constr, (unit -> unit) option) +| AssertValue (ident, constr) +]. + +Ltac2 Type repeat := [ +| Precisely (int) +| UpTo (int) +| RepeatStar +| RepeatPlus +]. + +Ltac2 Type orientation := [ LTR | RTL ]. + +Ltac2 Type rewriting := { + rew_orient : orientation option; + rew_repeat : repeat; + rew_equatn : (unit -> constr_with_bindings); +}. + +Ltac2 Type evar_flag := bool. +Ltac2 Type advanced_flag := bool. + +Ltac2 Type move_location := [ +| MoveAfter (ident) +| MoveBefore (ident) +| MoveFirst +| MoveLast +]. + +Ltac2 Type inversion_kind := [ +| SimpleInversion +| FullInversion +| FullInversionClear +]. + +(** Standard, built-in tactics. See Ltac1 for documentation. *) + +Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". + +Ltac2 @ external apply : advanced_flag -> evar_flag -> + (unit -> constr_with_bindings) list -> (ident * (intro_pattern option)) option -> unit := "ltac2" "tac_apply". + +Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". +Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". + +Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". + +Ltac2 @ external assert : assertion -> unit := "ltac2" "tac_assert". +Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". + +Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". +Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". + +Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". + +Ltac2 @ external destruct : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external induction : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". +Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". +Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_simpl". +Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". +Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". +Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". +Ltac2 @ external unfold : (reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". +Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". +Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". +Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". +Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". + +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_hnf : constr -> constr := "ltac2" "eval_hnf". +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_simpl : red_flags -> (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_simpl". +Ltac2 @ external eval_cbv : red_flags -> constr -> constr := "ltac2" "eval_cbv". +Ltac2 @ external eval_cbn : red_flags -> constr -> constr := "ltac2" "eval_cbn". +Ltac2 @ external eval_lazy : red_flags -> constr -> constr := "ltac2" "eval_lazy". +Ltac2 @ external eval_unfold : (reference * occurrences) list -> constr -> constr := "ltac2" "eval_unfold". +Ltac2 @ external eval_fold : constr list -> constr -> constr := "ltac2" "eval_fold". +Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr := "ltac2" "eval_pattern". +Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". +Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". + +Ltac2 @ external change : pattern option -> (constr array -> constr) -> clause -> unit := "ltac2" "tac_change". + +Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". + +Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". + +Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". + +Ltac2 @ external transitivity : constr -> unit := "ltac2" "tac_transitivity". + +Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". + +Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". + +Ltac2 @ external left : evar_flag -> bindings -> unit := "ltac2" "tac_left". +Ltac2 @ external right : evar_flag -> bindings -> unit := "ltac2" "tac_right". + +Ltac2 @ external constructor : evar_flag -> unit := "ltac2" "tac_constructor". +Ltac2 @ external split : evar_flag -> bindings -> unit := "ltac2" "tac_split". + +Ltac2 @ external constructor_n : evar_flag -> int -> bindings -> unit := "ltac2" "tac_constructorn". + +Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". + +Ltac2 @ external symmetry : clause -> unit := "ltac2" "tac_symmetry". + +Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". + +Ltac2 @ external revert : ident list -> unit := "ltac2" "tac_revert". + +Ltac2 @ external admit : unit -> unit := "ltac2" "tac_admit". + +Ltac2 @ external fix_ : ident option -> int -> unit := "ltac2" "tac_fix". +Ltac2 @ external cofix_ : ident option -> unit := "ltac2" "tac_cofix". + +Ltac2 @ external clear : ident list -> unit := "ltac2" "tac_clear". +Ltac2 @ external keep : ident list -> unit := "ltac2" "tac_keep". + +Ltac2 @ external clearbody : ident list -> unit := "ltac2" "tac_clearbody". + +Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". +Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". +Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". + +Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern option -> ident list option -> unit := "ltac2" "tac_inversion". + +(** coretactics *) + +Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". + +Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". + +Ltac2 @ external specialize : constr_with_bindings -> intro_pattern option -> unit := "ltac2" "tac_specialize". + +(** extratactics *) + +Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". +Ltac2 @ external injection : evar_flag -> intro_pattern list option -> destruction_arg option -> unit := "ltac2" "tac_injection". + +Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". +Ltac2 @ external contradiction : constr_with_bindings option -> unit := "ltac2" "tac_contradiction". + +Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> clause -> unit := "ltac2" "tac_autorewrite". + +Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". +Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". + +(** auto *) + +Ltac2 Type debug := [ Off | Info | Debug ]. + +Ltac2 Type strategy := [ BFS | DFS ]. + +Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". + +Ltac2 @ external auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_auto". + +Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_newauto". + +Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". + +Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". diff --git a/user-contrib/Ltac2/String.v b/user-contrib/Ltac2/String.v new file mode 100644 index 0000000000..99e1dab76b --- /dev/null +++ b/user-contrib/Ltac2/String.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char -> string := "ltac2" "string_make". +Ltac2 @external length : string -> int := "ltac2" "string_length". +Ltac2 @external get : string -> int -> char := "ltac2" "string_get". +Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg new file mode 100644 index 0000000000..890ed76d52 --- /dev/null +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -0,0 +1,933 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tok.t Stream.t -> int option + +let entry_of_lookahead s (lk : lookahead) = + let run strm = match lk 0 strm with None -> err () | Some _ -> () in + Pcoq.Entry.of_parser s run + +let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> None +| Some n -> lk2 n strm + +let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> lk2 n strm +| Some n -> Some n + +let lk_kw kw n strm = match stream_nth n strm with +| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None +| _ -> None + +let lk_ident n strm = match stream_nth n strm with +| IDENT _ -> Some (n + 1) +| _ -> None + +let lk_int n strm = match stream_nth n strm with +| NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) +| _ -> None + +let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) + +(* lookahead for (x:=t), (?x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + entry_of_lookahead "test_lpar_idnum_coloneq" begin + lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" + end + +(* lookahead for (x:t), (?x:t) *) +let test_lpar_id_colon = + entry_of_lookahead "test_lpar_id_colon" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" + end + +(* Hack to recognize "(x := t)" and "($x := t)" *) +let test_lpar_id_coloneq = + entry_of_lookahead "test_lpar_id_coloneq" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" + end + +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + entry_of_lookahead "test_lpar_id_rpar" begin + lk_kw "(" >> lk_ident >> lk_kw ")" + end + +let test_ampersand_ident = + entry_of_lookahead "test_ampersand_ident" begin + lk_kw "&" >> lk_ident + end + +let test_dollar_ident = + entry_of_lookahead "test_dollar_ident" begin + lk_kw "$" >> lk_ident + end + +let tac2expr = Tac2entries.Pltac.tac2expr +let tac2type = Entry.create "tactic:tac2type" +let tac2def_val = Entry.create "tactic:tac2def_val" +let tac2def_typ = Entry.create "tactic:tac2def_typ" +let tac2def_ext = Entry.create "tactic:tac2def_ext" +let tac2def_syn = Entry.create "tactic:tac2def_syn" +let tac2def_mut = Entry.create "tactic:tac2def_mut" +let tac2def_run = Entry.create "tactic:tac2def_run" +let tac2mode = Entry.create "vernac:ltac2_command" + +let ltac1_expr = Pltac.tactic_expr + +let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) +let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c +let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c +let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c +let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e +let inj_ltac1val loc e = inj_wit Tac2quote.wit_ltac1val loc e + +let pattern_of_qualid qid = + if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) + else + let open Libnames in + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) + else + CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") + +} + +GRAMMAR EXTEND Gram + GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + tac2def_mut tac2def_run; + tac2pat: + [ "1" LEFTA + [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { + if Tac2env.is_constructor qid then + CAst.make ~loc @@ CPatRef (RelId qid, pl) + else + CErrors.user_err ~loc (Pp.str "Syntax error") } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } + | p1 = tac2pat; "::"; p2 = tac2pat -> + { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])} + ] + | "0" + [ "_" -> { CAst.make ~loc @@ CPatVar Anonymous } + | "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "("; p = atomic_tac2pat; ")" -> { p } + ] ] + ; + atomic_tac2pat: + [ [ -> + { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | p = tac2pat; ":"; t = tac2type -> + { CAst.make ~loc @@ CPatCnv (p, t) } + | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> + { let pl = p :: pl in + CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) } + | p = tac2pat -> { p } + ] ] + ; + tac2expr: + [ "6" RIGHTA + [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] + | "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacFun (it, body) } + | "let"; isrec = rec_flag; + lc = LIST1 let_clause SEP "with"; "in"; + e = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacLet (isrec, lc, e) } + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> + { CAst.make ~loc @@ CTacCse (e, bl) } + ] + | "4" LEFTA [ ] + | "::" RIGHTA + [ e1 = tac2expr; "::"; e2 = tac2expr -> + { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } + ] + | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + { let el = e0 :: el in + CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] + | "1" LEFTA + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + { CAst.make ~loc @@ CTacApp (e, el) } + | e = SELF; ".("; qid = Prim.qualid; ")" -> + { CAst.make ~loc @@ CTacPrj (e, RelId qid) } + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] + | "0" + [ "("; a = SELF; ")" -> { a } + | "("; a = SELF; ":"; t = tac2type; ")" -> + { CAst.make ~loc @@ CTacCnv (a, t) } + | "()" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "("; ")" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + { Tac2quote.of_list ~loc (fun x -> x) a } + | "{"; a = tac2rec_fieldexprs; "}" -> + { CAst.make ~loc @@ CTacRec a } + | a = tactic_atom -> { a } ] + ] + ; + branches: + [ [ -> { [] } + | "|"; bl = LIST1 branch SEP "|" -> { bl } + | bl = LIST1 branch SEP "|" -> { bl } ] + ] + ; + branch: + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] + ; + rec_flag: + [ [ IDENT "rec" -> { true } + | -> { false } ] ] + ; + mut_flag: + [ [ IDENT "mutable" -> { true } + | -> { false } ] ] + ; + typ_param: + [ [ "'"; id = Prim.ident -> { id } ] ] + ; + tactic_atom: + [ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) } + | s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) } + | qid = Prim.qualid -> + { if Tac2env.is_constructor qid then + CAst.make ~loc @@ CTacCst (RelId qid) + else + CAst.make ~loc @@ CTacRef (RelId qid) } + | "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) } + | "&"; id = lident -> { Tac2quote.of_hyp ~loc id } + | "'"; c = Constr.constr -> { inj_open_constr loc c } + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } + | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } + | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } + | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } + | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } + | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1val loc qid } + ] ] + ; + let_clause: + [ [ binder = let_binder; ":="; te = tac2expr -> + { let (pat, fn) = binder in + let te = match fn with + | None -> te + | Some args -> CAst.make ~loc @@ CTacFun (args, te) + in + (pat, te) } + ] ] + ; + let_binder: + [ [ pats = LIST1 input_fun -> + { match pats with + | [{CAst.v=CPatVar _} as pat] -> (pat, None) + | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) + | [pat] -> (pat, None) + | _ -> CErrors.user_err ~loc (str "Invalid pattern") } + ] ] + ; + tac2type: + [ "5" RIGHTA + [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] + | "2" + [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + { let tl = t :: tl in + CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] + | "1" LEFTA + [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] + | "0" + [ "("; t = tac2type LEVEL "5"; ")" -> { t } + | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } + | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } + | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } + | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> + { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] + ]; + locident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + binder: + [ [ "_" -> { CAst.make ~loc Anonymous } + | l = Prim.ident -> { CAst.make ~loc (Name l) } ] ] + ; + input_fun: + [ [ b = tac2pat LEVEL "0" -> { b } ] ] + ; + tac2def_body: + [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in + (name, e) } + ] ] + ; + tac2def_val: + [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + { StrVal (mut, isrec, l) } + ] ] + ; + tac2def_mut: + [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] + ; + tac2def_run: + [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] + ; + tac2typ_knd: + [ [ t = tac2type -> { CTydDef (Some t) } + | "["; ".."; "]" -> { CTydOpn } + | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } + | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] + ; + tac2alg_constructors: + [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs } + | cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ] + ; + tac2alg_constructor: + [ [ c = Prim.ident -> { (c, []) } + | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] + ; + tac2rec_fields: + [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } + | f = tac2rec_field; ";" -> { [f] } + | f = tac2rec_field -> { [f] } + | -> { [] } ] ] + ; + tac2rec_field: + [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] + ; + tac2rec_fieldexprs: + [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } + | f = tac2rec_fieldexpr; ";" -> { [f] } + | f = tac2rec_fieldexpr-> { [f] } + | -> { [] } ] ] + ; + tac2rec_fieldexpr: + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] + ; + tac2typ_prm: + [ [ -> { [] } + | id = typ_param -> { [CAst.make ~loc id] } + | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } + ] ] + ; + tac2typ_def: + [ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ] + ; + tac2type_body: + [ [ -> { false, CTydDef None } + | ":="; e = tac2typ_knd -> { false, e } + | "::="; e = tac2typ_knd -> { true, e } + ] ] + ; + tac2def_typ: + [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> + { StrTyp (isrec, l) } + ] ] + ; + tac2def_ext: + [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + plugin = Prim.string; name = Prim.string -> + { let ml = { mltac_plugin = plugin; mltac_tactic = name } in + StrPrm (id, t, ml) } + ] ] + ; + syn_node: + [ [ "_" -> { CAst.make ~loc None } + | id = Prim.ident -> { CAst.make ~loc (Some id) } + ] ] + ; + sexpr: + [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } + | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } + | id = syn_node -> { SexprRec (loc, id, []) } + | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + { SexprRec (loc, id, tok) } + ] ] + ; + syn_level: + [ [ -> { None } + | ":"; n = Prim.integer -> { Some n } + ] ] + ; + tac2def_syn: + [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; + e = tac2expr -> + { StrSyn (toks, n, e) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + globref: + [ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) } + | qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid } + ] ] + ; +END + +(* Quotation scopes used by notations *) + +{ + +open Tac2entries.Pltac + +let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) + +} + +GRAMMAR EXTEND Gram + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause + q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag + q_destruction_arg q_reference q_with_bindings q_constr_matching + q_goal_matching q_hintdb q_move_location q_pose q_assert; + anti: + [ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ] + ; + ident_or_anti: + [ [ id = lident -> { QExpr id } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + lnatural: + [ [ n = Prim.natural -> { CAst.make ~loc n } ] ] + ; + q_ident: + [ [ id = ident_or_anti -> { id } ] ] + ; + qhyp: + [ [ x = anti -> { x } + | n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) } + | id = lident -> { QExpr (CAst.make ~loc @@ QNamedHyp id) } + ] ] + ; + simple_binding: + [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (h, c) } + ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + { CAst.make ~loc @@ QExplicitBindings bl } + | bl = LIST1 Constr.constr -> + { CAst.make ~loc @@ QImplicitBindings bl } + ] ] + ; + q_bindings: + [ [ bl = bindings -> { bl } ] ] + ; + q_with_bindings: + [ [ bl = with_bindings -> { bl } ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ] + ; +(* ne_intropatterns: *) +(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) +(* ; *) + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc } + | "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) } + | "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) } + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) } + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + { let rec pairify = function + | ([]|[_]|[_;_]) as l -> CAst.make ~loc l + | t::q -> + let q = + CAst.make ~loc @@ + QIntroAction (CAst.make ~loc @@ + QIntroOrAndPattern (CAst.make ~loc @@ + QIntroAndPattern (pairify q))) + in + CAst.make ~loc [t; q] + in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ] + ; + equality_intropattern: + [ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true } + | "<-" -> { CAst.make ~loc @@ QIntroRewrite false } + | "[="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ] + ; + naming_intropattern: + [ [ LEFTQMARK; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QExpr id) } + | "?$"; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QAnti id) } + | "?" -> + { CAst.make ~loc @@ QIntroAnonymous } + | id = ident_or_anti -> + { CAst.make ~loc @@ QIntroIdentifier id } + ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> { l } + | "*" -> { CAst.make ~loc @@ QIntroForthcoming true } + | "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed -> +(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) + (** TODO: handle %pat *) + { pat } + ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) } + | pat = equality_intropattern -> + { CAst.make ~loc @@ QIntroAction pat } + | "_" -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) } + | pat = naming_intropattern -> + { CAst.make ~loc @@ QIntroNaming pat } + ] ] + ; + q_intropatterns: + [ [ ipat = intropatterns -> { ipat } ] ] + ; + q_intropattern: + [ [ ipat = simple_intropattern -> { ipat } ] ] + ; + nat_or_anti: + [ [ n = lnatural -> { QExpr n } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat } + | -> { None } + ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ] + ; + constr_with_bindings: + [ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ] + ; + destruction_arg: + [ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n } + | id = lident -> { CAst.make ~loc @@ QElimOnIdent id } + | c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c } + ] ] + ; + q_destruction_arg: + [ [ arg = destruction_arg -> { arg } ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl } + | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> + { CAst.make ~loc @@ QAllOccurrencesBut (n::nl) } + ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ] + ; + hypident: + [ [ id = ident_or_anti -> + { id,Locus.InHyp } + | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypTypeOnly } + | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypValueOnly } + ] ] + ; + hypident_occ: + [ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + { { q_onhyps = None; q_concl_occs = occs } } + | "*"; "|-"; occs = concl_occ -> + { { q_onhyps = None; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> + { { q_onhyps = Some hl; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP "," -> + { { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } } + ] ] + ; + clause: + [ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl } + | "at"; occs = occs_nums -> + { CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } } + ] ] + ; + q_clause: + [ [ cl = clause -> { cl } ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> { occs } + | -> { CAst.make ~loc QNoOccurrences } + ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = OPT clause -> + { CAst.make ~loc @@ { + indcl_arg = c; + indcl_eqn = eq; + indcl_as = pat; + indcl_in = cl; + } } + ] ] + ; + q_induction_clause: + [ [ cl = induction_clause -> { cl } ] ] + ; + conversion: + [ [ c = Constr.constr -> + { CAst.make ~loc @@ QConvert c } + | c1 = Constr.constr; "with"; c2 = Constr.constr -> + { CAst.make ~loc @@ QConvertWith (c1, c2) } + ] ] + ; + q_conversion: + [ [ c = conversion -> { c } ] ] + ; + orient: + [ [ "->" -> { CAst.make ~loc (Some true) } + | "<-" -> { CAst.make ~loc (Some false) } + | -> { CAst.make ~loc None } + ]] + ; + rewriter: + [ [ "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatPlus,c) } + | [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatStar,c) } + | n = lnatural; "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QUpTo n,c) } + | n = lnatural; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) } + ] ] + ; + oriented_rewriter: + [ [ b = orient; r = rewriter -> + { let (m, c) = r in + CAst.make ~loc @@ { + rew_orient = b; + rew_repeat = m; + rew_equatn = c; + } } + ] ] + ; + q_rewriting: + [ [ r = oriented_rewriter -> { r } ] ] + ; + tactic_then_last: + [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } + | -> { [] } + ] ] + ; + tactic_then_gen: + [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } + | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (None, l)) } + | ta = tac2expr -> { ([Some ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } + | -> { ([None], None) } + ] ] + ; + q_dispatch: + [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] + ; + q_occurrences: + [ [ occs = occs -> { occs } ] ] + ; + red_flag: + [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } + | IDENT "iota" -> { CAst.make ~loc @@ QIota } + | IDENT "match" -> { CAst.make ~loc @@ QMatch } + | IDENT "fix" -> { CAst.make ~loc @@ QFix } + | IDENT "cofix" -> { CAst.make ~loc @@ QCofix } + | IDENT "zeta" -> { CAst.make ~loc @@ QZeta } + | IDENT "delta"; d = delta_flag -> { d } + ] ] + ; + refglobal: + [ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) } + | qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + q_reference: + [ [ r = refglobal -> { r } ] ] + ; + refglobals: + [ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ] + ; + delta_flag: + [ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl } + | "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl } + | -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) } + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flag -> { CAst.make ~loc s } + | d = delta_flag -> + { CAst.make ~loc + [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } + ] ] + ; + q_strategy_flag: + [ [ flag = strategy_flag -> { flag } ] ] + ; + hintdb: + [ [ "*" -> { CAst.make ~loc @@ QHintAll } + | l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l } + ] ] + ; + q_hintdb: + [ [ db = hintdb -> { db } ] ] + ; + match_pattern: + [ [ IDENT "context"; id = OPT Prim.ident; + "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } + | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_constr_matching: + [ [ m = match_list -> { m } ] ] + ; + gmatch_hyp_pattern: + [ [ na = Prim.name; ":"; pat = match_pattern -> { (na, pat) } ] ] + ; + gmatch_pattern: + [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> + { CAst.make ~loc @@ { + q_goal_match_concl = p; + q_goal_match_hyps = hl; + } } + ] ] + ; + gmatch_rule: + [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + gmatch_list: + [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_goal_matching: + [ [ m = gmatch_list -> { m } ] ] + ; + move_location: + [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } + | "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast } + | IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id } + | IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id } + ] ] + ; + q_move_location: + [ [ mv = move_location -> { mv } ] ] + ; + as_name: + [ [ -> { None } + | "as"; id = ident_or_anti -> { Some id } + ] ] + ; + pose: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (Some id, c) } + | c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) } + ] ] + ; + q_pose: + [ [ p = pose -> { p } ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + by_tactic: + [ [ "by"; tac = tac2expr -> { Some tac } + | -> { None } + ] ] + ; + assertion: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (QAssertValue (id, c)) } + | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> + { let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in + CAst.make ~loc (QAssertType (Some ipat, c, tac)) } + | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> + { CAst.make ~loc (QAssertType (ipat, c, tac)) } + ] ] + ; + q_assert: + [ [ a = assertion -> { a } ] ] + ; +END + +(** Extension of constr syntax *) + +(* +GRAMMAR EXTEND Gram + Pcoq.Constr.operconstr: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_ampersand_ident; "&"; id = Prim.ident -> + { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_dollar_ident; "$"; id = Prim.ident -> + { let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + ] ] + ; +END +*) +{ + +let () = + +let open Extend in +let open Tok in +let (++) r s = Next (r, s) in +let rules = [ + Rule ( + Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ + Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), + begin fun _ tac _ _ _ loc -> + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ) +] in + +Hook.set Tac2entries.register_constr_quotations begin fun () -> + Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) +end + +} + +{ + +let pr_ltac2entry _ = mt () (* FIXME *) +let pr_ltac2expr _ = mt () (* FIXME *) + +} + +VERNAC ARGUMENT EXTEND ltac2_entry +PRINTED BY { pr_ltac2entry } +| [ tac2def_val(v) ] -> { v } +| [ tac2def_typ(t) ] -> { t } +| [ tac2def_ext(e) ] -> { e } +| [ tac2def_syn(e) ] -> { e } +| [ tac2def_mut(e) ] -> { e } +| [ tac2def_run(e) ] -> { e } +END + +{ + +let classify_ltac2 = function +| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff + +} + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition +| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate + } +END + +{ + +let _ = Pvernac.register_proof_mode "Ltac2" tac2mode + +} + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY { pr_ltac2expr } +| [ tac2expr(e) ] -> { e } +END + +{ + +open G_ltac +open Vernacextend + +} + +VERNAC { tac2mode } EXTEND VernacLtac2 +| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => + { classify_as_proofstep } -> { +(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) + fun ~pstate -> + Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate + } +END + +{ + +open Stdarg + +} + +VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF +| [ "Print" "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac tac } +END diff --git a/user-contrib/Ltac2/ltac2_plugin.mlpack b/user-contrib/Ltac2/ltac2_plugin.mlpack new file mode 100644 index 0000000000..2a25e825cb --- /dev/null +++ b/user-contrib/Ltac2/ltac2_plugin.mlpack @@ -0,0 +1,14 @@ +Tac2dyn +Tac2ffi +Tac2env +Tac2print +Tac2intern +Tac2interp +Tac2entries +Tac2quote +Tac2match +Tac2core +Tac2extffi +Tac2tactics +Tac2stdlib +G_ltac2 diff --git a/user-contrib/Ltac2/plugin_base.dune b/user-contrib/Ltac2/plugin_base.dune new file mode 100644 index 0000000000..711e9b95d3 --- /dev/null +++ b/user-contrib/Ltac2/plugin_base.dune @@ -0,0 +1,6 @@ +(library + (name ltac2_plugin) + (public_name coq.plugins.ltac2) + (synopsis "Coq's Ltac2 plugin") + (modules_without_implementation tac2expr tac2qexpr tac2types) + (libraries coq.plugins.ltac)) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml new file mode 100644 index 0000000000..d7e7b91ee6 --- /dev/null +++ b/user-contrib/Ltac2/tac2core.ml @@ -0,0 +1,1446 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Value.of_option Value.of_ident None +| Name id -> Value.of_option Value.of_ident (Some id) + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let of_relevance = function + | Sorts.Relevant -> ValInt 0 + | Sorts.Irrelevant -> ValInt 1 + +let to_relevance = function + | ValInt 0 -> Sorts.Relevant + | ValInt 1 -> Sorts.Irrelevant + | _ -> assert false + +let of_annot f Context.{binder_name;binder_relevance} = + of_tuple [|(f binder_name); of_relevance binder_relevance|] + +let to_annot f x = + match to_tuple x with + | [|x;y|] -> + let x = f x in + let y = to_relevance y in + Context.make_annot x y + | _ -> assert false + +let of_instance u = + let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in + Value.of_array (fun v -> Value.of_ext Value.val_univ v) u + +let to_instance u = + let u = Value.to_array (fun v -> Value.to_ext Value.val_univ v) u in + EConstr.EInstance.make (Univ.Instance.of_array u) + +let of_rec_declaration (nas, ts, cs) = + (Value.of_array (of_annot of_name) nas, + Value.of_array Value.of_constr ts, + Value.of_array Value.of_constr cs) + +let to_rec_declaration (nas, ts, cs) = + (Value.to_array (to_annot to_name) nas, + Value.to_array Value.to_constr ts, + Value.to_array Value.to_constr cs) + +let of_result f = function +| Inl c -> v_blk 0 [|f c|] +| Inr e -> v_blk 1 [|Value.of_exn e|] + +(** Stdlib exceptions *) + +let err_notfocussed = + Tac2interp.LtacError (coq_core "Not_focussed", [||]) + +let err_outofbounds = + Tac2interp.LtacError (coq_core "Out_of_bounds", [||]) + +let err_notfound = + Tac2interp.LtacError (coq_core "Not_found", [||]) + +let err_matchfailure = + Tac2interp.LtacError (coq_core "Match_failure", [||]) + +(** Helper functions *) + +let thaw f = Tac2ffi.apply f [v_unit] + +let fatal_flag : unit Exninfo.t = Exninfo.make () + +let set_bt info = + if !Tac2interp.print_ltac2_backtrace then + Tac2interp.get_backtrace >>= fun bt -> + Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) + else Proofview.tclUNIT info + +let throw ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + let info = Exninfo.add info fatal_flag () in + Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) + +let fail ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + Proofview.tclZERO ~info e + +let return x = Proofview.tclUNIT x +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let wrap f = + return () >>= fun () -> return (f ()) + +let wrap_unit f = + return () >>= fun () -> f (); return v_unit + +let assert_focussed = + Proofview.Goal.goals >>= fun gls -> + match gls with + | [_] -> Proofview.tclUNIT () + | [] | _ :: _ :: _ -> throw err_notfocussed + +let pf_apply f = + Proofview.Goal.goals >>= function + | [] -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + f env sigma + | [gl] -> + gl >>= fun gl -> + f (Proofview.Goal.env gl) (Tacmach.New.project gl) + | _ :: _ :: _ -> + throw err_notfocussed + +(** Primitives *) + +let define_primitive name arity f = + Tac2env.define_primitive (pname name) (mk_closure arity f) + +let define0 name f = define_primitive name arity_one (fun _ -> f) + +let define1 name r0 f = define_primitive name arity_one begin fun x -> + f (Value.repr_to r0 x) +end + +let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> + f (Value.repr_to r0 x) (Value.repr_to r1 y) +end + +let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> + f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) +end + +(** Printing *) + +let () = define1 "print" pp begin fun pp -> + wrap_unit (fun () -> Feedback.msg_notice pp) +end + +let () = define1 "message_of_int" int begin fun n -> + return (Value.of_pp (Pp.int n)) +end + +let () = define1 "message_of_string" string begin fun s -> + return (Value.of_pp (str (Bytes.to_string s))) +end + +let () = define1 "message_of_constr" constr begin fun c -> + pf_apply begin fun env sigma -> + let pp = Printer.pr_econstr_env env sigma c in + return (Value.of_pp pp) + end +end + +let () = define1 "message_of_ident" ident begin fun c -> + let pp = Id.print c in + return (Value.of_pp pp) +end + +let () = define1 "message_of_exn" valexpr begin fun v -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let pp = Tac2print.pr_valexpr env sigma v (GTypRef (Other Core.t_exn, [])) in + return (Value.of_pp pp) +end + + +let () = define2 "message_concat" pp pp begin fun m1 m2 -> + return (Value.of_pp (Pp.app m1 m2)) +end + +(** Array *) + +let () = define2 "array_make" int valexpr begin fun n x -> + if n < 0 || n > Sys.max_array_length then throw err_outofbounds + else wrap (fun () -> v_blk 0 (Array.make n x)) +end + +let () = define1 "array_length" block begin fun (_, v) -> + return (Value.of_int (Array.length v)) +end + +let () = define3 "array_set" block int valexpr begin fun (_, v) n x -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap_unit (fun () -> v.(n) <- x) +end + +let () = define2 "array_get" block int begin fun (_, v) n -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap (fun () -> v.(n)) +end + +(** Ident *) + +let () = define2 "ident_equal" ident ident begin fun id1 id2 -> + return (Value.of_bool (Id.equal id1 id2)) +end + +let () = define1 "ident_to_string" ident begin fun id -> + return (Value.of_string (Bytes.of_string (Id.to_string id))) +end + +let () = define1 "ident_of_string" string begin fun s -> + let id = try Some (Id.of_string (Bytes.to_string s)) with _ -> None in + return (Value.of_option Value.of_ident id) +end + +(** Int *) + +let () = define2 "int_equal" int int begin fun m n -> + return (Value.of_bool (m == n)) +end + +let binop n f = define2 n int int begin fun m n -> + return (Value.of_int (f m n)) +end + +let () = binop "int_compare" Int.compare +let () = binop "int_add" (+) +let () = binop "int_sub" (-) +let () = binop "int_mul" ( * ) + +let () = define1 "int_neg" int begin fun m -> + return (Value.of_int (~- m)) +end + +(** Char *) + +let () = define1 "char_of_int" int begin fun n -> + wrap (fun () -> Value.of_char (Char.chr n)) +end + +let () = define1 "char_to_int" char begin fun n -> + wrap (fun () -> Value.of_int (Char.code n)) +end + +(** String *) + +let () = define2 "string_make" int char begin fun n c -> + if n < 0 || n > Sys.max_string_length then throw err_outofbounds + else wrap (fun () -> Value.of_string (Bytes.make n c)) +end + +let () = define1 "string_length" string begin fun s -> + return (Value.of_int (Bytes.length s)) +end + +let () = define3 "string_set" string int char begin fun s n c -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap_unit (fun () -> Bytes.set s n c) +end + +let () = define2 "string_get" string int begin fun s n -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap (fun () -> Value.of_char (Bytes.get s n)) +end + +(** Terms *) + +(** constr -> constr *) +let () = define1 "constr_type" constr begin fun c -> + let get_type env sigma = + Proofview.V82.wrap_exceptions begin fun () -> + let (sigma, t) = Typing.type_of env sigma c in + let t = Value.of_constr t in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t + end in + pf_apply get_type +end + +(** constr -> constr *) +let () = define2 "constr_equal" constr constr begin fun c1 c2 -> + Proofview.tclEVARMAP >>= fun sigma -> + let b = EConstr.eq_constr sigma c1 c2 in + Proofview.tclUNIT (Value.of_bool b) +end + +let () = define1 "constr_kind" constr begin fun c -> + let open Constr in + Proofview.tclEVARMAP >>= fun sigma -> + return begin match EConstr.kind sigma c with + | Rel n -> + v_blk 0 [|Value.of_int n|] + | Var id -> + v_blk 1 [|Value.of_ident id|] + | Meta n -> + v_blk 2 [|Value.of_int n|] + | Evar (evk, args) -> + v_blk 3 [| + Value.of_int (Evar.repr evk); + Value.of_array Value.of_constr args; + |] + | Sort s -> + v_blk 4 [|Value.of_ext Value.val_sort s|] + | Cast (c, k, t) -> + v_blk 5 [| + Value.of_constr c; + Value.of_ext Value.val_cast k; + Value.of_constr t; + |] + | Prod (na, t, u) -> + v_blk 6 [| + of_annot of_name na; + Value.of_constr t; + Value.of_constr u; + |] + | Lambda (na, t, c) -> + v_blk 7 [| + of_annot of_name na; + Value.of_constr t; + Value.of_constr c; + |] + | LetIn (na, b, t, c) -> + v_blk 8 [| + of_annot of_name na; + Value.of_constr b; + Value.of_constr t; + Value.of_constr c; + |] + | App (c, cl) -> + v_blk 9 [| + Value.of_constr c; + Value.of_array Value.of_constr cl; + |] + | Const (cst, u) -> + v_blk 10 [| + Value.of_constant cst; + of_instance u; + |] + | Ind (ind, u) -> + v_blk 11 [| + Value.of_ext Value.val_inductive ind; + of_instance u; + |] + | Construct (cstr, u) -> + v_blk 12 [| + Value.of_ext Value.val_constructor cstr; + of_instance u; + |] + | Case (ci, c, t, bl) -> + v_blk 13 [| + Value.of_ext Value.val_case ci; + Value.of_constr c; + Value.of_constr t; + Value.of_array Value.of_constr bl; + |] + | Fix ((recs, i), def) -> + let (nas, ts, cs) = of_rec_declaration def in + v_blk 14 [| + Value.of_array Value.of_int recs; + Value.of_int i; + nas; + ts; + cs; + |] + | CoFix (i, def) -> + let (nas, ts, cs) = of_rec_declaration def in + v_blk 15 [| + Value.of_int i; + nas; + ts; + cs; + |] + | Proj (p, c) -> + v_blk 16 [| + Value.of_ext Value.val_projection p; + Value.of_constr c; + |] + | Int _ -> + assert false + end +end + +let () = define1 "constr_make" valexpr begin fun knd -> + let c = match Tac2ffi.to_block knd with + | (0, [|n|]) -> + let n = Value.to_int n in + EConstr.mkRel n + | (1, [|id|]) -> + let id = Value.to_ident id in + EConstr.mkVar id + | (2, [|n|]) -> + let n = Value.to_int n in + EConstr.mkMeta n + | (3, [|evk; args|]) -> + let evk = Evar.unsafe_of_int (Value.to_int evk) in + let args = Value.to_array Value.to_constr args in + EConstr.mkEvar (evk, args) + | (4, [|s|]) -> + let s = Value.to_ext Value.val_sort s in + EConstr.mkSort (EConstr.Unsafe.to_sorts s) + | (5, [|c; k; t|]) -> + let c = Value.to_constr c in + let k = Value.to_ext Value.val_cast k in + let t = Value.to_constr t in + EConstr.mkCast (c, k, t) + | (6, [|na; t; u|]) -> + let na = to_annot to_name na in + let t = Value.to_constr t in + let u = Value.to_constr u in + EConstr.mkProd (na, t, u) + | (7, [|na; t; c|]) -> + let na = to_annot to_name na in + let t = Value.to_constr t in + let u = Value.to_constr c in + EConstr.mkLambda (na, t, u) + | (8, [|na; b; t; c|]) -> + let na = to_annot to_name na in + let b = Value.to_constr b in + let t = Value.to_constr t in + let c = Value.to_constr c in + EConstr.mkLetIn (na, b, t, c) + | (9, [|c; cl|]) -> + let c = Value.to_constr c in + let cl = Value.to_array Value.to_constr cl in + EConstr.mkApp (c, cl) + | (10, [|cst; u|]) -> + let cst = Value.to_constant cst in + let u = to_instance u in + EConstr.mkConstU (cst, u) + | (11, [|ind; u|]) -> + let ind = Value.to_ext Value.val_inductive ind in + let u = to_instance u in + EConstr.mkIndU (ind, u) + | (12, [|cstr; u|]) -> + let cstr = Value.to_ext Value.val_constructor cstr in + let u = to_instance u in + EConstr.mkConstructU (cstr, u) + | (13, [|ci; c; t; bl|]) -> + let ci = Value.to_ext Value.val_case ci in + let c = Value.to_constr c in + let t = Value.to_constr t in + let bl = Value.to_array Value.to_constr bl in + EConstr.mkCase (ci, c, t, bl) + | (14, [|recs; i; nas; ts; cs|]) -> + let recs = Value.to_array Value.to_int recs in + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkFix ((recs, i), def) + | (15, [|i; nas; ts; cs|]) -> + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkCoFix (i, def) + | (16, [|p; c|]) -> + let p = Value.to_ext Value.val_projection p in + let c = Value.to_constr c in + EConstr.mkProj (p, c) + | _ -> assert false + in + return (Value.of_constr c) +end + +let () = define1 "constr_check" constr begin fun c -> + pf_apply begin fun env sigma -> + try + let (sigma, _) = Typing.type_of env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (of_result Value.of_constr (Inl c)) + with e when CErrors.noncritical e -> + let e = CErrors.push e in + return (of_result Value.of_constr (Inr e)) + end +end + +let () = define3 "constr_substnl" (list constr) int constr begin fun subst k c -> + let ans = EConstr.Vars.substnl subst k c in + return (Value.of_constr ans) +end + +let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> + let ans = EConstr.Vars.substn_vars k ids c in + return (Value.of_constr ans) +end + +let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + try + let ans = Inductiveops.make_case_info env ind Sorts.Relevant Constr.RegularStyle in + return (Value.of_ext Value.val_case ans) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define2 "constr_constructor" (repr_ext val_inductive) int begin fun (ind, i) k -> + Proofview.tclENV >>= fun env -> + try + let open Declarations in + let ans = Environ.lookup_mind ind env in + let _ = ans.mind_packets.(i).mind_consnames.(k) in + return (Value.of_ext val_constructor ((ind, i), (k + 1))) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define3 "constr_in_context" ident constr closure begin fun id t c -> + Proofview.Goal.goals >>= function + | [gl] -> + gl >>= fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let has_var = + try + let _ = Environ.lookup_named_val id env in + true + with Not_found -> false + in + if has_var then + Tacticals.New.tclZEROMSG (str "Variable already exists") + else + let open Context.Named.Declaration in + let nenv = EConstr.push_named (LocalAssum (Context.make_annot id Sorts.Relevant, t)) env in + let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in + let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> + thaw c >>= fun _ -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> + let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in + let args = Array.of_list (EConstr.mkRel 1 :: args) in + let ans = EConstr.mkEvar (evk, args) in + let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in + return (Value.of_constr ans) + | _ -> + throw err_notfocussed +end + +(** Patterns *) + +let empty_context = EConstr.mkMeta Constr_matching.special_meta + +let () = define0 "pattern_empty_context" begin + return (Value.of_constr empty_context) +end + +let () = define2 "pattern_matches" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> fail err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + return (Value.of_list of_pair ans) + end + end +end + +let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> fail err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_list of_pair ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in + of_ans ans + end +end + +let () = define2 "pattern_matches_vect" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> fail err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let ans = Array.map_of_list snd ans in + return (Value.of_array Value.of_constr ans) + end + end +end + +let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c -> + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> fail err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let ans = Array.map_of_list snd ans in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_array Value.of_constr ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in + of_ans ans + end +end + +let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bool pattern) begin fun rev hp cp -> + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let mk_pattern (b, pat) = if b then Tac2match.MatchPattern pat else Tac2match.MatchContext pat in + let r = (List.map mk_pattern hp, mk_pattern cp) in + Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> + let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in + let hids = Value.of_array Value.of_ident (Array.map_of_list fst hyps) in + let hctx = Value.of_array of_ctxopt (Array.map_of_list snd hyps) in + let subs = Value.of_array Value.of_constr (Array.map_of_list snd (Id.Map.bindings subst)) in + let cctx = of_ctxopt ctx in + let ans = Value.of_tuple [| hids; hctx; subs; cctx |] in + Proofview.tclUNIT ans + end +end + +let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> + let ctx = EConstr.Unsafe.to_constr ctx in + let c = EConstr.Unsafe.to_constr c in + let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in + return (Value.of_constr (EConstr.of_constr ans)) +end + +(** Error *) + +let () = define1 "throw" exn begin fun (e, info) -> + throw ~info e +end + +(** Control *) + +(** exn -> 'a *) +let () = define1 "zero" exn begin fun (e, info) -> + fail ~info e +end + +(** (unit -> 'a) -> (exn -> 'a) -> 'a *) +let () = define2 "plus" closure closure begin fun x k -> + Proofview.tclOR (thaw x) (fun e -> Tac2ffi.apply k [Value.of_exn e]) +end + +(** (unit -> 'a) -> 'a *) +let () = define1 "once" closure begin fun f -> + Proofview.tclONCE (thaw f) +end + +(** (unit -> unit) list -> unit *) +let () = define1 "dispatch" (list closure) begin fun l -> + let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in + Proofview.tclDISPATCH l >>= fun () -> return v_unit +end + +(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) +let () = define3 "extend" (list closure) closure (list closure) begin fun lft tac rgt -> + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let tac = Proofview.tclIGNORE (thaw tac) in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in + Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit +end + +(** (unit -> unit) -> unit *) +let () = define1 "enter" closure begin fun f -> + let f = Proofview.tclIGNORE (thaw f) in + Proofview.tclINDEPENDENT f >>= fun () -> return v_unit +end + +(** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) +let () = define1 "case" closure begin fun f -> + Proofview.tclCASE (thaw f) >>= begin function + | Proofview.Next (x, k) -> + let k = Tac2ffi.mk_closure arity_one begin fun e -> + let (e, info) = Value.to_exn e in + set_bt info >>= fun info -> + k (e, info) + end in + return (v_blk 0 [| Value.of_tuple [| x; Value.of_closure k |] |]) + | Proofview.Fail e -> return (v_blk 1 [| Value.of_exn e |]) + end +end + +(** int -> int -> (unit -> 'a) -> 'a *) +let () = define3 "focus" int int closure begin fun i j tac -> + Proofview.tclFOCUS i j (thaw tac) +end + +(** unit -> unit *) +let () = define0 "shelve" begin + Proofview.shelve >>= fun () -> return v_unit +end + +(** unit -> unit *) +let () = define0 "shelve_unifiable" begin + Proofview.shelve_unifiable >>= fun () -> return v_unit +end + +let () = define1 "new_goal" int begin fun ev -> + let ev = Evar.unsafe_of_int ev in + Proofview.tclEVARMAP >>= fun sigma -> + if Evd.mem sigma ev then + Proofview.Unsafe.tclNEWGOALS [Proofview.with_empty_state ev] <*> Proofview.tclUNIT v_unit + else throw err_notfound +end + +(** unit -> constr *) +let () = define0 "goal" begin + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + return (Value.of_constr concl) + end +end + +(** ident -> constr *) +let () = define1 "hyp" ident begin fun id -> + pf_apply begin fun env _ -> + let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in + if mem then return (Value.of_constr (EConstr.mkVar id)) + else Tacticals.New.tclZEROMSG + (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (* FIXME: Do something more sensible *) + end +end + +let () = define0 "hyps" begin + pf_apply begin fun env _ -> + let open Context in + let open Named.Declaration in + let hyps = List.rev (Environ.named_context env) in + let map = function + | LocalAssum (id, t) -> + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr None; Value.of_constr t|] + | LocalDef (id, c, t) -> + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr (Some c); Value.of_constr t|] + in + return (Value.of_list map hyps) + end +end + +(** (unit -> constr) -> unit *) +let () = define1 "refine" closure begin fun c -> + let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in + Proofview.Goal.enter begin fun gl -> + Refine.generic_refine ~typecheck:true c gl + end >>= fun () -> return v_unit +end + +let () = define2 "with_holes" closure closure begin fun x f -> + Proofview.tclEVARMAP >>= fun sigma0 -> + thaw x >>= fun ans -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> + Tacticals.New.tclWITHHOLES false (Tac2ffi.apply f [ans]) sigma +end + +let () = define1 "progress" closure begin fun f -> + Proofview.tclPROGRESS (thaw f) +end + +let () = define2 "abstract" (option ident) closure begin fun id f -> + Abstract.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> + return v_unit +end + +let () = define2 "time" (option string) closure begin fun s f -> + let s = Option.map Bytes.to_string s in + Proofview.tclTIME s (thaw f) +end + +let () = define0 "check_interrupt" begin + Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit +end + +(** Fresh *) + +let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun set1 set2 -> + let ans = Id.Set.union set1 set2 in + return (Value.of_ext Value.val_free ans) +end + +let () = define1 "fresh_free_of_ids" (list ident) begin fun ids -> + let free = List.fold_right Id.Set.add ids Id.Set.empty in + return (Value.of_ext Value.val_free free) +end + +let () = define1 "fresh_free_of_constr" constr begin fun c -> + Proofview.tclEVARMAP >>= fun sigma -> + let rec fold accu c = match EConstr.kind sigma c with + | Constr.Var id -> Id.Set.add id accu + | _ -> EConstr.fold sigma fold accu c + in + let ans = fold Id.Set.empty c in + return (Value.of_ext Value.val_free ans) +end + +let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> + let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in + return (Value.of_ident nid) +end + +(** Env *) + +let () = define1 "env_get" (list ident) begin fun ids -> + let r = match ids with + | [] -> None + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + try Some (Nametab.global_of_path fp) with Not_found -> None + in + return (Value.of_option Value.of_reference r) +end + +let () = define1 "env_expand" (list ident) begin fun ids -> + let r = match ids with + | [] -> [] + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let qid = Libnames.make_qualid path id in + Nametab.locate_all qid + in + return (Value.of_list Value.of_reference r) +end + +let () = define1 "env_path" reference begin fun r -> + match Nametab.path_of_global r with + | fp -> + let (path, id) = Libnames.repr_path fp in + let path = DirPath.repr path in + return (Value.of_list Value.of_ident (List.rev_append path [id])) + | exception Not_found -> + throw err_notfound +end + +let () = define1 "env_instantiate" reference begin fun r -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let (sigma, c) = Evd.fresh_global env sigma r in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (Value.of_constr c) +end + +(** Ltac1 in Ltac2 *) + +let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 +let of_ltac1 v = Value.of_ext Value.val_ltac1 v + +let () = define1 "ltac1_ref" (list ident) begin fun ids -> + let open Ltac_plugin in + let r = match ids with + | [] -> raise Not_found + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + if Tacenv.exists_tactic fp then + List.hd (Tacenv.locate_extended_all_tactic (Libnames.qualid_of_path fp)) + else raise Not_found + in + let tac = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) (Tacenv.interp_ltac r) in + return (Value.of_ext val_ltac1 tac) +end + +let () = define1 "ltac1_run" ltac1 begin fun v -> + let open Ltac_plugin in + Tacinterp.tactic_of_value (Tacinterp.default_ist ()) v >>= fun () -> + return v_unit +end + +let () = define3 "ltac1_apply" ltac1 (list ltac1) closure begin fun f args k -> + let open Ltac_plugin in + let open Tacexpr in + let open Locus in + let k ret = + Proofview.tclIGNORE (Tac2ffi.apply k [Value.of_ext val_ltac1 ret]) + in + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + Tacinterp.val_interp ist tac k >>= fun () -> + return v_unit +end + +let () = define1 "ltac1_of_constr" constr begin fun c -> + let open Ltac_plugin in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_constr c)) +end + +let () = define1 "ltac1_to_constr" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) +end + +let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> + let open Geninterp.Val in + return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) +end + +let () = define1 "ltac1_to_list" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option (Value.of_list of_ltac1) (Tacinterp.Value.to_list v)) +end + +(** ML types *) + +let constr_flags () = + let open Pretyping in + { + use_typeclasses = true; + solve_unification_constraints = true; + fail_evar = true; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +let open_constr_no_classes_flags () = + let open Pretyping in + { + use_typeclasses = false; + solve_unification_constraints = true; + fail_evar = false; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +(** Embed all Ltac2 data into Values *) +let to_lvar ist = + let open Glob_ops in + let lfun = Tac2interp.set_env ist Id.Map.empty in + { empty_lvar with Ltac_pretype.ltac_genargs = lfun } + +let gtypref kn = GTypRef (Other kn, []) + +let intern_constr self ist c = + let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in + (GlbVal c, gtypref t_constr) + +let catchable_exception = function + | Logic_monad.Exception _ -> false + | e -> CErrors.noncritical e + +let interp_constr flags ist c = + let open Pretyping in + let ist = to_lvar ist in + pf_apply begin fun env sigma -> + try + let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in + let c = Value.of_constr c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT c + with e when catchable_exception e -> + let (e, info) = CErrors.push e in + set_bt info >>= fun info -> + match Exninfo.get info fatal_flag with + | None -> Proofview.tclZERO ~info e + | Some () -> throw ~info e + end + +let () = + let intern = intern_constr in + let interp ist c = interp_constr (constr_flags ()) ist c in + let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_constr obj + +let () = + let intern = intern_constr in + let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_open_constr obj + +let () = + let interp _ id = return (Value.of_ident id) in + let print _ id = str "ident:(" ++ Id.print id ++ str ")" in + let obj = { + ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); + ml_interp = interp; + ml_subst = (fun _ id -> id); + ml_print = print; + } in + define_ml_object Tac2quote.wit_ident obj + +let () = + let intern self ist c = + let env = ist.Genintern.genv in + let sigma = Evd.from_env env in + let warn = if !Ltac_plugin.Tacintern.strict_check then fun x -> x else Constrintern.for_grammar in + let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in + GlbVal pat, gtypref t_pattern + in + let subst subst c = + let env = Global.env () in + let sigma = Evd.from_env env in + Patternops.subst_pattern env sigma subst c + in + let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in + let interp _ c = return (Value.of_pattern c) in + let obj = { + ml_intern = intern; + ml_interp = interp; + ml_subst = subst; + ml_print = print; + } in + define_ml_object Tac2quote.wit_pattern obj + +let () = + let intern self ist ref = match ref.CAst.v with + | Tac2qexpr.QHypothesis id -> + GlbVal (Globnames.VarRef id), gtypref t_reference + | Tac2qexpr.QReference qid -> + let gr = + try Nametab.locate qid + with Not_found -> + Nametab.error_global_not_found qid + in + GlbVal gr, gtypref t_reference + in + let subst s c = Globnames.subst_global_reference s c in + let interp _ gr = return (Value.of_reference gr) in + let print _ = function + | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" + | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_reference obj + +let () = + let intern self ist tac = + (* Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_unit + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + let tac = (Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in + let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in + Proofview.tclOR tac wrap >>= fun () -> + return v_unit + in + let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1 obj + +let () = + let open Ltac_plugin in + let intern self ist tac = + (* Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_ltac1 + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_closure ist tac)) + in + let subst s tac = Genintern.substitute Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1val:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1val obj + +(** Ltac2 in terms *) + +let () = + let interp ist poly env sigma concl tac = + let ist = Tac2interp.get_env ist in + let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in + let name, poly = Id.of_string "ltac2", poly in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in + (EConstr.of_constr c, sigma) + in + GlobEnv.register_constr_interp0 wit_ltac2 interp + +let () = + let interp ist poly env sigma concl id = + let ist = Tac2interp.get_env ist in + let c = Id.Map.find id ist.env_ist in + let c = Value.to_constr c in + let sigma = Typing.check env sigma c concl in + (c, sigma) + in + GlobEnv.register_constr_interp0 wit_ltac2_quotation interp + +let () = + let pr_raw id = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb id = Genprint.PrinterBasic (fun _env _sigma -> str "$" ++ Id.print id) in + let pr_top _ = Genprint.TopPrinterBasic mt in + Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top + +(** Ltac2 in Ltac1 *) + +let () = + let e = Tac2entries.Pltac.tac2expr in + let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in + Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) + +let () = + let open Ltac_plugin in + let open Tacinterp in + let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in + let interp ist tac = +(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) + let ist = { env_ist = Id.Map.empty } in + Tac2interp.interp ist tac >>= fun _ -> + Ftactic.return idtac + in + Geninterp.register_interp0 wit_ltac2 interp + +let () = + let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in + let pr_top _ = Genprint.TopPrinterBasic mt in + Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top + +(** Built-in notation scopes *) + +let add_scope s f = + Tac2entries.register_scope (Id.of_string s) f + +let rec pr_scope = let open CAst in function +| SexprStr {v=s} -> qstring s +| SexprInt {v=n} -> Pp.int n +| SexprRec (_, {v=na}, args) -> + let na = match na with + | None -> str "_" + | Some id -> Id.print id + in + na ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" + +let scope_fail s args = + let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in + CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) + +let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) + +let add_generic_scope s entry arg = + let parse = function + | [] -> + let scope = Extend.Aentry entry in + let act x = CAst.make @@ CTacExt (arg, x) in + Tac2entries.ScopeRule (scope, act) + | arg -> scope_fail s arg + in + add_scope s parse + +open CAst + +let () = add_scope "keyword" begin function +| [SexprStr {loc;v=s}] -> + let scope = Extend.Atoken (Tok.PKEYWORD s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| arg -> scope_fail "keyword" arg +end + +let () = add_scope "terminal" begin function +| [SexprStr {loc;v=s}] -> + let scope = Extend.Atoken (CLexer.terminal s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| arg -> scope_fail "terminal" arg +end + +let () = add_scope "list0" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist0 scope in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr {v=str}] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist0sep (scope, sep) in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "list0" arg +end + +let () = add_scope "list1" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist1 scope in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr {v=str}] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist1sep (scope, sep) in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "list1" arg +end + +let () = add_scope "opt" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Aopt scope in + let act opt = match opt with + | None -> + CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) + | Some x -> + CAst.make @@ CTacApp (CAst.make @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) + in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "opt" arg +end + +let () = add_scope "self" begin function +| [] -> + let scope = Extend.Aself in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "self" arg +end + +let () = add_scope "next" begin function +| [] -> + let scope = Extend.Anext in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "next" arg +end + +let () = add_scope "tactic" begin function +| [] -> + (* Default to level 5 parsing *) + let scope = Extend.Aentryl (tac2expr, "5") in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| [SexprInt {loc;v=n}] as arg -> + let () = if n < 0 || n > 6 then scope_fail "tactic" arg in + let scope = Extend.Aentryl (tac2expr, string_of_int n) in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "tactic" arg +end + +let () = add_scope "thunk" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let act e = Tac2quote.thunk (act e) in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "thunk" arg +end + +let add_expr_scope name entry f = + add_scope name begin function + | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) + | arg -> scope_fail name arg + end + +let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) +let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings +let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings +let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern +let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns +let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg +let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause +let () = add_expr_scope "conversion" q_conversion Tac2quote.of_conversion +let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting +let () = add_expr_scope "clause" q_clause Tac2quote.of_clause +let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb +let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences +let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch +let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag +let () = add_expr_scope "reference" q_reference Tac2quote.of_reference +let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location +let () = add_expr_scope "pose" q_pose Tac2quote.of_pose +let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion +let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching +let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching + +let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr +let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr +let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern + +(** seq scope, a bit hairy *) + +open Extend +exception SelfSymbol + +let rec generalize_symbol : + type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function +| Atoken tok -> Atoken tok +| Alist1 e -> Alist1 (generalize_symbol e) +| Alist1sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Alist1sep (e, sep) +| Alist0 e -> Alist0 (generalize_symbol e) +| Alist0sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Alist0sep (e, sep) +| Aopt e -> Aopt (generalize_symbol e) +| Aself -> raise SelfSymbol +| Anext -> raise SelfSymbol +| Aentry e -> Aentry e +| Aentryl (e, l) -> Aentryl (e, l) +| Arules r -> Arules r + +type _ converter = +| CvNil : (Loc.t -> raw_tacexpr) converter +| CvCns : 'act converter * ('a -> raw_tacexpr) option -> ('a -> 'act) converter + +let rec apply : type a. a converter -> raw_tacexpr list -> a = function +| CvNil -> fun accu loc -> Tac2quote.of_tuple ~loc accu +| CvCns (c, None) -> fun accu x -> apply c accu +| CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) + +type seqrule = +| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule + +let rec make_seq_rule = function +| [] -> + Seqrule (Stop, CvNil) +| tok :: rem -> + let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in + let scope = generalize_symbol scope in + let Seqrule (r, c) = make_seq_rule rem in + let r = NextNoRec (r, scope) in + let f = match tok with + | SexprStr _ -> None (* Leave out mere strings *) + | _ -> Some f + in + Seqrule (r, CvCns (c, f)) + +let () = add_scope "seq" begin fun toks -> + let scope = + try + let Seqrule (r, c) = make_seq_rule (List.rev toks) in + Arules [Rules (r, apply c [])] + with SelfSymbol -> + CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + in + Tac2entries.ScopeRule (scope, (fun e -> e)) +end diff --git a/user-contrib/Ltac2/tac2core.mli b/user-contrib/Ltac2/tac2core.mli new file mode 100644 index 0000000000..9fae65bb3e --- /dev/null +++ b/user-contrib/Ltac2/tac2core.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/user-contrib/Ltac2/tac2dyn.ml b/user-contrib/Ltac2/tac2dyn.ml new file mode 100644 index 0000000000..896676f08b --- /dev/null +++ b/user-contrib/Ltac2/tac2dyn.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('raw * 'glb) pack + include Arg.Map(struct type 'a t = 'a pack end) +end + +module Val = Dyn.Make(struct end) diff --git a/user-contrib/Ltac2/tac2dyn.mli b/user-contrib/Ltac2/tac2dyn.mli new file mode 100644 index 0000000000..e995296840 --- /dev/null +++ b/user-contrib/Ltac2/tac2dyn.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('a, 'b) tag + val eq : ('a1, 'b1) tag -> ('a2, 'b2) tag -> ('a1 * 'b1, 'a2 * 'b2) CSig.eq option + val repr : ('a, 'b) tag -> string +end +(** Arguments that are part of an AST. *) + +module type Param = sig type ('raw, 'glb) t end + +module ArgMap (M : Param) : +sig + type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack + type t + val empty : t + val add : ('a, 'b) Arg.tag -> ('a * 'b) pack -> t -> t + val remove : ('a, 'b) Arg.tag -> t -> t + val find : ('a, 'b) Arg.tag -> t -> ('a * 'b) pack + val mem : ('a, 'b) Arg.tag -> t -> bool +end + +module Val : Dyn.S +(** Toplevel values *) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml new file mode 100644 index 0000000000..9fd01426de --- /dev/null +++ b/user-contrib/Ltac2/tac2entries.ml @@ -0,0 +1,938 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object {(default_object "TAC2-DEFINITION") with + cache_function = cache_tacdef; + load_function = load_tacdef; + open_function = open_tacdef; + subst_function = subst_tacdef; + classify_function = classify_tacdef} + +(** Type definition *) + +type typdef = { + typdef_local : bool; + typdef_expr : glb_quant_typedef; +} + +let change_kn_label kn id = + let mp = KerName.modpath kn in + KerName.make mp (Label.of_id id) + +let change_sp_label sp id = + let (dp, _) = Libnames.repr_path sp in + Libnames.make_path dp id + +let push_typedef visibility sp kn (_, def) = match def with +| GTydDef _ -> + Tac2env.push_type visibility sp kn +| GTydAlg { galg_constructors = cstrs } -> + (* Register constructors *) + let iter (c, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_constructor visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter cstrs +| GTydRec fields -> + (* Register fields *) + let iter (c, _, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_projection visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter fields +| GTydOpn -> + Tac2env.push_type visibility sp kn + +let next i = + let ans = !i in + let () = incr i in + ans + +let define_typedef kn (params, def as qdef) = match def with +| GTydDef _ -> + Tac2env.define_type kn qdef +| GTydAlg { galg_constructors = cstrs } -> + (* Define constructors *) + let constant = ref 0 in + let nonconstant = ref 0 in + let iter (c, args) = + let knc = change_kn_label kn c in + let tag = if List.is_empty args then next constant else next nonconstant in + let data = { + Tac2env.cdata_prms = params; + cdata_type = kn; + cdata_args = args; + cdata_indx = Some tag; + } in + Tac2env.define_constructor knc data + in + Tac2env.define_type kn qdef; + List.iter iter cstrs +| GTydRec fs -> + (* Define projections *) + let iter i (id, mut, t) = + let knp = change_kn_label kn id in + let proj = { + Tac2env.pdata_prms = params; + pdata_type = kn; + pdata_ptyp = t; + pdata_mutb = mut; + pdata_indx = i; + } in + Tac2env.define_projection knp proj + in + Tac2env.define_type kn qdef; + List.iteri iter fs +| GTydOpn -> + Tac2env.define_type kn qdef + +let perform_typdef vs ((sp, kn), def) = + let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let load_typdef i obj = perform_typdef (Until i) obj +let open_typdef i obj = perform_typdef (Exactly i) obj + +let cache_typdef ((sp, kn), def) = + let () = push_typedef (Until 1) sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let subst_typdef (subst, def) = + let expr' = subst_quant_typedef subst def.typdef_expr in + if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } + +let classify_typdef o = Substitute o + +let inTypDef : typdef -> obj = + declare_object {(default_object "TAC2-TYPE-DEFINITION") with + cache_function = cache_typdef; + load_function = load_typdef; + open_function = open_typdef; + subst_function = subst_typdef; + classify_function = classify_typdef} + +(** Type extension *) + +type extension_data = { + edata_name : Id.t; + edata_args : int glb_typexpr list; +} + +type typext = { + typext_local : bool; + typext_prms : int; + typext_type : type_constant; + typext_expr : extension_data list; +} + +let push_typext vis sp kn def = + let iter data = + let spc = change_sp_label sp data.edata_name in + let knc = change_kn_label kn data.edata_name in + Tac2env.push_constructor vis spc knc + in + List.iter iter def.typext_expr + +let define_typext kn def = + let iter data = + let knc = change_kn_label kn data.edata_name in + let cdata = { + Tac2env.cdata_prms = def.typext_prms; + cdata_type = def.typext_type; + cdata_args = data.edata_args; + cdata_indx = None; + } in + Tac2env.define_constructor knc cdata + in + List.iter iter def.typext_expr + +let cache_typext ((sp, kn), def) = + let () = define_typext kn def in + push_typext (Until 1) sp kn def + +let perform_typext vs ((sp, kn), def) = + let () = if not def.typext_local then push_typext vs sp kn def in + define_typext kn def + +let load_typext i obj = perform_typext (Until i) obj +let open_typext i obj = perform_typext (Exactly i) obj + +let subst_typext (subst, e) = + let open Mod_subst in + let subst_data data = + let edata_args = List.Smart.map (fun e -> subst_type subst e) data.edata_args in + if edata_args == data.edata_args then data + else { data with edata_args } + in + let typext_type = subst_kn subst e.typext_type in + let typext_expr = List.Smart.map subst_data e.typext_expr in + if typext_type == e.typext_type && typext_expr == e.typext_expr then + e + else + { e with typext_type; typext_expr } + +let classify_typext o = Substitute o + +let inTypExt : typext -> obj = + declare_object {(default_object "TAC2-TYPE-EXTENSION") with + cache_function = cache_typext; + load_function = load_typext; + open_function = open_typext; + subst_function = subst_typext; + classify_function = classify_typext} + +(** Toplevel entries *) + +let fresh_var avoid x = + let bad id = + Id.Set.mem id avoid || + (try ignore (Tac2env.locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string x) bad + +let extract_pattern_type ({loc;v=p} as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + +(** Mangle recursive tactics *) +let inline_rec_tactic tactics = + let avoid = List.fold_left (fun accu ({v=id}, _) -> Id.Set.add id accu) Id.Set.empty tactics in + let map (id, e) = match e.v with + | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) + | _ -> + user_err ?loc:id.loc (str "Recursive tactic definitions must be functions") + in + let tactics = List.map map tactics in + let map (id, pat, e) = + let fold_var (avoid, ans) (pat, _) = + let id = fresh_var avoid "x" in + let loc = pat.loc in + (Id.Set.add id avoid, CAst.make ?loc id :: ans) + in + (* Fresh variables to abstract over the function patterns *) + let _, vars = List.fold_left fold_var (avoid, []) pat in + let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in + let bnd = List.map map_body tactics in + let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in + let var_of_id {loc;v=id} = + let qid = qualid_of_ident ?loc id in + CAst.make ?loc @@ CTacRef (RelId qid) + in + let loc0 = e.loc in + let vpat = List.map pat_of_id vars in + let varg = List.map var_of_id vars in + let e = CAst.make ?loc:loc0 @@ CTacLet (true, bnd, CAst.make ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in + (id, CAst.make ?loc:loc0 @@ CTacFun (vpat, e)) + in + List.map map tactics + +let check_lowercase {loc;v=id} = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") + +let register_ltac ?(local = false) ?(mut = false) isrec tactics = + let map ({loc;v=na}, e) = + let id = match na with + | Anonymous -> + user_err ?loc (str "Tactic definition must have a name") + | Name id -> id + in + let () = check_lowercase CAst.(make ?loc id) in + (CAst.(make ?loc id), e) + in + let tactics = List.map map tactics in + let tactics = + if isrec then inline_rec_tactic tactics else tactics + in + let map ({loc;v=id}, e) = + let (e, t) = intern ~strict:true e in + let () = + if not (is_value e) then + user_err ?loc (str "Tactic definition must be a syntactical value") + in + let kn = Lib.make_kn id in + let exists = + try let _ = Tac2env.interp_global kn in true with Not_found -> false + in + let () = + if exists then + user_err ?loc (str "Tactic " ++ Names.Id.print id ++ str " already exists") + in + (id, e, t) + in + let defs = List.map map tactics in + let iter (id, e, t) = + let def = { + tacdef_local = local; + tacdef_mutable = mut; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + in + List.iter iter defs + +let qualid_to_ident qid = + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid + else user_err ?loc:qid.CAst.loc (str "Identifier expected") + +let register_typedef ?(local = false) isrec types = + let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name types with + | [] -> () + | ({loc;v=id}, _) :: _ -> + user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) + in + let check ({loc;v=id}, (params, def)) = + let same_name {v=id1} {v=id2} = Id.equal id1 id2 in + let () = match List.duplicates same_name params with + | [] -> () + | {loc;v=id} :: _ -> + user_err ?loc (str "The type parameter " ++ Id.print id ++ + str " occurs several times") + in + match def with + | CTydDef _ -> + if isrec then + user_err ?loc (str "The type abbreviation " ++ Id.print id ++ + str " cannot be recursive") + | CTydAlg cs -> + let same_name (id1, _) (id2, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name cs with + | [] -> () + | (id, _) :: _ -> + user_err (str "Multiple definitions of the constructor " ++ Id.print id) + in + () + | CTydRec ps -> + let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name ps with + | [] -> () + | (id, _, _) :: _ -> + user_err (str "Multiple definitions of the projection " ++ Id.print id) + in + () + | CTydOpn -> + if isrec then + user_err ?loc (str "The open type declaration " ++ Id.print id ++ + str " cannot be recursive") + in + let () = List.iter check types in + let self = + if isrec then + let fold accu ({v=id}, (params, _)) = + Id.Map.add id (Lib.make_kn id, List.length params) accu + in + List.fold_left fold Id.Map.empty types + else Id.Map.empty + in + let map ({v=id}, def) = + let typdef = { + typdef_local = local; + typdef_expr = intern_typedef self def; + } in + (id, typdef) + in + let types = List.map map types in + let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in + List.iter iter types + +let register_primitive ?(local = false) {loc;v=id} t ml = + let t = intern_open_type t in + let rec count_arrow = function + | GTypArrow (_, t) -> 1 + count_arrow t + | _ -> 0 + in + let arrows = count_arrow (snd t) in + let () = if Int.equal arrows 0 then + user_err ?loc (str "External tactic must have at least one argument") in + let () = + try let _ = Tac2env.interp_primitive ml in () with Not_found -> + user_err ?loc (str "Unregistered primitive " ++ + quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) + in + let init i = Id.of_string (Printf.sprintf "x%i" i) in + let names = List.init arrows init in + let bnd = List.map (fun id -> Name id) names in + let arg = List.map (fun id -> GTacVar id) names in + let e = GTacFun (bnd, GTacPrm (ml, arg)) in + let def = { + tacdef_local = local; + tacdef_mutable = false; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + +let register_open ?(local = false) qid (params, def) = + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc:qid.CAst.loc (str "Unbound type " ++ pr_qualid qid) + in + let (tparams, t) = Tac2env.interp_type kn in + let () = match t with + | GTydOpn -> () + | GTydAlg _ | GTydRec _ | GTydDef _ -> + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") + in + let () = + if not (Int.equal (List.length params) tparams) then + Tac2intern.error_nparams_mismatch ?loc:qid.CAst.loc (List.length params) tparams + in + match def with + | CTydOpn -> () + | CTydAlg def -> + let intern_type t = + let tpe = CTydDef (Some t) in + let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in + match ans with + | GTydDef (Some t) -> t + | _ -> assert false + in + let map (id, tpe) = + let tpe = List.map intern_type tpe in + { edata_name = id; edata_args = tpe } + in + let def = List.map map def in + let def = { + typext_local = local; + typext_type = kn; + typext_prms = tparams; + typext_expr = def; + } in + Lib.add_anonymous_leaf (inTypExt def) + | CTydRec _ | CTydDef _ -> + user_err ?loc:qid.CAst.loc (str "Extensions only accept inductive constructors") + +let register_type ?local isrec types = match types with +| [qid, true, def] -> + let () = if isrec then user_err ?loc:qid.CAst.loc (str "Extensions cannot be recursive") in + register_open ?local qid def +| _ -> + let map (qid, redef, def) = + let () = if redef then + user_err ?loc:qid.loc (str "Types can only be extended one by one") + in + (qualid_to_ident qid, def) + in + let types = List.map map types in + register_typedef ?local isrec types + +(** Parsing *) + +type 'a token = +| TacTerm of string +| TacNonTerm of Name.t * 'a + +type scope_rule = +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty + +let register_scope id s = + scope_table := Id.Map.add id s !scope_table + +module ParseToken = +struct + +let loc_of_token = function +| SexprStr {loc} -> loc +| SexprInt {loc} -> loc +| SexprRec (loc, _, _) -> Some loc + +let parse_scope = function +| SexprRec (_, {loc;v=Some id}, toks) -> + if Id.Map.mem id !scope_table then + Id.Map.find id !scope_table toks + else + CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) +| SexprStr {v=str} -> + let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in + ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ?loc (str "Invalid parsing token") + +let parse_token = function +| SexprStr {v=s} -> TacTerm s +| SexprRec (_, {v=na}, [tok]) -> + let na = match na with None -> Anonymous | Some id -> Name id in + let scope = parse_scope tok in + TacNonTerm (na, scope) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ?loc (str "Invalid parsing token") + +end + +let parse_scope = ParseToken.parse_scope + +type synext = { + synext_tok : sexpr list; + synext_exp : raw_tacexpr; + synext_lev : int option; + synext_loc : bool; +} + +type krule = +| KRule : + (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * + ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule + +let rec get_rule (tok : scope_rule token list) : krule = match tok with +| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, scope) in + let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in + KRule (rule, act) +| TacTerm t :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let act k _ = act k in + KRule (rule, act) + +let perform_notation syn st = + let tok = List.rev_map ParseToken.parse_token syn.synext_tok in + let KRule (rule, act) = get_rule tok in + let mk loc args = + let map (na, e) = + ((CAst.make ?loc:e.loc @@ CPatVar na), e) + in + let bnd = List.map map args in + CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) + in + let rule = Extend.Rule (rule, act mk) in + let lev = match syn.synext_lev with + | None -> None + | Some lev -> Some (string_of_int lev) + in + let rule = (lev, None, [rule]) in + ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) + +let ltac2_notation = + Pcoq.create_grammar_command "ltac2-notation" perform_notation + +let cache_synext (_, syn) = + Pcoq.extend_grammar_command ltac2_notation syn + +let open_synext i (_, syn) = + if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn + +let subst_synext (subst, syn) = + let e = Tac2intern.subst_rawexpr subst syn.synext_exp in + if e == syn.synext_exp then syn else { syn with synext_exp = e } + +let classify_synext o = + if o.synext_loc then Dispose else Substitute o + +let inTac2Notation : synext -> obj = + declare_object {(default_object "TAC2-NOTATION") with + cache_function = cache_synext; + open_function = open_synext; + subst_function = subst_synext; + classify_function = classify_synext} + +type abbreviation = { + abbr_body : raw_tacexpr; +} + +let perform_abbreviation visibility ((sp, kn), abbr) = + let () = Tac2env.push_ltac visibility sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let load_abbreviation i obj = perform_abbreviation (Until i) obj +let open_abbreviation i obj = perform_abbreviation (Exactly i) obj + +let cache_abbreviation ((sp, kn), abbr) = + let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let subst_abbreviation (subst, abbr) = + let body' = subst_rawexpr subst abbr.abbr_body in + if body' == abbr.abbr_body then abbr + else { abbr_body = body' } + +let classify_abbreviation o = Substitute o + +let inTac2Abbreviation : abbreviation -> obj = + declare_object {(default_object "TAC2-ABBREVIATION") with + cache_function = cache_abbreviation; + load_function = load_abbreviation; + open_function = open_abbreviation; + subst_function = subst_abbreviation; + classify_function = classify_abbreviation} + +let register_notation ?(local = false) tkn lev body = match tkn, lev with +| [SexprRec (_, {loc;v=Some id}, [])], None -> + (* Tactic abbreviation *) + let () = check_lowercase CAst.(make ?loc id) in + let body = Tac2intern.globalize Id.Set.empty body in + let abbr = { abbr_body = body } in + ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) +| _ -> + (* Check that the tokens make sense *) + let entries = List.map ParseToken.parse_token tkn in + let fold accu tok = match tok with + | TacTerm _ -> accu + | TacNonTerm (Name id, _) -> Id.Set.add id accu + | TacNonTerm (Anonymous, _) -> accu + in + let ids = List.fold_left fold Id.Set.empty entries in + (* Globalize so that names are absolute *) + let body = Tac2intern.globalize ids body in + let lev = match lev with Some _ -> lev | None -> Some 5 in + let ext = { + synext_tok = tkn; + synext_exp = body; + synext_lev = lev; + synext_loc = local; + } in + Lib.add_anonymous_leaf (inTac2Notation ext) + +type redefinition = { + redef_kn : ltac_constant; + redef_body : glb_tacexpr; +} + +let perform_redefinition (_, redef) = + let kn = redef.redef_kn in + let data = Tac2env.interp_global kn in + let data = { data with Tac2env.gdata_expr = redef.redef_body } in + Tac2env.define_global kn data + +let subst_redefinition (subst, redef) = + let kn = Mod_subst.subst_kn subst redef.redef_kn in + let body = Tac2intern.subst_expr subst redef.redef_body in + if kn == redef.redef_kn && body == redef.redef_body then redef + else { redef_kn = kn; redef_body = body } + +let classify_redefinition o = Substitute o + +let inTac2Redefinition : redefinition -> obj = + declare_object {(default_object "TAC2-REDEFINITION") with + cache_function = perform_redefinition; + open_function = (fun _ -> perform_redefinition); + subst_function = subst_redefinition; + classify_function = classify_redefinition } + +let register_redefinition ?(local = false) qid e = + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) + in + let kn = match kn with + | TacConstant kn -> kn + | TacAlias _ -> + user_err ?loc:qid.CAst.loc (str "Cannot redefine syntactic abbreviations") + in + let data = Tac2env.interp_global kn in + let () = + if not (data.Tac2env.gdata_mutable) then + user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") + in + let (e, t) = intern ~strict:true e in + let () = + if not (is_value e) then + user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") + in + let () = + if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then + let name = int_name () in + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ + str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) + in + let def = { + redef_kn = kn; + redef_body = e; + } in + Lib.add_anonymous_leaf (inTac2Redefinition def) + +let perform_eval ~pstate e = + let open Proofview.Notations in + let env = Global.env () in + let (e, ty) = Tac2intern.intern ~strict:false e in + let v = Tac2interp.interp Tac2interp.empty_environment e in + let selector, proof = + match pstate with + | None -> + let sigma = Evd.from_env env in + let name, poly = Id.of_string "ltac2", false in + Goal_select.SelectAll, Proof.start ~name ~poly sigma [] + | Some pstate -> + Goal_select.get_default_goal_selector (), + Proof_global.give_me_the_proof pstate + in + let v = match selector with + | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v + | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v + | Goal_select.SelectId id -> Proofview.tclFOCUSID id v + | Goal_select.SelectAll -> v + | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) + in + (* HACK: the API doesn't allow to return a value *) + let ans = ref None in + let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in + let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in + let sigma = Proof.in_proof proof (fun sigma -> sigma) in + let ans = match !ans with None -> assert false | Some r -> r in + let name = int_name () in + Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) + ++ spc () ++ str "=" ++ spc () ++ + Tac2print.pr_valexpr env sigma ans (snd ty)) + +(** Toplevel entries *) + +let register_struct ?local ~pstate str = match str with +| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e +| StrTyp (isrec, t) -> register_type ?local isrec t +| StrPrm (id, t, ml) -> register_primitive ?local id t ml +| StrSyn (tok, lev, e) -> register_notation ?local tok lev e +| StrMut (qid, e) -> register_redefinition ?local qid e +| StrRun e -> perform_eval ~pstate e + +(** Toplevel exception *) + +let _ = Goptions.declare_bool_option { + Goptions.optdepr = false; + Goptions.optname = "print Ltac2 backtrace"; + Goptions.optkey = ["Ltac2"; "Backtrace"]; + Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); + Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); +} + +let backtrace : backtrace Exninfo.t = Exninfo.make () + +let pr_frame = function +| FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" +| FrLtac kn -> + str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) +| FrPrim ml -> + str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" +| FrExtn (tag, arg) -> + let obj = Tac2env.interp_ml_object tag in + str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ + obj.Tac2env.ml_print (Global.env ()) arg + +let () = register_handler begin function +| Tac2interp.LtacError (kn, args) -> + let t_exn = KerName.make Tac2env.coq_prefix (Label.make "exn") in + let v = Tac2ffi.of_open (kn, args) in + let t = GTypRef (Other t_exn, []) in + let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) +| _ -> raise Unhandled +end + +let () = ExplainErr.register_additional_error_info begin fun (e, info) -> + if !Tac2interp.print_ltac2_backtrace then + let bt = Exninfo.get info backtrace in + let bt = match bt with + | Some bt -> bt + | None -> raise Exit + in + let bt = + str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () + in + Some (Loc.tag @@ Some bt) + else raise Exit +end + +(** Printing *) + +let print_ltac qid = + if Tac2env.is_constructor qid then + let kn = + try Tac2env.locate_constructor qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown constructor " ++ pr_qualid qid) + in + let _ = Tac2env.interp_constructor kn in + Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) + in + match kn with + | TacConstant kn -> + let data = Tac2env.interp_global kn in + let e = data.Tac2env.gdata_expr in + let (_, t) = data.Tac2env.gdata_type in + let name = int_name () in + Feedback.msg_notice ( + hov 0 ( + hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ + hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + ) + ) + | TacAlias kn -> + Feedback.msg_notice (str "Alias to ...") + +(** Calling tactics *) + +let solve ~pstate default tac = + let pstate, status = Proof_global.with_current_proof begin fun etac p -> + let with_end_tac = if default then Some etac else None in + let g = Goal_select.get_default_goal_selector () in + let (p, status) = Pfedit.solve g None tac ?with_end_tac p in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p, status + end pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate + +let call ~pstate ~default e = + let loc = e.loc in + let (e, t) = intern ~strict:false e in + let () = check_unit ?loc t in + let tac = Tac2interp.interp Tac2interp.empty_environment e in + solve ~pstate default (Proofview.tclIGNORE tac) + +(** Primitive algebraic types than can't be defined Coq-side *) + +let register_prim_alg name params def = + let id = Id.of_string name in + let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) def in + let alg = { + galg_constructors = def; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + let def = (params, GTydAlg alg) in + let def = { typdef_local = false; typdef_expr = def } in + ignore (Lib.add_leaf id (inTypDef def)) + +let coq_def n = KerName.make Tac2env.coq_prefix (Label.make n) + +let def_unit = { + typdef_local = false; + typdef_expr = 0, GTydDef (Some (GTypRef (Tuple 0, []))); +} + +let t_list = coq_def "list" + +let (f_register_constr_quotations, register_constr_quotations) = Hook.make () + +let cache_ltac2_init (_, ()) = + Hook.get f_register_constr_quotations () + +let load_ltac2_init _ (_, ()) = + Hook.get f_register_constr_quotations () + +let open_ltac2_init _ (_, ()) = + Goptions.set_string_option_value_gen ["Default"; "Proof"; "Mode"] "Ltac2" + +(** Dummy object that register global rules when Require is called *) +let inTac2Init : unit -> obj = + declare_object {(default_object "TAC2-INIT") with + cache_function = cache_ltac2_init; + load_function = load_ltac2_init; + open_function = open_ltac2_init; + } + +let _ = Mltop.declare_cache_obj begin fun () -> + ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); + register_prim_alg "list" 1 [ + ("[]", []); + ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); + ]; + Lib.add_anonymous_leaf (inTac2Init ()); +end "ltac2_plugin" diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli new file mode 100644 index 0000000000..d493192bb3 --- /dev/null +++ b/user-contrib/Ltac2/tac2entries.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ?mut:bool -> rec_flag -> + (Names.lname * raw_tacexpr) list -> unit + +val register_type : ?local:bool -> rec_flag -> + (qualid * redef_flag * raw_quant_typedef) list -> unit + +val register_primitive : ?local:bool -> + Names.lident -> raw_typexpr -> ml_tactic_name -> unit + +val register_struct + : ?local:bool + -> pstate:Proof_global.t option + -> strexpr + -> unit + +val register_notation : ?local:bool -> sexpr list -> int option -> + raw_tacexpr -> unit + +(** {5 Notations} *) + +type scope_rule = +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +val register_scope : Id.t -> scope_interpretation -> unit +(** Create a new scope with the provided name *) + +val parse_scope : sexpr -> scope_rule +(** Use this to interpret the subscopes for interpretation functions *) + +(** {5 Inspecting} *) + +val print_ltac : Libnames.qualid -> unit + +(** {5 Eval loop} *) + +(** Evaluate a tactic expression in the current environment *) +val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t + +(** {5 Toplevel exceptions} *) + +val backtrace : backtrace Exninfo.t + +(** {5 Parsing entries} *) + +module Pltac : +sig +val tac2expr : raw_tacexpr Pcoq.Entry.t + +(** Quoted entries. To be used for complex notations. *) + +open Tac2qexpr + +val q_ident : Id.t CAst.t or_anti Pcoq.Entry.t +val q_bindings : bindings Pcoq.Entry.t +val q_with_bindings : bindings Pcoq.Entry.t +val q_intropattern : intro_pattern Pcoq.Entry.t +val q_intropatterns : intro_pattern list CAst.t Pcoq.Entry.t +val q_destruction_arg : destruction_arg Pcoq.Entry.t +val q_induction_clause : induction_clause Pcoq.Entry.t +val q_conversion : conversion Pcoq.Entry.t +val q_rewriting : rewriting Pcoq.Entry.t +val q_clause : clause Pcoq.Entry.t +val q_dispatch : dispatch Pcoq.Entry.t +val q_occurrences : occurrences Pcoq.Entry.t +val q_reference : reference or_anti Pcoq.Entry.t +val q_strategy_flag : strategy_flag Pcoq.Entry.t +val q_constr_matching : constr_matching Pcoq.Entry.t +val q_goal_matching : goal_matching Pcoq.Entry.t +val q_hintdb : hintdb Pcoq.Entry.t +val q_move_location : move_location Pcoq.Entry.t +val q_pose : pose Pcoq.Entry.t +val q_assert : assertion Pcoq.Entry.t +end + +(** {5 Hooks} *) + +val register_constr_quotations : (unit -> unit) Hook.t diff --git a/user-contrib/Ltac2/tac2env.ml b/user-contrib/Ltac2/tac2env.ml new file mode 100644 index 0000000000..93ad57e97e --- /dev/null +++ b/user-contrib/Ltac2/tac2env.ml @@ -0,0 +1,298 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* KerName.compare c1 c2 +| TacAlias c1, TacAlias c2 -> KerName.compare c1 c2 +| TacConstant _, TacAlias _ -> -1 +| TacAlias _, TacConstant _ -> 1 + +let equal r1 r2 = compare r1 r2 == 0 + +end + +module KnTab = Nametab.Make(FullPath)(KerName) +module RfTab = Nametab.Make(FullPath)(TacRef) +module RfMap = Map.Make(TacRef) + +type nametab = { + tab_ltac : RfTab.t; + tab_ltac_rev : full_path RfMap.t; + tab_cstr : KnTab.t; + tab_cstr_rev : full_path KNmap.t; + tab_type : KnTab.t; + tab_type_rev : full_path KNmap.t; + tab_proj : KnTab.t; + tab_proj_rev : full_path KNmap.t; +} + +let empty_nametab = { + tab_ltac = RfTab.empty; + tab_ltac_rev = RfMap.empty; + tab_cstr = KnTab.empty; + tab_cstr_rev = KNmap.empty; + tab_type = KnTab.empty; + tab_type_rev = KNmap.empty; + tab_proj = KnTab.empty; + tab_proj_rev = KNmap.empty; +} + +let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" + +let push_ltac vis sp kn = + let tab = !nametab in + let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in + let tab_ltac_rev = RfMap.add kn sp tab.tab_ltac_rev in + nametab := { tab with tab_ltac; tab_ltac_rev } + +let locate_ltac qid = + let tab = !nametab in + RfTab.locate qid tab.tab_ltac + +let locate_extended_all_ltac qid = + let tab = !nametab in + RfTab.find_prefixes qid tab.tab_ltac + +let shortest_qualid_of_ltac kn = + let tab = !nametab in + let sp = RfMap.find kn tab.tab_ltac_rev in + RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + +let push_constructor vis sp kn = + let tab = !nametab in + let tab_cstr = KnTab.push vis sp kn tab.tab_cstr in + let tab_cstr_rev = KNmap.add kn sp tab.tab_cstr_rev in + nametab := { tab with tab_cstr; tab_cstr_rev } + +let locate_constructor qid = + let tab = !nametab in + KnTab.locate qid tab.tab_cstr + +let locate_extended_all_constructor qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_cstr + +let shortest_qualid_of_constructor kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_cstr_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr + +let push_type vis sp kn = + let tab = !nametab in + let tab_type = KnTab.push vis sp kn tab.tab_type in + let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in + nametab := { tab with tab_type; tab_type_rev } + +let locate_type qid = + let tab = !nametab in + KnTab.locate qid tab.tab_type + +let locate_extended_all_type qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_type + +let shortest_qualid_of_type ?loc kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_type_rev in + KnTab.shortest_qualid ?loc Id.Set.empty sp tab.tab_type + +let push_projection vis sp kn = + let tab = !nametab in + let tab_proj = KnTab.push vis sp kn tab.tab_proj in + let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in + nametab := { tab with tab_proj; tab_proj_rev } + +let locate_projection qid = + let tab = !nametab in + KnTab.locate qid tab.tab_proj + +let locate_extended_all_projection qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_proj + +let shortest_qualid_of_projection kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_proj_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj + +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + +type environment = { + env_ist : valexpr Id.Map.t; +} + +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + +type ('a, 'b) ml_object = { + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; +} + +module MLTypeObj = +struct + type ('a, 'b) t = ('a, 'b) ml_object +end + +module MLType = Tac2dyn.ArgMap(MLTypeObj) + +let ml_object_table = ref MLType.empty + +let define_ml_object t tpe = + ml_object_table := MLType.add t (MLType.Pack tpe) !ml_object_table + +let interp_ml_object t = + try + let MLType.Pack ans = MLType.find t !ml_object_table in + ans + with Not_found -> + CErrors.anomaly Pp.(str "Unknown object type " ++ str (Tac2dyn.Arg.repr t)) + +(** Absolute paths *) + +let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + +let std_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) + +let ltac1_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Ltac1"; "Ltac2"])) + +(** Generic arguments *) + +let wit_ltac2 = Genarg.make0 "ltac2:value" +let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" +let () = Geninterp.register_val0 wit_ltac2 None +let () = Geninterp.register_val0 wit_ltac2_quotation None + +let is_constructor qid = + let (_, id) = repr_qualid qid in + let id = Id.to_string id in + assert (String.length id > 0); + match id with + | "true" | "false" -> true (* built-in constructors *) + | _ -> + match id.[0] with + | 'A'..'Z' -> true + | _ -> false diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli new file mode 100644 index 0000000000..c7e87c5432 --- /dev/null +++ b/user-contrib/Ltac2/tac2env.mli @@ -0,0 +1,146 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* global_data -> unit +val interp_global : ltac_constant -> global_data + +(** {5 Toplevel definition of types} *) + +val define_type : type_constant -> glb_quant_typedef -> unit +val interp_type : type_constant -> glb_quant_typedef + +(** {5 Toplevel definition of algebraic constructors} *) + +type constructor_data = { + cdata_prms : int; + (** Type parameters *) + cdata_type : type_constant; + (** Inductive definition to which the constructor pertains *) + cdata_args : int glb_typexpr list; + (** Types of the constructor arguments *) + cdata_indx : int option; + (** Index of the constructor in the ADT. Numbering is duplicated between + argumentless and argument-using constructors, e.g. in type ['a option] + [None] and [Some] have both index 0. This field is empty whenever the + constructor is a member of an open type. *) +} + +val define_constructor : ltac_constructor -> constructor_data -> unit +val interp_constructor : ltac_constructor -> constructor_data + +(** {5 Toplevel definition of projections} *) + +type projection_data = { + pdata_prms : int; + (** Type parameters *) + pdata_type : type_constant; + (** Record definition to which the projection pertains *) + pdata_ptyp : int glb_typexpr; + (** Type of the projection *) + pdata_mutb : bool; + (** Whether the field is mutable *) + pdata_indx : int; + (** Index of the projection *) +} + +val define_projection : ltac_projection -> projection_data -> unit +val interp_projection : ltac_projection -> projection_data + +(** {5 Toplevel definition of aliases} *) + +val define_alias : ltac_constant -> raw_tacexpr -> unit +val interp_alias : ltac_constant -> raw_tacexpr + +(** {5 Name management} *) + +val push_ltac : visibility -> full_path -> tacref -> unit +val locate_ltac : qualid -> tacref +val locate_extended_all_ltac : qualid -> tacref list +val shortest_qualid_of_ltac : tacref -> qualid + +val push_constructor : visibility -> full_path -> ltac_constructor -> unit +val locate_constructor : qualid -> ltac_constructor +val locate_extended_all_constructor : qualid -> ltac_constructor list +val shortest_qualid_of_constructor : ltac_constructor -> qualid + +val push_type : visibility -> full_path -> type_constant -> unit +val locate_type : qualid -> type_constant +val locate_extended_all_type : qualid -> type_constant list +val shortest_qualid_of_type : ?loc:Loc.t -> type_constant -> qualid + +val push_projection : visibility -> full_path -> ltac_projection -> unit +val locate_projection : qualid -> ltac_projection +val locate_extended_all_projection : qualid -> ltac_projection list +val shortest_qualid_of_projection : ltac_projection -> qualid + +(** {5 Toplevel definitions of ML tactics} *) + +(** This state is not part of the summary, contrarily to the ones above. It is + intended to be used from ML plugins to register ML-side functions. *) + +val define_primitive : ml_tactic_name -> closure -> unit +val interp_primitive : ml_tactic_name -> closure + +(** {5 ML primitive types} *) + +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + +type environment = { + env_ist : valexpr Id.Map.t; +} + +type ('a, 'b) ml_object = { + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; +} + +val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit +val interp_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object + +(** {5 Absolute paths} *) + +val coq_prefix : ModPath.t +(** Path where primitive datatypes are defined in Ltac2 plugin. *) + +val std_prefix : ModPath.t +(** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) + +val ltac1_prefix : ModPath.t +(** Path where the Ltac1 legacy FFI is defined. *) + +(** {5 Generic arguments} *) + +val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type + +(** {5 Helper functions} *) + +val is_constructor : qualid -> bool diff --git a/user-contrib/Ltac2/tac2expr.mli b/user-contrib/Ltac2/tac2expr.mli new file mode 100644 index 0000000000..1069d0bfa3 --- /dev/null +++ b/user-contrib/Ltac2/tac2expr.mli @@ -0,0 +1,190 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_tacexpr_r + +and raw_tacexpr = raw_tacexpr_r CAst.t + +and raw_taccase = raw_patexpr * raw_tacexpr + +and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list + +type case_info = type_constant or_tuple + +type 'a open_match = { + opn_match : 'a; + opn_branch : (Name.t * Name.t array * 'a) KNmap.t; + (** Invariant: should not be empty *) + opn_default : Name.t * 'a; +} + +type glb_tacexpr = +| GTacAtm of atom +| GTacVar of Id.t +| GTacRef of ltac_constant +| GTacFun of Name.t list * glb_tacexpr +| GTacApp of glb_tacexpr * glb_tacexpr list +| GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr +| GTacCst of case_info * int * glb_tacexpr list +| GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array +| GTacPrj of type_constant * glb_tacexpr * int +| GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr +| GTacOpn of ltac_constructor * glb_tacexpr list +| GTacWth of glb_tacexpr open_match +| GTacExt : (_, 'a) Tac2dyn.Arg.tag * 'a -> glb_tacexpr +| GTacPrm of ml_tactic_name * glb_tacexpr list + +(** {5 Parsing & Printing} *) + +type exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +type sexpr = +| SexprStr of string CAst.t +| SexprInt of int CAst.t +| SexprRec of Loc.t * Id.t option CAst.t * sexpr list + +(** {5 Toplevel statements} *) + +type strexpr = +| StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list + (** Term definition *) +| StrTyp of rec_flag * (qualid * redef_flag * raw_quant_typedef) list + (** Type definition *) +| StrPrm of Names.lident * raw_typexpr * ml_tactic_name + (** External definition *) +| StrSyn of sexpr list * int option * raw_tacexpr + (** Syntactic extensions *) +| StrMut of qualid * raw_tacexpr + (** Redefinition of mutable globals *) +| StrRun of raw_tacexpr + (** Toplevel evaluation of an expression *) + +(** {5 Dynamic semantics} *) + +(** Values are represented in a way similar to OCaml, i.e. they constrast + immediate integers (integers, constructors without arguments) and structured + blocks (tuples, arrays, constructors with arguments), as well as a few other + base cases, namely closures, strings, named constructors, and dynamic type + coming from the Coq implementation. *) + +type tag = int + +type frame = +| FrLtac of ltac_constant +| FrAnon of glb_tacexpr +| FrPrim of ml_tactic_name +| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame + +type backtrace = frame list diff --git a/user-contrib/Ltac2/tac2extffi.ml b/user-contrib/Ltac2/tac2extffi.ml new file mode 100644 index 0000000000..315c970f9e --- /dev/null +++ b/user-contrib/Ltac2/tac2extffi.ml @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false) f + +(** More ML representations *) + +let to_qhyp v = match Value.to_block v with +| (0, [| i |]) -> AnonHyp (Value.to_int i) +| (1, [| id |]) -> NamedHyp (Value.to_ident id) +| _ -> assert false + +let qhyp = make_to_repr to_qhyp + +let to_bindings = function +| ValInt 0 -> NoBindings +| ValBlk (0, [| vl |]) -> + ImplicitBindings (Value.to_list Value.to_constr vl) +| ValBlk (1, [| vl |]) -> + ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) +| _ -> assert false + +let bindings = make_to_repr to_bindings + +let to_constr_with_bindings v = match Value.to_tuple v with +| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) +| _ -> assert false + +let constr_with_bindings = make_to_repr to_constr_with_bindings diff --git a/user-contrib/Ltac2/tac2extffi.mli b/user-contrib/Ltac2/tac2extffi.mli new file mode 100644 index 0000000000..f5251c3d0d --- /dev/null +++ b/user-contrib/Ltac2/tac2extffi.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a Proofview.tactic) arity0 +| AddAty : ('a, 'b) arity0 -> ('a, 'a -> 'b) arity0 + +type valexpr = +| ValInt of int + (** Immediate integers *) +| ValBlk of tag * valexpr array + (** Structured blocks *) +| ValStr of Bytes.t + (** Strings *) +| ValCls of closure + (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr + (** Arbitrary data *) + +and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure + +let arity_one = OneAty +let arity_suc a = AddAty a + +type 'a arity = (valexpr, 'a) arity0 + +let mk_closure arity f = MLTactic (arity, f) + +module Valexpr = +struct + +type t = valexpr + +let is_int = function +| ValInt _ -> true +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false + +let tag v = match v with +| ValBlk (n, _) -> n +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let field v n = match v with +| ValBlk (_, v) -> v.(n) +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let set_field v n w = match v with +| ValBlk (_, v) -> v.(n) <- w +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let make_block tag v = ValBlk (tag, v) +let make_int n = ValInt n + +end + +type 'a repr = { + r_of : 'a -> valexpr; + r_to : valexpr -> 'a; + r_id : bool; +} + +let repr_of r x = r.r_of x +let repr_to r x = r.r_to x + +let make_repr r_of r_to = { r_of; r_to; r_id = false; } + +(** Dynamic tags *) + +let val_exn = Val.create "exn" +let val_constr = Val.create "constr" +let val_ident = Val.create "ident" +let val_pattern = Val.create "pattern" +let val_pp = Val.create "pp" +let val_sort = Val.create "sort" +let val_cast = Val.create "cast" +let val_inductive = Val.create "inductive" +let val_constant = Val.create "constant" +let val_constructor = Val.create "constructor" +let val_projection = Val.create "projection" +let val_case = Val.create "case" +let val_univ = Val.create "universe" +let val_free : Names.Id.Set.t Val.tag = Val.create "free" +let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" + +let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v + +(** Exception *) + +exception LtacError of KerName.t * valexpr array + +(** Conversion functions *) + +let valexpr = { + r_of = (fun obj -> obj); + r_to = (fun obj -> obj); + r_id = true; +} + +let of_unit () = ValInt 0 + +let to_unit = function +| ValInt 0 -> () +| _ -> assert false + +let unit = { + r_of = of_unit; + r_to = to_unit; + r_id = false; +} + +let of_int n = ValInt n +let to_int = function +| ValInt n -> n +| _ -> assert false + +let int = { + r_of = of_int; + r_to = to_int; + r_id = false; +} + +let of_bool b = if b then ValInt 0 else ValInt 1 + +let to_bool = function +| ValInt 0 -> true +| ValInt 1 -> false +| _ -> assert false + +let bool = { + r_of = of_bool; + r_to = to_bool; + r_id = false; +} + +let of_char n = ValInt (Char.code n) +let to_char = function +| ValInt n -> Char.chr n +| _ -> assert false + +let char = { + r_of = of_char; + r_to = to_char; + r_id = false; +} + +let of_string s = ValStr s +let to_string = function +| ValStr s -> s +| _ -> assert false + +let string = { + r_of = of_string; + r_to = to_string; + r_id = false; +} + +let rec of_list f = function +| [] -> ValInt 0 +| x :: l -> ValBlk (0, [| f x; of_list f l |]) + +let rec to_list f = function +| ValInt 0 -> [] +| ValBlk (0, [|v; vl|]) -> f v :: to_list f vl +| _ -> assert false + +let list r = { + r_of = (fun l -> of_list r.r_of l); + r_to = (fun l -> to_list r.r_to l); + r_id = false; +} + +let of_closure cls = ValCls cls + +let to_closure = function +| ValCls cls -> cls +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false + +let closure = { + r_of = of_closure; + r_to = to_closure; + r_id = false; +} + +let of_ext tag c = + ValExt (tag, c) + +let to_ext tag = function +| ValExt (tag', e) -> extract_val tag tag' e +| _ -> assert false + +let repr_ext tag = { + r_of = (fun e -> of_ext tag e); + r_to = (fun e -> to_ext tag e); + r_id = false; +} + +let of_constr c = of_ext val_constr c +let to_constr c = to_ext val_constr c +let constr = repr_ext val_constr + +let of_ident c = of_ext val_ident c +let to_ident c = to_ext val_ident c +let ident = repr_ext val_ident + +let of_pattern c = of_ext val_pattern c +let to_pattern c = to_ext val_pattern c +let pattern = repr_ext val_pattern + +let internal_err = + let open Names in + let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + in + KerName.make coq_prefix (Label.of_id (Id.of_string "Internal")) + +(** FIXME: handle backtrace in Ltac2 exceptions *) +let of_exn c = match fst c with +| LtacError (kn, c) -> ValOpn (kn, c) +| _ -> ValOpn (internal_err, [|of_ext val_exn c|]) + +let to_exn c = match c with +| ValOpn (kn, c) -> + if Names.KerName.equal kn internal_err then + to_ext val_exn c.(0) + else + (LtacError (kn, c), Exninfo.null) +| _ -> assert false + +let exn = { + r_of = of_exn; + r_to = to_exn; + r_id = false; +} + +let of_option f = function +| None -> ValInt 0 +| Some c -> ValBlk (0, [|f c|]) + +let to_option f = function +| ValInt 0 -> None +| ValBlk (0, [|c|]) -> Some (f c) +| _ -> assert false + +let option r = { + r_of = (fun l -> of_option r.r_of l); + r_to = (fun l -> to_option r.r_to l); + r_id = false; +} + +let of_pp c = of_ext val_pp c +let to_pp c = to_ext val_pp c +let pp = repr_ext val_pp + +let of_tuple cl = ValBlk (0, cl) +let to_tuple = function +| ValBlk (0, cl) -> cl +| _ -> assert false + +let of_pair f g (x, y) = ValBlk (0, [|f x; g y|]) +let to_pair f g = function +| ValBlk (0, [|x; y|]) -> (f x, g y) +| _ -> assert false +let pair r0 r1 = { + r_of = (fun p -> of_pair r0.r_of r1.r_of p); + r_to = (fun p -> to_pair r0.r_to r1.r_to p); + r_id = false; +} + +let of_array f vl = ValBlk (0, Array.map f vl) +let to_array f = function +| ValBlk (0, vl) -> Array.map f vl +| _ -> assert false +let array r = { + r_of = (fun l -> of_array r.r_of l); + r_to = (fun l -> to_array r.r_to l); + r_id = false; +} + +let of_block (n, args) = ValBlk (n, args) +let to_block = function +| ValBlk (n, args) -> (n, args) +| _ -> assert false + +let block = { + r_of = of_block; + r_to = to_block; + r_id = false; +} + +let of_open (kn, args) = ValOpn (kn, args) + +let to_open = function +| ValOpn (kn, args) -> (kn, args) +| _ -> assert false + +let open_ = { + r_of = of_open; + r_to = to_open; + r_id = false; +} + +let of_constant c = of_ext val_constant c +let to_constant c = to_ext val_constant c +let constant = repr_ext val_constant + +let of_reference = function +| VarRef id -> ValBlk (0, [| of_ident id |]) +| ConstRef cst -> ValBlk (1, [| of_constant cst |]) +| IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) +| ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) + +let to_reference = function +| ValBlk (0, [| id |]) -> VarRef (to_ident id) +| ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) +| ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) +| ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) +| _ -> assert false + +let reference = { + r_of = of_reference; + r_to = to_reference; + r_id = false; +} + +type ('a, 'b) fun1 = closure + +let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure +let to_fun1 r0 r1 f = to_closure f + +let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = + fun arity f args -> match args, arity with + | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) + (* A few hardcoded cases for efficiency *) + | [a0], OneAty -> f a0 + | [a0; a1], AddAty OneAty -> f a0 a1 + | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 + | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 + (* Generic cases *) + | a :: args, OneAty -> + f a >>= fun f -> + let MLTactic (arity, f) = to_closure f in + apply arity f args + | a :: args, AddAty arity -> + apply arity (f a) args + +let apply (MLTactic (arity, f)) args = apply arity f args + +type n_closure = +| NClosure : 'a arity * (valexpr list -> 'a) -> n_closure + +let rec abstract n f = + if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) + else + let NClosure (arity, fe) = abstract (n - 1) f in + NClosure (AddAty arity, fun accu v -> fe (v :: accu)) + +let abstract n f = + let () = assert (n > 0) in + let NClosure (arity, f) = abstract n f in + MLTactic (arity, f []) + +let app_fun1 cls r0 r1 x = + apply cls [r0.r_of x] >>= fun v -> Proofview.tclUNIT (r1.r_to v) diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli new file mode 100644 index 0000000000..bfc93d99e6 --- /dev/null +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -0,0 +1,189 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* valexpr + (** Arbitrary data *) + +type 'a arity + +val arity_one : (valexpr -> valexpr Proofview.tactic) arity +val arity_suc : 'a arity -> (valexpr -> 'a) arity + +val mk_closure : 'v arity -> 'v -> closure + +module Valexpr : +sig + type t = valexpr + val is_int : t -> bool + val tag : t -> int + val field : t -> int -> t + val set_field : t -> int -> t -> unit + val make_block : int -> t array -> t + val make_int : int -> t +end + +(** {5 Ltac2 FFI} *) + +type 'a repr + +val repr_of : 'a repr -> 'a -> valexpr +val repr_to : 'a repr -> valexpr -> 'a + +val make_repr : ('a -> valexpr) -> (valexpr -> 'a) -> 'a repr + +(** These functions allow to convert back and forth between OCaml and Ltac2 + data representation. The [to_*] functions raise an anomaly whenever the data + has not expected shape. *) + +val of_unit : unit -> valexpr +val to_unit : valexpr -> unit +val unit : unit repr + +val of_int : int -> valexpr +val to_int : valexpr -> int +val int : int repr + +val of_bool : bool -> valexpr +val to_bool : valexpr -> bool +val bool : bool repr + +val of_char : char -> valexpr +val to_char : valexpr -> char +val char : char repr + +val of_string : Bytes.t -> valexpr +val to_string : valexpr -> Bytes.t +val string : Bytes.t repr + +val of_list : ('a -> valexpr) -> 'a list -> valexpr +val to_list : (valexpr -> 'a) -> valexpr -> 'a list +val list : 'a repr -> 'a list repr + +val of_constr : EConstr.t -> valexpr +val to_constr : valexpr -> EConstr.t +val constr : EConstr.t repr + +val of_exn : Exninfo.iexn -> valexpr +val to_exn : valexpr -> Exninfo.iexn +val exn : Exninfo.iexn repr + +val of_ident : Id.t -> valexpr +val to_ident : valexpr -> Id.t +val ident : Id.t repr + +val of_closure : closure -> valexpr +val to_closure : valexpr -> closure +val closure : closure repr + +val of_block : (int * valexpr array) -> valexpr +val to_block : valexpr -> (int * valexpr array) +val block : (int * valexpr array) repr + +val of_array : ('a -> valexpr) -> 'a array -> valexpr +val to_array : (valexpr -> 'a) -> valexpr -> 'a array +val array : 'a repr -> 'a array repr + +val of_tuple : valexpr array -> valexpr +val to_tuple : valexpr -> valexpr array + +val of_pair : ('a -> valexpr) -> ('b -> valexpr) -> 'a * 'b -> valexpr +val to_pair : (valexpr -> 'a) -> (valexpr -> 'b) -> valexpr -> 'a * 'b +val pair : 'a repr -> 'b repr -> ('a * 'b) repr + +val of_option : ('a -> valexpr) -> 'a option -> valexpr +val to_option : (valexpr -> 'a) -> valexpr -> 'a option +val option : 'a repr -> 'a option repr + +val of_pattern : Pattern.constr_pattern -> valexpr +val to_pattern : valexpr -> Pattern.constr_pattern +val pattern : Pattern.constr_pattern repr + +val of_pp : Pp.t -> valexpr +val to_pp : valexpr -> Pp.t +val pp : Pp.t repr + +val of_constant : Constant.t -> valexpr +val to_constant : valexpr -> Constant.t +val constant : Constant.t repr + +val of_reference : GlobRef.t -> valexpr +val to_reference : valexpr -> GlobRef.t +val reference : GlobRef.t repr + +val of_ext : 'a Val.tag -> 'a -> valexpr +val to_ext : 'a Val.tag -> valexpr -> 'a +val repr_ext : 'a Val.tag -> 'a repr + +val of_open : KerName.t * valexpr array -> valexpr +val to_open : valexpr -> KerName.t * valexpr array +val open_ : (KerName.t * valexpr array) repr + +type ('a, 'b) fun1 + +val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic + +val to_fun1 : 'a repr -> 'b repr -> valexpr -> ('a, 'b) fun1 +val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr + +val valexpr : valexpr repr + +(** {5 Dynamic tags} *) + +val val_constr : EConstr.t Val.tag +val val_ident : Id.t Val.tag +val val_pattern : Pattern.constr_pattern Val.tag +val val_pp : Pp.t Val.tag +val val_sort : ESorts.t Val.tag +val val_cast : Constr.cast_kind Val.tag +val val_inductive : inductive Val.tag +val val_constant : Constant.t Val.tag +val val_constructor : constructor Val.tag +val val_projection : Projection.t Val.tag +val val_case : Constr.case_info Val.tag +val val_univ : Univ.Level.t Val.tag +val val_free : Id.Set.t Val.tag +val val_ltac1 : Geninterp.Val.t Val.tag + +val val_exn : Exninfo.iexn Tac2dyn.Val.tag +(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] + should be put into a value with tag [val_exn]. *) + +(** Closures *) + +val apply : closure -> valexpr list -> valexpr Proofview.tactic +(** Given a closure, apply it to some arguments. Handling of argument mismatches + is done automatically, i.e. in case of over or under-application. *) + +val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> closure +(** Turn a fixed-arity function into a closure. The inner function is guaranteed + to be applied to a list whose size is the integer argument. *) + +(** Exception *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml new file mode 100644 index 0000000000..de99fb167f --- /dev/null +++ b/user-contrib/Ltac2/tac2intern.ml @@ -0,0 +1,1545 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* elt -> bool +val create : unit -> 'a t +val fresh : 'a t -> elt +val find : elt -> 'a t -> (elt * 'a option) +val union : elt -> elt -> 'a t -> unit +val set : elt -> 'a -> 'a t -> unit +module Map : +sig + type key = elt + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val exists : (key -> 'a -> bool) -> 'a t -> bool +end +end += +struct +type elt = int +let equal = Int.equal +module Map = Int.Map + +type 'a node = +| Canon of int * 'a option +| Equiv of elt + +type 'a t = { + mutable uf_data : 'a node array; + mutable uf_size : int; +} + +let resize p = + if Int.equal (Array.length p.uf_data) p.uf_size then begin + let nsize = 2 * p.uf_size + 1 in + let v = Array.make nsize (Equiv 0) in + Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); + p.uf_data <- v; + end + +let create () = { uf_data = [||]; uf_size = 0 } + +let fresh p = + resize p; + let n = p.uf_size in + p.uf_data.(n) <- (Canon (1, None)); + p.uf_size <- n + 1; + n + +let rec lookup n p = + let node = Array.get p.uf_data n in + match node with + | Canon (size, v) -> n, size, v + | Equiv y -> + let ((z, _, _) as res) = lookup y p in + if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); + res + +let find n p = + let (x, _, v) = lookup n p in (x, v) + +let union x y p = + let ((x, size1, _) as xcan) = lookup x p in + let ((y, size2, _) as ycan) = lookup y p in + let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in + let x, _, xnode = xcan in + let y, _, ynode = ycan in + assert (Option.is_empty xnode); + assert (Option.is_empty ynode); + p.uf_data.(x) <- Equiv y; + p.uf_data.(y) <- Canon (size1 + size2, None) + +let set x v p = + let (x, s, v') = lookup x p in + assert (Option.is_empty v'); + p.uf_data.(x) <- Canon (s, Some v) + +end + +type mix_var = +| GVar of UF.elt +| LVar of int + +type mix_type_scheme = int * mix_var glb_typexpr + +type environment = { + env_var : mix_type_scheme Id.Map.t; + (** Type schemes of bound variables *) + env_cst : UF.elt glb_typexpr UF.t; + (** Unification state *) + env_als : UF.elt Id.Map.t ref; + (** Map user-facing type variables to unification variables *) + env_opn : bool; + (** Accept unbound type variables *) + env_rec : (KerName.t * int) Id.Map.t; + (** Recursive type definitions *) + env_str : bool; + (** True iff in strict mode *) +} + +let empty_env () = { + env_var = Id.Map.empty; + env_cst = UF.create (); + env_als = ref Id.Map.empty; + env_opn = true; + env_rec = Id.Map.empty; + env_str = true; +} + +let env_name env = + (* Generate names according to a provided environment *) + let mk num = + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + name + in + let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in + let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in + let vars = ref vars in + let rec fresh n = + let name = mk n in + if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) + else name + in + fun n -> + if UF.Map.mem n !vars then UF.Map.find n !vars + else + let ans = fresh 0 in + let () = vars := UF.Map.add n ans !vars in + ans + +let ltac2_env : environment Genintern.Store.field = + Genintern.Store.field () + +let drop_ltac2_env store = + Genintern.Store.remove store ltac2_env + +let fresh_id env = UF.fresh env.env_cst + +let get_alias {loc;v=id} env = + try Id.Map.find id env.env_als.contents + with Not_found -> + if env.env_opn then + let n = fresh_id env in + let () = env.env_als := Id.Map.add id n env.env_als.contents in + n + else user_err ?loc (str "Unbound type parameter " ++ Id.print id) + +let push_name id t env = match id with +| Anonymous -> env +| Name id -> { env with env_var = Id.Map.add id t env.env_var } + +let error_nargs_mismatch ?loc kn nargs nfound = + let cstr = Tac2env.shortest_qualid_of_constructor kn in + user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ + int nargs ++ str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let error_nparams_mismatch ?loc nargs nfound = + user_err ?loc (str "Type expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst id +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (Name id) -> GTypVar (get_alias (CAst.make ?loc id) env) +| CTypVar Anonymous -> GTypVar (fresh_id env) +| CTypRef (rel, args) -> + let (kn, nparams) = match rel with + | RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && Id.Map.mem id env.env_rec then + let (kn, n) = Id.Map.find id env.env_rec in + (Other kn, n) + else + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) + in + let (nparams, _) = Tac2env.interp_type kn in + (Other kn, nparams) + | AbsKn (Other kn) -> + let (nparams, _) = Tac2env.interp_type kn in + (Other kn, nparams) + | AbsKn (Tuple n) -> + (Tuple n, n) + in + let nargs = List.length args in + let () = + if not (Int.equal nparams nargs) then + let qid = match rel with + | RelId lid -> lid + | AbsKn (Other kn) -> shortest_qualid_of_type ?loc kn + | AbsKn (Tuple _) -> assert false + in + user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ + strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ + applied to " ++ int nargs ++ strbrk "argument(s)") + in + GTypRef (kn, List.map (fun t -> intern_type env t) args) +| CTypArrow (t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) + +let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + subst_type substf t + +let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf = function + | LVar i -> GTypVar subst.(i) + | GVar n -> GTypVar n + in + subst_type substf t + +let fresh_reftype env (kn : KerName.t or_tuple) = + let n = match kn with + | Other kn -> fst (Tac2env.interp_type kn) + | Tuple n -> n + in + let subst = Array.init n (fun _ -> fresh_id env) in + let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in + (subst, t) + +(** First-order unification algorithm *) +let is_unfoldable kn = match snd (Tac2env.interp_type kn) with +| GTydDef (Some _) -> true +| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false + +let unfold env kn args = + let (nparams, def) = Tac2env.interp_type kn in + let def = match def with + | GTydDef (Some t) -> t + | _ -> assert false + in + let args = Array.of_list args in + let subst n = args.(n) in + subst_type subst def + +(** View function, allows to ensure head normal forms *) +let rec kind env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> kind env t + end +| GTypRef (Other kn, tl) -> + if is_unfoldable kn then kind env (unfold env kn tl) else t +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +(** Normalize unification variables without unfolding type aliases *) +let rec nf env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> nf env t + end +| GTypRef (kn, tl) -> + let tl = List.map (fun t -> nf env t) tl in + GTypRef (kn, tl) +| GTypArrow (t, u) -> + let t = nf env t in + let u = nf env u in + GTypArrow (t, u) + +let pr_glbtype env t = + let t = nf env t in + let name = env_name env in + pr_glbtype name t + +exception Occur + +let rec occur_check env id t = match kind env t with +| GTypVar id' -> if UF.equal id id' then raise Occur +| GTypArrow (t1, t2) -> + let () = occur_check env id t1 in + occur_check env id t2 +| GTypRef (kn, tl) -> + List.iter (fun t -> occur_check env id t) tl + +exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr + +let unify_var env id t = match kind env t with +| GTypVar id' -> + if not (UF.equal id id') then UF.union id id' env.env_cst +| GTypArrow _ | GTypRef _ -> + try + let () = occur_check env id t in + UF.set id t env.env_cst + with Occur -> raise (CannotUnify (GTypVar id, t)) + +let eq_or_tuple eq t1 t2 = match t1, t2 with +| Tuple n1, Tuple n2 -> Int.equal n1 n2 +| Other o1, Other o2 -> eq o1 o2 +| _ -> false + +let rec unify0 env t1 t2 = match kind env t1, kind env t2 with +| GTypVar id, t | t, GTypVar id -> + unify_var env id t +| GTypArrow (t1, u1), GTypArrow (t2, u2) -> + let () = unify0 env t1 t2 in + unify0 env u1 u2 +| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> + if eq_or_tuple KerName.equal kn1 kn2 then + List.iter2 (fun t1 t2 -> unify0 env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| _ -> raise (CannotUnify (t1, t2)) + +let unify ?loc env t1 t2 = + try unify0 env t1 t2 + with CannotUnify (u1, u2) -> + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env t1 ++ + spc () ++ str "but an expression was expected of type" ++ spc () ++ pr_glbtype env t2) + +let unify_arrow ?loc env ft args = + let ft0 = ft in + let rec iter ft args is_fun = match kind env ft, args with + | t, [] -> t + | GTypArrow (t1, ft), (loc, t2) :: args -> + let () = unify ?loc env t2 t1 in + iter ft args true + | GTypVar id, (_, t) :: args -> + let ft = GTypVar (fresh_id env) in + let () = unify_var env id (GTypArrow (t, ft)) in + iter ft args true + | GTypRef _, _ :: _ -> + if is_fun then + user_err ?loc (str "This function has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is applied to too many arguments") + else + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is not a function") + in + iter ft args false + +(** Term typing *) + +let is_pure_constructor kn = + match snd (Tac2env.interp_type kn) with + | GTydAlg _ | GTydOpn -> true + | GTydRec fields -> + let is_pure (_, mut, _) = not mut in + List.for_all is_pure fields + | GTydDef _ -> assert false (** Type definitions have no constructors *) + +let rec is_value = function +| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true +| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false +| GTacCst (Tuple _, _, el) -> List.for_all is_value el +| GTacCst (_, _, []) -> true +| GTacOpn (_, el) -> List.for_all is_value el +| GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ +| GTacWth _ -> false + +let is_rec_rhs = function +| GTacFun _ -> true +| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ +| GTacSet _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacCse _ | GTacOpn _ | GTacWth _ -> false + +let rec fv_type f t accu = match t with +| GTypVar id -> f id accu +| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) +| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl + +let fv_env env = + let rec f id accu = match UF.find id env.env_cst with + | id, None -> UF.Map.add id () accu + | _, Some t -> fv_type f t accu + in + let fold_var id (_, t) accu = + let fmix id accu = match id with + | LVar _ -> accu + | GVar id -> f id accu + in + fv_type fmix t accu + in + let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in + let fold_als _ id accu = f id accu in + Id.Map.fold fold_als !(env.env_als) fv_var + +let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = + let fv = fv_env env in + let count = ref 0 in + let vars = ref UF.Map.empty in + let rec subst id = + let (id, t) = UF.find id env.env_cst in + match t with + | None -> + if UF.Map.mem id fv then GTypVar (GVar id) + else + begin try UF.Map.find id !vars + with Not_found -> + let n = !count in + let var = GTypVar (LVar n) in + let () = incr count in + let () = vars := UF.Map.add id var !vars in + var + end + | Some t -> subst_type subst t + in + let t = subst_type subst t in + (!count, t) + +let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = + let subst id = GTypVar (GVar id) in + (0, subst_type subst t) + +let warn_not_unit = + CWarnings.create ~name:"not-unit" ~category:"ltac" + (fun () -> strbrk "The following expression should have type unit.") + +let warn_redundant_clause = + CWarnings.create ~name:"redundant-clause" ~category:"ltac" + (fun () -> strbrk "The following clause is redundant.") + +let check_elt_unit loc env t = + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false + in + if not maybe_unit then warn_not_unit ?loc () + +let check_elt_empty loc env t = match kind env t with +| GTypVar _ -> + user_err ?loc (str "Cannot infer an empty type for this expression") +| GTypArrow _ | GTypRef (Tuple _, _) -> + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") +| GTypRef (Other kn, _) -> + let def = Tac2env.interp_type kn in + match def with + | _, GTydAlg { galg_constructors = [] } -> kn + | _ -> + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") + +let check_unit ?loc t = + let env = empty_env () in + (* Should not matter, t should be closed. *) + let t = fresh_type_scheme env t in + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false + in + if not maybe_unit then warn_not_unit ?loc () + +let check_redundant_clause = function +| [] -> () +| (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () + +let get_variable0 mem var = match var with +| RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && mem id then ArgVar CAst.(make ?loc:qid.CAst.loc id) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound value " ++ pr_qualid qid) + in + ArgArg kn +| AbsKn kn -> ArgArg kn + +let get_variable env var = + let mem id = Id.Map.mem id env.env_var in + get_variable0 mem var + +let get_constructor env var = match var with +| RelId qid -> + let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in + begin match c with + | Some knc -> Other knc + | None -> + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound constructor " ++ pr_qualid qid) + end +| AbsKn knc -> knc + +let get_projection var = match var with +| RelId qid -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") + in + Tac2env.interp_projection kn +| AbsKn kn -> + Tac2env.interp_projection kn + +let intern_atm env = function +| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (Other t_int, [])) +| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (Other t_string, [])) + +let invalid_pattern ?loc kn kn' = + let pr t = match t with + | Other kn' -> str "type " ++ pr_typref kn' + | Tuple n -> str "tuple of size " ++ int n + in + user_err ?loc (str "Invalid pattern, expected a pattern for " ++ + pr kn ++ str ", found a pattern for " ++ pr kn') (** FIXME *) + +(** Pattern view *) + +type glb_patexpr = +| GPatVar of Name.t +| GPatRef of ltac_constructor or_tuple * glb_patexpr list + +let rec intern_patexpr env {loc;v=pat} = match pat with +| CPatVar na -> GPatVar na +| CPatRef (qid, pl) -> + let kn = get_constructor env qid in + GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) +| CPatCnv (pat, ty) -> + user_err ?loc (str "Pattern not handled yet") + +type pattern_kind = +| PKind_empty +| PKind_variant of type_constant or_tuple +| PKind_open of type_constant +| PKind_any + +let get_pattern_kind env pl = match pl with +| [] -> PKind_empty +| p :: pl -> + let rec get_kind (p, _) pl = match intern_patexpr env p with + | GPatVar _ -> + begin match pl with + | [] -> PKind_any + | p :: pl -> get_kind p pl + end + | GPatRef (Other kn, pl) -> + let data = Tac2env.interp_constructor kn in + if Option.is_empty data.cdata_indx then PKind_open data.cdata_type + else PKind_variant (Other data.cdata_type) + | GPatRef (Tuple _, tp) -> PKind_variant (Tuple (List.length tp)) + in + get_kind p pl + +(** Internalization *) + +(** Used to generate a fresh tactic variable for pattern-expansion *) +let fresh_var avoid = + let bad id = + Id.Set.mem id avoid || + (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string "p") bad + +let add_name accu = function +| Name id -> Id.Set.add id accu +| Anonymous -> accu + +let rec ids_of_pattern accu {v=pat} = match pat with +| CPatVar Anonymous -> accu +| CPatVar (Name id) -> Id.Set.add id accu +| CPatRef (_, pl) -> + List.fold_left ids_of_pattern accu pl +| CPatCnv (pat, _) -> ids_of_pattern accu pat + +let loc_of_relid = function +| RelId {loc} -> loc +| AbsKn _ -> None + +let extract_pattern_type ({loc;v=p} as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + +(** Expand pattern: [p => t] becomes [x => match x with p => t end] *) +let expand_pattern avoid bnd = + let fold (avoid, bnd) (pat, t) = + let na, expand = match pat.v with + | CPatVar na -> + (* Don't expand variable patterns *) + na, None + | _ -> + let id = fresh_var avoid in + let qid = RelId (qualid_of_ident ?loc:pat.loc id) in + Name id, Some qid + in + let avoid = ids_of_pattern avoid pat in + let avoid = add_name avoid na in + (avoid, (na, pat, expand) :: bnd) + in + let (_, bnd) = List.fold_left fold (avoid, []) bnd in + let fold e (na, pat, expand) = match expand with + | None -> e + | Some qid -> + let loc = loc_of_relid qid in + CAst.make ?loc @@ CTacCse (CAst.make ?loc @@ CTacRef qid, [pat, e]) + in + let expand e = List.fold_left fold e bnd in + let nas = List.rev_map (fun (na, _, _) -> na) bnd in + (nas, expand) + +let is_alias env qid = match get_variable env qid with +| ArgArg (TacAlias _) -> true +| ArgVar _ | (ArgArg (TacConstant _)) -> false + +let rec intern_rec env {loc;v=e} = match e with +| CTacAtm atm -> intern_atm env atm +| CTacRef qid -> + begin match get_variable env qid with + | ArgVar {CAst.v=id} -> + let sch = Id.Map.find id env.env_var in + (GTacVar id, fresh_mix_type_scheme env sch) + | ArgArg (TacConstant kn) -> + let { Tac2env.gdata_type = sch } = + try Tac2env.interp_global kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) + in + (GTacRef kn, fresh_type_scheme env sch) + | ArgArg (TacAlias kn) -> + let e = + try Tac2env.interp_alias kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) + in + intern_rec env e + end +| CTacCst qid -> + let kn = get_constructor env qid in + intern_constructor env loc kn [] +| CTacFun (bnd, e) -> + let bnd = List.map extract_pattern_type bnd in + let map (_, t) = match t with + | None -> GTypVar (fresh_id env) + | Some t -> intern_type env t + in + let tl = List.map map bnd in + let (nas, exp) = expand_pattern (Id.Map.domain env.env_var) bnd in + let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env nas tl in + let (e, t) = intern_rec env (exp e) in + let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in + (GTacFun (nas, e), t) +| CTacApp ({loc;v=CTacCst qid}, args) -> + let kn = get_constructor env qid in + intern_constructor env loc kn args +| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> + let kn = match get_variable env qid with + | ArgArg (TacAlias kn) -> kn + | ArgVar _ | (ArgArg (TacConstant _)) -> assert false + in + let e = Tac2env.interp_alias kn in + let map arg = + (* Thunk alias arguments *) + let loc = arg.loc in + let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in + let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in + CAst.make ?loc @@ CTacFun ([var], arg) + in + let args = List.map map args in + intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) +| CTacApp (f, args) -> + let loc = f.loc in + let (f, ft) = intern_rec env f in + let fold arg (args, t) = + let loc = arg.loc in + let (arg, argt) = intern_rec env arg in + (arg :: args, (loc, argt) :: t) + in + let (args, t) = List.fold_right fold args ([], []) in + let ret = unify_arrow ?loc env ft t in + (GTacApp (f, args), ret) +| CTacLet (is_rec, el, e) -> + let map (pat, e) = + let (pat, ty) = extract_pattern_type pat in + (pat, ty, e) + in + let el = List.map map el in + let fold accu (pat, _, e) = + let ids = ids_of_pattern Id.Set.empty pat in + let common = Id.Set.inter ids accu in + if Id.Set.is_empty common then Id.Set.union ids accu + else + let id = Id.Set.choose common in + user_err ?loc:pat.loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + in + let ids = List.fold_left fold Id.Set.empty el in + if is_rec then intern_let_rec env loc ids el e + else intern_let env loc ids el e +| CTacCnv (e, tc) -> + let (e, t) = intern_rec env e in + let tc = intern_type env tc in + let () = unify ?loc env t tc in + (e, tc) +| CTacSeq (e1, e2) -> + let loc1 = e1.loc in + let (e1, t1) = intern_rec env e1 in + let (e2, t2) = intern_rec env e2 in + let () = check_elt_unit loc1 env t1 in + (GTacLet (false, [Anonymous, e1], e2), t2) +| CTacCse (e, pl) -> + intern_case env loc e pl +| CTacRec fs -> + intern_record env loc fs +| CTacPrj (e, proj) -> + let pinfo = get_projection proj in + let loc = e.loc in + let (e, t) = intern_rec env e in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (Other pinfo.pdata_type, params) in + let () = unify ?loc env t exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) +| CTacSet (e, proj, r) -> + let pinfo = get_projection proj in + let () = + if not pinfo.pdata_mutb then + let loc = match proj with + | RelId {CAst.loc} -> loc + | AbsKn _ -> None + in + user_err ?loc (str "Field is not mutable") + in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (Other pinfo.pdata_type, params) in + let e = intern_rec_with_constraint env e exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + let r = intern_rec_with_constraint env r ret in + (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) +| CTacExt (tag, arg) -> + let open Genintern in + let self ist e = + let env = match Store.get ist.extra ltac2_env with + | None -> empty_env () + | Some env -> env + in + intern_rec env e + in + let obj = interp_ml_object tag in + (* External objects do not have access to the named context because this is + not stable by dynamic semantics. *) + let genv = Global.env_of_context Environ.empty_named_context_val in + let ist = empty_glob_sign genv in + let ist = { ist with extra = Store.set ist.extra ltac2_env env } in + let arg, tpe = + if env.env_str then + let arg () = obj.ml_intern self ist arg in + Flags.with_option Ltac_plugin.Tacintern.strict_check arg () + else + obj.ml_intern self ist arg + in + let e = match arg with + | GlbVal arg -> GTacExt (tag, arg) + | GlbTacexpr e -> e + in + (e, tpe) + +and intern_rec_with_constraint env e exp = + let (er, t) = intern_rec env e in + let () = unify ?loc:e.loc env t exp in + er + +and intern_let env loc ids el e = + let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in + let fold (pat, t, e) (avoid, accu) = + let nas, exp = expand_pattern avoid [pat, t] in + let na = match nas with [x] -> x | _ -> assert false in + let avoid = List.fold_left add_name avoid nas in + (avoid, (na, exp, t, e) :: accu) + in + let (_, el) = List.fold_right fold el (avoid, []) in + let fold (na, exp, tc, e) (body, el, p) = + let (e, t) = match tc with + | None -> intern_rec env e + | Some tc -> + let tc = intern_type env tc in + (intern_rec_with_constraint env e tc, tc) + in + let t = if is_value e then abstract_var env t else monomorphic t in + (exp body, (na, e) :: el, (na, t) :: p) + in + let (e, el, p) = List.fold_right fold el (e, [], []) in + let env = List.fold_left (fun accu (na, t) -> push_name na t accu) env p in + let (e, t) = intern_rec env e in + (GTacLet (false, el, e), t) + +and intern_let_rec env loc ids el e = + let map env (pat, t, e) = + let na = match pat.v with + | CPatVar na -> na + | CPatRef _ | CPatCnv _ -> + user_err ?loc:pat.loc (str "This kind of pattern is forbidden in let-rec bindings") + in + let id = fresh_id env in + let env = push_name na (monomorphic (GTypVar id)) env in + (env, (loc, na, t, e, id)) + in + let (env, el) = List.fold_left_map map env el in + let fold (loc, na, tc, e, id) (el, tl) = + let loc_e = e.loc in + let (e, t) = intern_rec env e in + let () = + if not (is_rec_rhs e) then + user_err ?loc:loc_e (str "This kind of expression is not allowed as \ + right-hand side of a recursive binding") + in + let () = unify ?loc env t (GTypVar id) in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify ?loc env t tc + in + ((na, e) :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + let (e, t) = intern_rec env e in + (GTacLet (true, el, e), t) + +(** For now, patterns recognized by the pattern-matching compiling are limited + to depth-one where leaves are either variables or catch-all *) +and intern_case env loc e pl = + let (e', t) = intern_rec env e in + let todo ?loc () = user_err ?loc (str "Pattern not handled yet") in + match get_pattern_kind env pl with + | PKind_any -> + let (pat, b) = List.hd pl in + let na = match intern_patexpr env pat with + | GPatVar na -> na + | _ -> assert false + in + let () = check_redundant_clause (List.tl pl) in + let env = push_name na (monomorphic t) env in + let (b, tb) = intern_rec env b in + (GTacLet (false, [na, e'], b), tb) + | PKind_empty -> + let kn = check_elt_empty loc env t in + let r = fresh_id env in + (GTacCse (e', Other kn, [||], [||]), GTypVar r) + | PKind_variant kn -> + let subst, tc = fresh_reftype env kn in + let () = unify ?loc:e.loc env t tc in + let (nconst, nnonconst, arities) = match kn with + | Tuple 0 -> 1, 0, [0] + | Tuple n -> 0, 1, [n] + | Other kn -> + let (_, def) = Tac2env.interp_type kn in + let galg = match def with | GTydAlg c -> c | _ -> assert false in + let arities = List.map (fun (_, args) -> List.length args) galg.galg_constructors in + galg.galg_nconst, galg.galg_nnonconst, arities + in + let const = Array.make nconst None in + let nonconst = Array.make nnonconst None in + let ret = GTypVar (fresh_id env) in + let rec intern_branch = function + | [] -> () + | (pat, br) :: rem -> + let tbr = match pat.v with + | CPatVar (Name _) -> + let loc = pat.loc in + todo ?loc () + | CPatVar Anonymous -> + let () = check_redundant_clause rem in + let (br', brT) = intern_rec env br in + (* Fill all remaining branches *) + let fill (ncst, narg) arity = + if Int.equal arity 0 then + let () = + if Option.is_empty const.(ncst) then const.(ncst) <- Some br' + in + (succ ncst, narg) + else + let () = + if Option.is_empty nonconst.(narg) then + let ids = Array.make arity Anonymous in + nonconst.(narg) <- Some (ids, br') + in + (ncst, succ narg) + in + let _ = List.fold_left fill (0, 0) arities in + brT + | CPatRef (qid, args) -> + let loc = pat.loc in + let knc = get_constructor env qid in + let kn', index, arity = match knc with + | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) + | Other knc -> + let data = Tac2env.interp_constructor knc in + let index = Option.get data.cdata_indx in + Other data.cdata_type, index, data.cdata_args + in + let () = + if not (eq_or_tuple KerName.equal kn kn') then + invalid_pattern ?loc kn kn' + in + let get_id pat = match pat with + | {v=CPatVar na} -> na + | {loc} -> todo ?loc () + in + let ids = List.map get_id args in + let nids = List.length ids in + let nargs = List.length arity in + let () = match knc with + | Tuple n -> assert (n == nids) + | Other knc -> + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids + in + let fold env id tpe = + (* Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids arity in + let (br', brT) = intern_rec nenv br in + let () = + if List.is_empty args then + if Option.is_empty const.(index) then const.(index) <- Some br' + else warn_redundant_clause ?loc () + else + let ids = Array.of_list ids in + if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') + else warn_redundant_clause ?loc () + in + brT + | CPatCnv _ -> + user_err ?loc (str "Pattern not handled yet") + in + let () = unify ?loc:br.loc env tbr ret in + intern_branch rem + in + let () = intern_branch pl in + let map n is_const = function + | None -> + let kn = match kn with Other kn -> kn | _ -> assert false in + let cstr = pr_internal_constructor kn n is_const in + user_err ?loc (str "Unhandled match case for constructor " ++ cstr) + | Some x -> x + in + let const = Array.mapi (fun i o -> map i true o) const in + let nonconst = Array.mapi (fun i o -> map i false o) nonconst in + let ce = GTacCse (e', kn, const, nonconst) in + (ce, ret) + | PKind_open kn -> + let subst, tc = fresh_reftype env (Other kn) in + let () = unify ?loc:e.loc env t tc in + let ret = GTypVar (fresh_id env) in + let rec intern_branch map = function + | [] -> + user_err ?loc (str "Missing default case") + | (pat, br) :: rem -> + match intern_patexpr env pat with + | GPatVar na -> + let () = check_redundant_clause rem in + let nenv = push_name na (monomorphic tc) env in + let br' = intern_rec_with_constraint nenv br ret in + let def = (na, br') in + (map, def) + | GPatRef (knc, args) -> + let get = function + | GPatVar na -> na + | GPatRef _ -> + user_err ?loc (str "TODO: Unhandled match case") (* FIXME *) + in + let loc = pat.loc in + let knc = match knc with + | Other knc -> knc + | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) + in + let ids = List.map get args in + let data = Tac2env.interp_constructor knc in + let () = + if not (KerName.equal kn data.cdata_type) then + invalid_pattern ?loc (Other kn) (Other data.cdata_type) + in + let nids = List.length ids in + let nargs = List.length data.cdata_args in + let () = + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids + in + let fold env id tpe = + (* Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids data.cdata_args in + let br' = intern_rec_with_constraint nenv br ret in + let map = + if KNmap.mem knc map then + let () = warn_redundant_clause ?loc () in + map + else + KNmap.add knc (Anonymous, Array.of_list ids, br') map + in + intern_branch map rem + in + let (map, def) = intern_branch KNmap.empty pl in + (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) + +and intern_constructor env loc kn args = match kn with +| Other kn -> + let cstr = interp_constructor kn in + let nargs = List.length cstr.cdata_args in + if Int.equal nargs (List.length args) then + let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in + let targs = List.init cstr.cdata_prms (fun i -> GTypVar subst.(i)) in + let ans = GTypRef (Other cstr.cdata_type, targs) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + match cstr.cdata_indx with + | Some idx -> + (GTacCst (Other cstr.cdata_type, idx, args), ans) + | None -> + (GTacOpn (kn, args), ans) + else + error_nargs_mismatch ?loc kn nargs (List.length args) +| Tuple n -> + assert (Int.equal n (List.length args)); + let types = List.init n (fun i -> GTypVar (fresh_id env)) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + let ans = GTypRef (Tuple n, types) in + GTacCst (Tuple n, 0, args), ans + +and intern_record env loc fs = + let map (proj, e) = + let loc = match proj with + | RelId {CAst.loc} -> loc + | AbsKn _ -> None + in + let proj = get_projection proj in + (loc, proj, e) + in + let fs = List.map map fs in + let kn = match fs with + | [] -> user_err ?loc (str "Cannot infer the corresponding record type") + | (_, proj, _) :: _ -> proj.pdata_type + in + let params, typdef = match Tac2env.interp_type kn with + | n, GTydRec def -> n, def + | _ -> assert false + in + let subst = Array.init params (fun _ -> fresh_id env) in + (* Set the answer [args] imperatively *) + let args = Array.make (List.length typdef) None in + let iter (loc, pinfo, e) = + if KerName.equal kn pinfo.pdata_type then + let index = pinfo.pdata_indx in + match args.(index) with + | None -> + let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in + let e = intern_rec_with_constraint env e exp in + args.(index) <- Some e + | Some _ -> + let (name, _, _) = List.nth typdef pinfo.pdata_indx in + user_err ?loc (str "Field " ++ Id.print name ++ str " is defined \ + several times") + else + user_err ?loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ + pertain to record definition " ++ pr_typref pinfo.pdata_type) + in + let () = List.iter iter fs in + let () = match Array.findi (fun _ o -> Option.is_empty o) args with + | None -> () + | Some i -> + let (field, _, _) = List.nth typdef i in + user_err ?loc (str "Field " ++ Id.print field ++ str " is undefined") + in + let args = Array.map_to_list Option.get args in + let tparam = List.init params (fun i -> GTypVar subst.(i)) in + (GTacCst (Other kn, 0, args), GTypRef (Other kn, tparam)) + +let normalize env (count, vars) (t : UF.elt glb_typexpr) = + let get_var id = + try UF.Map.find id !vars + with Not_found -> + let () = assert env.env_opn in + let n = GTypVar !count in + let () = incr count in + let () = vars := UF.Map.add id n !vars in + n + in + let rec subst id = match UF.find id env.env_cst with + | id, None -> get_var id + | _, Some t -> subst_type subst t + in + subst_type subst t + +let intern ~strict e = + let env = empty_env () in + let env = if strict then env else { env with env_str = false } in + let (e, t) = intern_rec env e in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (e, (!count, t)) + +let intern_typedef self (ids, t) : glb_quant_typedef = + let env = { (empty_env ()) with env_rec = self } in + (* Initialize type parameters *) + let map id = get_alias id env in + let ids = List.map map ids in + let count = ref (List.length ids) in + let vars = ref UF.Map.empty in + let iter n id = vars := UF.Map.add id (GTypVar n) !vars in + let () = List.iteri iter ids in + (* Do not accept unbound type variables *) + let env = { env with env_opn = false } in + let intern t = + let t = intern_type env t in + normalize env (count, vars) t + in + let count = !count in + match t with + | CTydDef None -> (count, GTydDef None) + | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) + | CTydAlg constrs -> + let map (c, t) = (c, List.map intern t) in + let constrs = List.map map constrs in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) constrs in + let galg = { + galg_constructors = constrs; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + (count, GTydAlg galg) + | CTydRec fields -> + let map (c, mut, t) = (c, mut, intern t) in + let fields = List.map map fields in + (count, GTydRec fields) + | CTydOpn -> (count, GTydOpn) + +let intern_open_type t = + let env = empty_env () in + let t = intern_type env t in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (!count, t) + +(** Subtyping *) + +let check_subtype t1 t2 = + let env = empty_env () in + let t1 = fresh_type_scheme env t1 in + (* We build a substitution mimicking rigid variable by using dummy tuples *) + let rigid i = GTypRef (Tuple (i + 1), []) in + let (n, t2) = t2 in + let subst = Array.init n rigid in + let substf i = subst.(i) in + let t2 = subst_type substf t2 in + try unify0 env t1 t2; true with CannotUnify _ -> false + +(** Globalization *) + +let get_projection0 var = match var with +| RelId qid -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") + in + kn +| AbsKn kn -> kn + +let rec globalize ids ({loc;v=er} as e) = match er with +| CTacAtm _ -> e +| CTacRef ref -> + let mem id = Id.Set.mem id ids in + begin match get_variable0 mem ref with + | ArgVar _ -> e + | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) + end +| CTacCst qid -> + let knc = get_constructor () qid in + CAst.make ?loc @@ CTacCst (AbsKn knc) +| CTacFun (bnd, e) -> + let fold (pats, accu) pat = + let accu = ids_of_pattern accu pat in + let pat = globalize_pattern ids pat in + (pat :: pats, accu) + in + let bnd, ids = List.fold_left fold ([], ids) bnd in + let bnd = List.rev bnd in + let e = globalize ids e in + CAst.make ?loc @@ CTacFun (bnd, e) +| CTacApp (e, el) -> + let e = globalize ids e in + let el = List.map (fun e -> globalize ids e) el in + CAst.make ?loc @@ CTacApp (e, el) +| CTacLet (isrec, bnd, e) -> + let fold accu (pat, _) = ids_of_pattern accu pat in + let ext = List.fold_left fold Id.Set.empty bnd in + let eids = Id.Set.union ext ids in + let e = globalize eids e in + let map (qid, e) = + let ids = if isrec then eids else ids in + let qid = globalize_pattern ids qid in + (qid, globalize ids e) + in + let bnd = List.map map bnd in + CAst.make ?loc @@ CTacLet (isrec, bnd, e) +| CTacCnv (e, t) -> + let e = globalize ids e in + CAst.make ?loc @@ CTacCnv (e, t) +| CTacSeq (e1, e2) -> + let e1 = globalize ids e1 in + let e2 = globalize ids e2 in + CAst.make ?loc @@ CTacSeq (e1, e2) +| CTacCse (e, bl) -> + let e = globalize ids e in + let bl = List.map (fun b -> globalize_case ids b) bl in + CAst.make ?loc @@ CTacCse (e, bl) +| CTacRec r -> + let map (p, e) = + let p = get_projection0 p in + let e = globalize ids e in + (AbsKn p, e) + in + CAst.make ?loc @@ CTacRec (List.map map r) +| CTacPrj (e, p) -> + let e = globalize ids e in + let p = get_projection0 p in + CAst.make ?loc @@ CTacPrj (e, AbsKn p) +| CTacSet (e, p, e') -> + let e = globalize ids e in + let p = get_projection0 p in + let e' = globalize ids e' in + CAst.make ?loc @@ CTacSet (e, AbsKn p, e') +| CTacExt (tag, arg) -> + let arg = str (Tac2dyn.Arg.repr tag) in + CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) + +and globalize_case ids (p, e) = + (globalize_pattern ids p, globalize ids e) + +and globalize_pattern ids ({loc;v=pr} as p) = match pr with +| CPatVar _ -> p +| CPatRef (cst, pl) -> + let knc = get_constructor () cst in + let cst = AbsKn knc in + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CAst.make ?loc @@ CPatRef (cst, pl) +| CPatCnv (pat, ty) -> + let pat = globalize_pattern ids pat in + CAst.make ?loc @@ CPatCnv (pat, ty) + +(** Kernel substitution *) + +open Mod_subst + +let subst_or_tuple f subst o = match o with +| Tuple _ -> o +| Other v -> + let v' = f subst v in + if v' == v then o else Other v' + +let rec subst_type subst t = match t with +| GTypVar _ -> t +| GTypArrow (t1, t2) -> + let t1' = subst_type subst t1 in + let t2' = subst_type subst t2 in + if t1' == t1 && t2' == t2 then t + else GTypArrow (t1', t2') +| GTypRef (kn, tl) -> + let kn' = subst_or_tuple subst_kn subst kn in + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in + if kn' == kn && tl' == tl then t else GTypRef (kn', tl') + +let rec subst_expr subst e = match e with +| GTacAtm _ | GTacVar _ | GTacPrm _ -> e +| GTacRef kn -> GTacRef (subst_kn subst kn) +| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) +| GTacApp (f, args) -> + GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) +| GTacLet (r, bs, e) -> + let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in + GTacLet (r, bs, subst_expr subst e) +| GTacCst (t, n, el) as e0 -> + let t' = subst_or_tuple subst_kn subst t in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in + if t' == t && el' == el then e0 else GTacCst (t', n, el') +| GTacCse (e, ci, cse0, cse1) -> + let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in + let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in + let ci' = subst_or_tuple subst_kn subst ci in + GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> + let e' = subst_expr subst e in + let def' = subst_expr subst def in + let fold kn (self, vars, p) accu = + let kn' = subst_kn subst kn in + let p' = subst_expr subst p in + if kn' == kn && p' == p then accu + else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) + in + let br' = KNmap.fold fold br br in + if e' == e && br' == br && def' == def then e0 + else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } +| GTacPrj (kn, e, p) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) +| GTacSet (kn, e, p, r) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + let r' = subst_expr subst r in + if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') +| GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + let arg' = tpe.ml_subst subst arg in + if arg' == arg then e else GTacExt (tag, arg') +| GTacOpn (kn, el) as e0 -> + let kn' = subst_kn subst kn in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in + if kn' == kn && el' == el then e0 else GTacOpn (kn', el') + +let subst_typedef subst e = match e with +| GTydDef t -> + let t' = Option.Smart.map (fun t -> subst_type subst t) t in + if t' == t then e else GTydDef t' +| GTydAlg galg -> + let map (c, tl as p) = + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in + if tl' == tl then p else (c, tl') + in + let constrs' = List.Smart.map map galg.galg_constructors in + if constrs' == galg.galg_constructors then e + else GTydAlg { galg with galg_constructors = constrs' } +| GTydRec fields -> + let map (c, mut, t as p) = + let t' = subst_type subst t in + if t' == t then p else (c, mut, t') + in + let fields' = List.Smart.map map fields in + if fields' == fields then e else GTydRec fields' +| GTydOpn -> GTydOpn + +let subst_quant_typedef subst (prm, def as qdef) = + let def' = subst_typedef subst def in + if def' == def then qdef else (prm, def') + +let subst_type_scheme subst (prm, t as sch) = + let t' = subst_type subst t in + if t' == t then sch else (prm, t') + +let subst_or_relid subst ref = match ref with +| RelId _ -> ref +| AbsKn kn -> + let kn' = subst_or_tuple subst_kn subst kn in + if kn' == kn then ref else AbsKn kn' + +let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with +| CTypVar _ -> t +| CTypArrow (t1, t2) -> + let t1' = subst_rawtype subst t1 in + let t2' = subst_rawtype subst t2 in + if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') +| CTypRef (ref, tl) -> + let ref' = subst_or_relid subst ref in + let tl' = List.Smart.map (fun t -> subst_rawtype subst t) tl in + if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') + +let subst_tacref subst ref = match ref with +| RelId _ -> ref +| AbsKn (TacConstant kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstant kn') +| AbsKn (TacAlias kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacAlias kn') + +let subst_projection subst prj = match prj with +| RelId _ -> prj +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then prj else AbsKn kn' + +let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with +| CPatVar _ -> p +| CPatRef (c, pl) -> + let pl' = List.Smart.map (fun p -> subst_rawpattern subst p) pl in + let c' = subst_or_relid subst c in + if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') +| CPatCnv (pat, ty) -> + let pat' = subst_rawpattern subst pat in + let ty' = subst_rawtype subst ty in + if pat' == pat && ty' == ty then p else CAst.make ?loc @@ CPatCnv (pat', ty') + +(** Used for notations *) +let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with +| CTacAtm _ -> t +| CTacRef ref -> + let ref' = subst_tacref subst ref in + if ref' == ref then t else CAst.make ?loc @@ CTacRef ref' +| CTacCst ref -> + let ref' = subst_or_relid subst ref in + if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' +| CTacFun (bnd, e) -> + let map pat = subst_rawpattern subst pat in + let bnd' = List.Smart.map map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') +| CTacApp (e, el) -> + let e' = subst_rawexpr subst e in + let el' = List.Smart.map (fun e -> subst_rawexpr subst e) el in + if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') +| CTacLet (isrec, bnd, e) -> + let map (na, e as p) = + let na' = subst_rawpattern subst na in + let e' = subst_rawexpr subst e in + if na' == na && e' == e then p else (na', e') + in + let bnd' = List.Smart.map map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') +| CTacCnv (e, c) -> + let e' = subst_rawexpr subst e in + let c' = subst_rawtype subst c in + if c' == c && e' == e then t else CAst.make ?loc @@ CTacCnv (e', c') +| CTacSeq (e1, e2) -> + let e1' = subst_rawexpr subst e1 in + let e2' = subst_rawexpr subst e2 in + if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') +| CTacCse (e, bl) -> + let map (p, e as x) = + let p' = subst_rawpattern subst p in + let e' = subst_rawexpr subst e in + if p' == p && e' == e then x else (p', e') + in + let e' = subst_rawexpr subst e in + let bl' = List.Smart.map map bl in + if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') +| CTacRec el -> + let map (prj, e as p) = + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then p else (prj', e') + in + let el' = List.Smart.map map el in + if el' == el then t else CAst.make ?loc @@ CTacRec el' +| CTacPrj (e, prj) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then t else CAst.make ?loc @@ CTacPrj (e', prj') +| CTacSet (e, prj, r) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + let r' = subst_rawexpr subst r in + if prj' == prj && e' == e && r' == r then t else CAst.make ?loc @@ CTacSet (e', prj', r') +| CTacExt _ -> assert false (** Should not be generated by globalization *) + +(** Registering *) + +let () = + let open Genintern in + let intern ist tac = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let loc = tac.loc in + let (tac, t) = intern_rec env tac in + let () = check_elt_unit loc env t in + (ist, tac) + in + Genintern.register_intern0 wit_ltac2 intern +let () = Genintern.register_subst0 wit_ltac2 subst_expr + +let () = + let open Genintern in + let intern ist (loc, id) = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let t = + try Id.Map.find id env.env_var + with Not_found -> + CErrors.user_err ?loc (str "Unbound value " ++ Id.print id) + in + let t = fresh_mix_type_scheme env t in + let () = unify ?loc env t (GTypRef (Other t_constr, [])) in + (ist, id) + in + Genintern.register_intern0 wit_ltac2_quotation intern + +let () = Genintern.register_subst0 wit_ltac2_quotation (fun _ id -> id) diff --git a/user-contrib/Ltac2/tac2intern.mli b/user-contrib/Ltac2/tac2intern.mli new file mode 100644 index 0000000000..d646b5cda5 --- /dev/null +++ b/user-contrib/Ltac2/tac2intern.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_tacexpr -> glb_tacexpr * type_scheme +val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef +val intern_open_type : raw_typexpr -> type_scheme + +(** Check that a term is a value. Only values are safe to marshall between + processes. *) +val is_value : glb_tacexpr -> bool +val check_unit : ?loc:Loc.t -> type_scheme -> unit + +val check_subtype : type_scheme -> type_scheme -> bool +(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] + also have type [t2]. *) + +val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr +val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr +val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef +val subst_type_scheme : substitution -> type_scheme -> type_scheme + +val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr + +(** {5 Notations} *) + +val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr +(** Replaces all qualified identifiers by their corresponding kernel name. The + set represents bound variables in the context. *) + +(** Errors *) + +val error_nargs_mismatch : ?loc:Loc.t -> ltac_constructor -> int -> int -> 'a +val error_nparams_mismatch : ?loc:Loc.t -> int -> int -> 'a + +(** Misc *) + +val drop_ltac2_env : Genintern.Store.t -> Genintern.Store.t diff --git a/user-contrib/Ltac2/tac2interp.ml b/user-contrib/Ltac2/tac2interp.ml new file mode 100644 index 0000000000..db779db471 --- /dev/null +++ b/user-contrib/Ltac2/tac2interp.ml @@ -0,0 +1,227 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* >= fun sigma -> + match Evd.Store.get (Evd.get_extra_data sigma) backtrace with + | None -> Proofview.tclUNIT [] + | Some bt -> Proofview.tclUNIT bt + +let set_backtrace bt = + Proofview.tclEVARMAP >>= fun sigma -> + let store = Evd.get_extra_data sigma in + let store = Evd.Store.set store backtrace bt in + let sigma = Evd.set_extra_data store sigma in + Proofview.Unsafe.tclEVARS sigma + +let with_frame frame tac = + if !print_ltac2_backtrace then + get_backtrace >>= fun bt -> + set_backtrace (frame :: bt) >>= fun () -> + tac >>= fun ans -> + set_backtrace bt >>= fun () -> + Proofview.tclUNIT ans + else tac + +type environment = Tac2env.environment = { + env_ist : valexpr Id.Map.t; +} + +let empty_environment = { + env_ist = Id.Map.empty; +} + +type closure = { + mutable clos_env : valexpr Id.Map.t; + (** Mutable so that we can implement recursive functions imperatively *) + clos_var : Name.t list; + (** Bound variables *) + clos_exp : glb_tacexpr; + (** Body *) + clos_ref : ltac_constant option; + (** Global constant from which the closure originates *) +} + +let push_name ist id v = match id with +| Anonymous -> ist +| Name id -> { env_ist = Id.Map.add id v ist.env_ist } + +let get_var ist id = + try Id.Map.find id ist.env_ist with Not_found -> + anomaly (str "Unbound variable " ++ Id.print id) + +let get_ref ist kn = + try + let data = Tac2env.interp_global kn in + data.Tac2env.gdata_expr + with Not_found -> + anomaly (str "Unbound reference" ++ KerName.print kn) + +let return = Proofview.tclUNIT + +let rec interp (ist : environment) = function +| GTacAtm (AtmInt n) -> return (Tac2ffi.of_int n) +| GTacAtm (AtmStr s) -> return (Tac2ffi.of_string (Bytes.of_string s)) +| GTacVar id -> return (get_var ist id) +| GTacRef kn -> + let data = get_ref ist kn in + return (eval_pure (Some kn) data) +| GTacFun (ids, e) -> + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in + let f = interp_app cls in + return (Tac2ffi.of_closure f) +| GTacApp (f, args) -> + interp ist f >>= fun f -> + Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> + Tac2ffi.apply (Tac2ffi.to_closure f) args +| GTacLet (false, el, e) -> + let fold accu (na, e) = + interp ist e >>= fun e -> + return (push_name accu na e) + in + Proofview.Monad.List.fold_left fold ist el >>= fun ist -> + interp ist e +| GTacLet (true, el, e) -> + let map (na, e) = match e with + | GTacFun (ids, e) -> + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in + let f = Tac2ffi.of_closure (interp_app cls) in + na, cls, f + | _ -> anomaly (str "Ill-formed recursive function") + in + let fixs = List.map map el in + let fold accu (na, _, cls) = match na with + | Anonymous -> accu + | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } + in + let ist = List.fold_left fold ist fixs in + (* Hack to make a cycle imperatively in the environment *) + let iter (_, e, _) = e.clos_env <- ist.env_ist in + let () = List.iter iter fixs in + interp ist e +| GTacCst (_, n, []) -> return (Valexpr.make_int n) +| GTacCst (_, n, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (Valexpr.make_block n (Array.of_list el)) +| GTacCse (e, _, cse0, cse1) -> + interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> + interp ist e >>= fun e -> interp_with ist e cse def +| GTacPrj (_, e, p) -> + interp ist e >>= fun e -> interp_proj ist e p +| GTacSet (_, e, p, r) -> + interp ist e >>= fun e -> + interp ist r >>= fun r -> + interp_set ist e p r +| GTacOpn (kn, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (Tac2ffi.of_open (kn, Array.of_list el)) +| GTacPrm (ml, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) +| GTacExt (tag, e) -> + let tpe = Tac2env.interp_ml_object tag in + with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) + +and interp_app f = + let ans = fun args -> + let { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } = f in + let frame = match kn with + | None -> FrAnon e + | Some kn -> FrLtac kn + in + let ist = { env_ist = ist } in + let ist = List.fold_left2 push_name ist ids args in + with_frame frame (interp ist e) + in + Tac2ffi.abstract (List.length f.clos_var) ans + +and interp_case ist e cse0 cse1 = + if Valexpr.is_int e then + interp ist cse0.(Tac2ffi.to_int e) + else + let (n, args) = Tac2ffi.to_block e in + let (ids, e) = cse1.(n) in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist e + +and interp_with ist e cse def = + let (kn, args) = Tac2ffi.to_open e in + let br = try Some (KNmap.find kn cse) with Not_found -> None in + begin match br with + | None -> + let (self, def) = def in + let ist = push_name ist self e in + interp ist def + | Some (self, ids, p) -> + let ist = push_name ist self e in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist p + end + +and interp_proj ist e p = + return (Valexpr.field e p) + +and interp_set ist e p r = + let () = Valexpr.set_field e p r in + return (Valexpr.make_int 0) + +and eval_pure kn = function +| GTacAtm (AtmInt n) -> Valexpr.make_int n +| GTacRef kn -> + let { Tac2env.gdata_expr = e } = + try Tac2env.interp_global kn + with Not_found -> assert false + in + eval_pure (Some kn) e +| GTacFun (na, e) -> + let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in + let f = interp_app cls in + Tac2ffi.of_closure f +| GTacCst (_, n, []) -> Valexpr.make_int n +| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) +| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) +| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> + anomaly (Pp.str "Term is not a syntactical value") + +and eval_unnamed e = eval_pure None e + + +(** Cross-boundary hacks. *) + +open Geninterp + +let val_env : environment Val.typ = Val.create "ltac2:env" +let env_ref = Id.of_string_soft "@@ltac2_env@@" + +let extract_env (Val.Dyn (tag, v)) : environment = +match Val.eq tag val_env with +| None -> assert false +| Some Refl -> v + +let get_env ist = + try extract_env (Id.Map.find env_ref ist) + with Not_found -> empty_environment + +let set_env env ist = + Id.Map.add env_ref (Val.Dyn (val_env, env)) ist diff --git a/user-contrib/Ltac2/tac2interp.mli b/user-contrib/Ltac2/tac2interp.mli new file mode 100644 index 0000000000..21fdcd03af --- /dev/null +++ b/user-contrib/Ltac2/tac2interp.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glb_tacexpr -> valexpr Proofview.tactic + +(* val interp_app : closure -> ml_tactic *) + +(** {5 Cross-boundary encodings} *) + +val get_env : Ltac_pretype.unbound_ltac_var_map -> environment +val set_env : environment -> Ltac_pretype.unbound_ltac_var_map -> Ltac_pretype.unbound_ltac_var_map + +(** {5 Exceptions} *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) + +(** {5 Backtrace} *) + +val get_backtrace : backtrace Proofview.tactic + +val with_frame : frame -> 'a Proofview.tactic -> 'a Proofview.tactic + +val print_ltac2_backtrace : bool ref diff --git a/user-contrib/Ltac2/tac2match.ml b/user-contrib/Ltac2/tac2match.ml new file mode 100644 index 0000000000..058d02adde --- /dev/null +++ b/user-contrib/Ltac2/tac2match.ml @@ -0,0 +1,232 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + Id.Map.merge merge s1 s2 + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> result -> 'r tac) -> result -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + } in + let eval x ctx = Proofview.tclUNIT (x, ctx) in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + let put_subst subst : unit m = + let s = { subst } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** {6 Pattern-matching} *) + + let pattern_match_term pat term = + match pat with + | MatchPattern p -> + begin + try + put_subst (Constr_matching.matches E.env E.sigma p term) <*> + return None + with Constr_matching.PatternMatchingFailure -> fail + end + | MatchContext p -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub = (_, subst); m_ctx }, s) -> + let nctx = { subst } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | Some nctx -> Proofview.tclOR (k (Some (Lazy.force m_ctx)) nctx) (fun e -> (map s e).stream k ctx) + } + in + map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error + + let hyp_match_type pat hyps = + pick hyps >>= fun decl -> + let id = NamedDecl.get_id decl in + pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> + return (id, ctx) + + let _hyp_match_body_and_type bodypat typepat hyps = + pick hyps >>= function + | LocalDef (id,body,hyp) -> + pattern_match_term bodypat body >>= fun ctx_body -> + pattern_match_term typepat hyp >>= fun ctx_typ -> + return (id, ctx_body, ctx_typ) + | LocalAssum (id,hyp) -> fail + + let hyp_match pat hyps = + match pat with + | typepat -> + hyp_match_type typepat hyps +(* | Def ((_,hypname),bodypat,typepat) -> *) +(* hyp_match_body_and_type hypname bodypat typepat hyps *) + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps accu = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun (matched_hyp, hyp_ctx) -> + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in + let hyps = CList.remove_first select_matched_hyp hyps in + hyp_pattern_list_match pats hyps ((matched_hyp, hyp_ctx) :: accu) + | [] -> return accu + + let rule_match_goal hyps concl = function + | (hyppats,conclpat) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term conclpat concl >>= fun ctx_concl -> + hyp_pattern_list_match hyppats hyps [] >>= fun hyps -> + return (hyps, ctx_concl) + +end + +let match_goal env sigma concl ~rev rule = + let open Proofview.Notations in + let hyps = EConstr.named_context env in + let hyps = if rev then List.rev hyps else hyps in + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.rule_match_goal hyps concl rule) >>= fun ((hyps, ctx_concl), subst) -> + Proofview.tclUNIT (hyps, ctx_concl, subst.subst) diff --git a/user-contrib/Ltac2/tac2match.mli b/user-contrib/Ltac2/tac2match.mli new file mode 100644 index 0000000000..c82c40d238 --- /dev/null +++ b/user-contrib/Ltac2/tac2match.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Evd.evar_map -> + constr -> + rev:bool -> + match_rule -> + ((Id.t * context option) list * (* List of hypotheses matching: name + context *) + context option * (* Context for conclusion *) + Ltac_pretype.patvar_map (* Pattern variable substitution *)) Proofview.tactic diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml new file mode 100644 index 0000000000..f4cb290265 --- /dev/null +++ b/user-contrib/Ltac2/tac2print.ml @@ -0,0 +1,488 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* str "'" ++ str (pr n) + | GTypRef (Other kn, []) -> pr_typref kn + | GTypRef (Other kn, [t]) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (pr_glbtype T1 t ++ spc () ++ pr_typref kn) + | GTypRef (Other kn, tl) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) + | GTypArrow (t1, t2) -> + let paren = match lvl with + | T5_r -> fun x -> x + | T5_l | T2 | T1 | T0 -> paren + in + paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) + | GTypRef (Tuple 0, []) -> + Libnames.pr_qualid (Tac2env.shortest_qualid_of_type t_unit) + | GTypRef (Tuple _, tl) -> + let paren = match lvl with + | T5_r | T5_l -> fun x -> x + | T2 | T1 | T0 -> paren + in + paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) + in + hov 0 (pr_glbtype lvl c) + +let pr_glbtype pr c = pr_glbtype_gen pr T5_r c + +let int_name () = + let vars = ref Int.Map.empty in + fun n -> + if Int.Map.mem n !vars then Int.Map.find n !vars + else + let num = Int.Map.cardinal !vars in + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + let () = vars := Int.Map.add n name !vars in + name + +(** Term printing *) + +let pr_constructor kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_constructor kn) + +let pr_projection kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) + +type exp_level = Tac2expr.exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +let pr_atom = function +| AtmInt n -> Pp.int n +| AtmStr s -> qstring s + +let pr_name = function +| Name id -> Id.print id +| Anonymous -> str "_" + +let find_constructor n empty def = + let rec find n = function + | [] -> assert false + | (id, []) as ans :: rem -> + if empty then + if Int.equal n 0 then ans + else find (pred n) rem + else find n rem + | (id, _ :: _) as ans :: rem -> + if not empty then + if Int.equal n 0 then ans + else find (pred n) rem + else find n rem + in + find n def + +let pr_internal_constructor tpe n is_const = + let data = match Tac2env.interp_type tpe with + | (_, GTydAlg data) -> data + | _ -> assert false + in + let (id, _) = find_constructor n is_const data.galg_constructors in + let kn = change_kn_label tpe id in + pr_constructor kn + +let order_branches cbr nbr def = + let rec order cidx nidx def = match def with + | [] -> [] + | (id, []) :: rem -> + let ans = order (succ cidx) nidx rem in + (id, [], cbr.(cidx)) :: ans + | (id, _ :: _) :: rem -> + let ans = order cidx (succ nidx) rem in + let (vars, e) = nbr.(nidx) in + (id, Array.to_list vars, e) :: ans + in + order 0 0 def + +let pr_glbexpr_gen lvl c = + let rec pr_glbexpr lvl = function + | GTacAtm atm -> pr_atom atm + | GTacVar id -> Id.print id + | GTacRef gr -> + let qid = shortest_qualid_of_ltac (TacConstant gr) in + Libnames.pr_qualid qid + | GTacFun (nas, c) -> + let nas = pr_sequence pr_name nas in + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + paren (hov 0 (hov 2 (str "fun" ++ spc () ++ nas) ++ spc () ++ str "=>" ++ spc () ++ + pr_glbexpr E5 c)) + | GTacApp (c, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (hov 2 (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) + | GTacLet (mut, bnd, e) -> + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + let mut = if mut then str "rec" ++ spc () else mt () in + let pr_bnd (na, e) = + pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () + in + let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in + paren (hv 0 (hov 2 (str "let" ++ spc () ++ mut ++ bnd ++ str "in") ++ spc () ++ pr_glbexpr E5 e)) + | GTacCst (Tuple 0, _, _) -> str "()" + | GTacCst (Tuple _, _, cl) -> + let paren = match lvl with + | E0 | E1 -> paren + | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) + | GTacCst (Other tpe, n, cl) -> + pr_applied_constructor lvl tpe n cl + | GTacCse (e, info, cst_br, ncst_br) -> + let e = pr_glbexpr E5 e in + let br = match info with + | Other kn -> + let def = match Tac2env.interp_type kn with + | _, GTydAlg { galg_constructors = def } -> def + | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false + in + let br = order_branches cst_br ncst_br def in + let pr_branch (cstr, vars, p) = + let cstr = change_kn_label kn cstr in + let cstr = pr_constructor cstr in + let vars = match vars with + | [] -> mt () + | _ -> spc () ++ pr_sequence pr_name vars + in + hov 4 (str "|" ++ spc () ++ hov 0 (cstr ++ vars ++ spc () ++ str "=>") ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + prlist pr_branch br + | Tuple n -> + let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in + let p = pr_glbexpr E5 p in + let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in + hov 4 (str "|" ++ spc () ++ hov 0 (paren vars ++ spc () ++ str "=>") ++ spc () ++ p) + in + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ spc () ++ str "end") + | GTacWth wth -> + let e = pr_glbexpr E5 wth.opn_match in + let pr_pattern c self vars p = + let self = match self with + | Anonymous -> mt () + | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id + in + hov 4 (str "|" ++ spc () ++ hov 0 (c ++ vars ++ self ++ spc () ++ str "=>") ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + let pr_branch (cstr, (self, vars, p)) = + let cstr = pr_constructor cstr in + let vars = match Array.to_list vars with + | [] -> mt () + | vars -> spc () ++ pr_sequence pr_name vars + in + pr_pattern cstr self vars p + in + let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in + let (def_as, def_p) = wth.opn_default in + let def = pr_pattern (str "_") def_as (mt ()) def_p in + let br = br ++ def in + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ str "end") + | GTacPrj (kn, e, n) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + hov 0 (e ++ str "." ++ paren proj) + | GTacSet (kn, e, n, r) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + let r = pr_glbexpr E1 r in + hov 0 (e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r) + | GTacOpn (kn, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let c = pr_constructor kn in + paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) + | GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) + | GTacPrm (prm, args) -> + let args = match args with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args + in + hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ + qstring prm.mltac_tactic ++ args) + and pr_applied_constructor lvl tpe n cl = + let _, data = Tac2env.interp_type tpe in + if KerName.equal tpe t_list then + let rec factorize accu = function + | GTacCst (_, 0, []) -> accu, None + | GTacCst (_, 0, [e; l]) -> factorize (e :: accu) l + | e -> accu, Some e + in + let l, e = factorize [] (GTacCst (Other tpe, n, cl)) in + match e with + | None -> + let pr e = pr_glbexpr E4 e in + hov 2 (str "[" ++ prlist_with_sep pr_semicolon pr (List.rev l) ++ str "]") + | Some e -> + let paren = match lvl with + | E0 | E1 | E2 -> paren + | E3 | E4 | E5 -> fun x -> x + in + let pr e = pr_glbexpr E1 e in + let pr_cons () = spc () ++ str "::" ++ spc () in + paren (hov 2 (prlist_with_sep pr_cons pr (List.rev (e :: l)))) + else match data with + | GTydAlg def -> + let paren = match lvl with + | E0 -> + if List.is_empty cl then fun x -> x else paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let cstr = pr_internal_constructor tpe n (List.is_empty cl) in + let cl = match cl with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl + in + paren (hov 2 (cstr ++ cl)) + | GTydRec def -> + let args = List.combine def cl in + let pr_arg ((id, _, _), arg) = + let kn = change_kn_label tpe id in + pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg + in + let args = prlist_with_sep pr_semicolon pr_arg args in + hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") + | (GTydDef _ | GTydOpn) -> assert false + in + hov 0 (pr_glbexpr lvl c) + + + +let pr_glbexpr c = + pr_glbexpr_gen E5 c + +(** Toplevel printers *) + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst.(id) +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let unfold kn args = + let (nparams, def) = Tac2env.interp_type kn in + match def with + | GTydDef (Some def) -> + let args = Array.of_list args in + Some (subst_type args def) + | _ -> None + +let rec kind t = match t with +| GTypVar id -> GTypVar id +| GTypRef (Other kn, tl) -> + begin match unfold kn tl with + | None -> t + | Some t -> kind t + end +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +let printers = ref KNmap.empty + +let register_val_printer kn pr = + printers := KNmap.add kn pr !printers + +open Tac2ffi + +let rec pr_valexpr env sigma v t = match kind t with +| GTypVar _ -> str "" +| GTypRef (Other kn, params) -> + let pr = try Some (KNmap.find kn !printers) with Not_found -> None in + begin match pr with + | Some pr -> pr.val_printer env sigma v params + | None -> + let n, repr = Tac2env.interp_type kn in + if KerName.equal kn t_list then + pr_val_list env sigma (to_list (fun v -> repr_to valexpr v) v) (List.hd params) + else match repr with + | GTydDef None -> str "" + | GTydDef (Some _) -> + (* Shouldn't happen thanks to kind *) + assert false + | GTydAlg alg -> + if Valexpr.is_int v then + pr_internal_constructor kn (Tac2ffi.to_int v) true + else + let (n, args) = Tac2ffi.to_block v in + let (id, tpe) = find_constructor n false alg.galg_constructors in + let knc = change_kn_label kn id in + let args = pr_constrargs env sigma params args tpe in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + | GTydRec rcd -> + let (_, args) = Tac2ffi.to_block v in + pr_record env sigma params args rcd + | GTydOpn -> + begin match Tac2ffi.to_open v with + | (knc, [||]) -> pr_constructor knc + | (knc, args) -> + let data = Tac2env.interp_constructor knc in + let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + end + end +| GTypArrow _ -> str "" +| GTypRef (Tuple 0, []) -> str "()" +| GTypRef (Tuple _, tl) -> + let blk = Array.to_list (snd (to_block v)) in + if List.length blk == List.length tl then + let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in + hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") + else + str "" + +and pr_constrargs env sigma params args tpe = + let subst = Array.of_list params in + let tpe = List.map (fun t -> subst_type subst t) tpe in + let args = Array.to_list args in + let args = List.combine args tpe in + prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args + +and pr_record env sigma params args rcd = + let subst = Array.of_list params in + let map (id, _, tpe) = (id, subst_type subst tpe) in + let rcd = List.map map rcd in + let args = Array.to_list args in + let fields = List.combine rcd args in + let pr_field ((id, t), arg) = + Id.print id ++ spc () ++ str ":=" ++ spc () ++ pr_valexpr env sigma arg t + in + str "{" ++ spc () ++ prlist_with_sep pr_semicolon pr_field fields ++ spc () ++ str "}" + +and pr_val_list env sigma args tpe = + let pr v = pr_valexpr env sigma v tpe in + str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" + +let register_init n f = + let kn = KerName.make Tac2env.coq_prefix (Label.make n) in + register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } + +let () = register_init "int" begin fun _ _ n -> + let n = to_int n in + Pp.int n +end + +let () = register_init "string" begin fun _ _ s -> + let s = to_string s in + Pp.quote (str (Bytes.to_string s)) +end + +let () = register_init "ident" begin fun _ _ id -> + let id = to_ident id in + str "@" ++ Id.print id +end + +let () = register_init "constr" begin fun env sigma c -> + let c = to_constr c in + let c = try Printer.pr_leconstr_env env sigma c with _ -> str "..." in + str "constr:(" ++ c ++ str ")" +end + +let () = register_init "pattern" begin fun env sigma c -> + let c = to_pattern c in + let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in + str "pattern:(" ++ c ++ str ")" +end + +let () = register_init "message" begin fun _ _ pp -> + str "message:(" ++ to_pp pp ++ str ")" +end + +let () = register_init "err" begin fun _ _ e -> + let e = to_ext val_exn e in + let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in + str "err:(" ++ CErrors.print_no_report e ++ str ")" +end + +let () = + let kn = KerName.make Tac2env.coq_prefix (Label.make "array") in + let val_printer env sigma v arg = match arg with + | [arg] -> + let (_, v) = to_block v in + str "[|" ++ spc () ++ + prvect_with_sep pr_semicolon (fun a -> pr_valexpr env sigma a arg) v ++ + spc () ++ str "|]" + | _ -> assert false + in + register_val_printer kn { val_printer } diff --git a/user-contrib/Ltac2/tac2print.mli b/user-contrib/Ltac2/tac2print.mli new file mode 100644 index 0000000000..9b9db2937d --- /dev/null +++ b/user-contrib/Ltac2/tac2print.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Pp.t +val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> Pp.t +val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t + +(** {5 Printing expressions} *) + +val pr_constructor : ltac_constructor -> Pp.t +val pr_internal_constructor : type_constant -> int -> bool -> Pp.t +val pr_projection : ltac_projection -> Pp.t +val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t +val pr_glbexpr : glb_tacexpr -> Pp.t + +(** {5 Printing values}*) + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +val register_val_printer : type_constant -> val_printer -> unit + +val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp.t + +(** {5 Utilities} *) + +val int_name : unit -> (int -> string) +(** Create a function that give names to integers. The names are generated on + the fly, in the order they are encountered. *) diff --git a/user-contrib/Ltac2/tac2qexpr.mli b/user-contrib/Ltac2/tac2qexpr.mli new file mode 100644 index 0000000000..400ab1a092 --- /dev/null +++ b/user-contrib/Ltac2/tac2qexpr.mli @@ -0,0 +1,173 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0)) +| [e] -> e +| el -> + let len = List.length el in + CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) + +let of_int {loc;v=n} = + CAst.make ?loc @@ CTacAtm (AtmInt n) + +let of_option ?loc f opt = match opt with +| None -> constructor ?loc (coq_core "None") [] +| Some e -> constructor ?loc (coq_core "Some") [f e] + +let inj_wit ?loc wit x = + CAst.make ?loc @@ CTacExt (wit, x) + +let of_variable {loc;v=id} = + let qid = Libnames.qualid_of_ident ?loc id in + if Tac2env.is_constructor qid then + CErrors.user_err ?loc (str "Invalid identifier") + else CAst.make ?loc @@ CTacRef (RelId qid) + +let of_anti f = function +| QExpr x -> f x +| QAnti id -> of_variable id + +let of_ident {loc;v=id} = inj_wit ?loc wit_ident id + +let of_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc wit_constr c + +let of_open_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc wit_open_constr c + +let of_bool ?loc b = + let c = if b then coq_core "true" else coq_core "false" in + constructor ?loc c [] + +let rec of_list ?loc f = function +| [] -> constructor (coq_core "[]") [] +| e :: l -> + constructor ?loc (coq_core "::") [f e; of_list ?loc f l] + +let of_qhyp {loc;v=h} = match h with +| QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] +| QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] + +let of_bindings {loc;v=b} = match b with +| QNoBindings -> + std_constructor ?loc "NoBindings" [] +| QImplicitBindings tl -> + std_constructor ?loc "ImplicitBindings" [of_list ?loc of_open_constr tl] +| QExplicitBindings tl -> + let map e = of_pair (fun q -> of_anti of_qhyp q) of_open_constr e in + std_constructor ?loc "ExplicitBindings" [of_list ?loc map tl] + +let of_constr_with_bindings c = of_pair of_open_constr of_bindings c + +let rec of_intro_pattern {loc;v=pat} = match pat with +| QIntroForthcoming b -> + std_constructor ?loc "IntroForthcoming" [of_bool b] +| QIntroNaming iname -> + std_constructor ?loc "IntroNaming" [of_intro_pattern_naming iname] +| QIntroAction iact -> + std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] + +and of_intro_pattern_naming {loc;v=pat} = match pat with +| QIntroIdentifier id -> + std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] +| QIntroFresh id -> + std_constructor ?loc "IntroFresh" [of_anti of_ident id] +| QIntroAnonymous -> + std_constructor ?loc "IntroAnonymous" [] + +and of_intro_pattern_action {loc;v=pat} = match pat with +| QIntroWildcard -> + std_constructor ?loc "IntroWildcard" [] +| QIntroOrAndPattern pat -> + std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern pat] +| QIntroInjection il -> + std_constructor ?loc "IntroInjection" [of_intro_patterns il] +| QIntroRewrite b -> + std_constructor ?loc "IntroRewrite" [of_bool ?loc b] + +and of_or_and_intro_pattern {loc;v=pat} = match pat with +| QIntroOrPattern ill -> + std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] +| QIntroAndPattern il -> + std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] + +and of_intro_patterns {loc;v=l} = + of_list ?loc of_intro_pattern l + +let of_hyp_location_flag ?loc = function +| Locus.InHyp -> std_constructor ?loc "InHyp" [] +| Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] +| Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] + +let of_occurrences {loc;v=occ} = match occ with +| QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] +| QAllOccurrencesBut occs -> + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in + std_constructor ?loc "AllOccurrencesBut" [occs] +| QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] +| QOnlyOccurrences occs -> + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in + std_constructor ?loc "OnlyOccurrences" [occs] + +let of_hyp_location ?loc ((occs, id), flag) = + of_tuple ?loc [ + of_anti of_ident id; + of_occurrences occs; + of_hyp_location_flag ?loc flag; + ] + +let of_clause {loc;v=cl} = + let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in + let concl = of_occurrences cl.q_concl_occs in + CAst.make ?loc @@ CTacRec ([ + std_proj "on_hyps", hyps; + std_proj "on_concl", concl; + ]) + +let of_destruction_arg {loc;v=arg} = match arg with +| QElimOnConstr c -> + let arg = thunk (of_constr_with_bindings c) in + std_constructor ?loc "ElimOnConstr" [arg] +| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] +| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] + +let of_induction_clause {loc;v=cl} = + let arg = of_destruction_arg cl.indcl_arg in + let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in + let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in + let in_ = of_option ?loc of_clause cl.indcl_in in + CAst.make ?loc @@ CTacRec ([ + std_proj "indcl_arg", arg; + std_proj "indcl_eqn", eqn; + std_proj "indcl_as", as_; + std_proj "indcl_in", in_; + ]) + +let check_pattern_id ?loc id = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) + +let pattern_vars pat = + let rec aux () accu pat = match pat.CAst.v with + | Constrexpr.CPatVar id + | Constrexpr.CEvar (id, []) -> + let () = check_pattern_id ?loc:pat.CAst.loc id in + Id.Set.add id accu + | _ -> + Constrexpr_ops.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat + in + aux () Id.Set.empty pat + +let abstract_vars loc vars tac = + let get_name = function Name id -> Some id | Anonymous -> None in + let def = try Some (List.find_map get_name vars) with Not_found -> None in + let na, tac = match def with + | None -> (Anonymous, tac) + | Some id0 -> + (* Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) + let build_bindings (n, accu) na = match na with + | Anonymous -> (n + 1, accu) + | Name _ -> + let get = global_ref ?loc (kername array_prefix "get") in + let args = [of_variable CAst.(make ?loc id0); of_int CAst.(make ?loc n)] in + let e = CAst.make ?loc @@ CTacApp (get, args) in + let accu = (CAst.make ?loc @@ CPatVar na, e) :: accu in + (n + 1, accu) + in + let (_, bnd) = List.fold_left build_bindings (0, []) vars in + let tac = CAst.make ?loc @@ CTacLet (false, bnd, tac) in + (Name id0, tac) + in + CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], tac) + +let of_pattern p = + inj_wit ?loc:p.CAst.loc wit_pattern p + +let of_conversion {loc;v=c} = match c with +| QConvert c -> + let pat = of_option ?loc of_pattern None in + let c = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar Anonymous], of_constr c) in + of_tuple ?loc [pat; c] +| QConvertWith (pat, c) -> + let vars = pattern_vars pat in + let pat = of_option ?loc of_pattern (Some pat) in + let c = of_constr c in + (* Order is critical here *) + let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in + let c = abstract_vars loc vars c in + of_tuple [pat; c] + +let of_repeat {loc;v=r} = match r with +| QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] +| QUpTo n -> std_constructor ?loc "UpTo" [of_int n] +| QRepeatStar -> std_constructor ?loc "RepeatStar" [] +| QRepeatPlus -> std_constructor ?loc "RepeatPlus" [] + +let of_orient loc b = + if b then std_constructor ?loc "LTR" [] + else std_constructor ?loc "RTL" [] + +let of_rewriting {loc;v=rew} = + let orient = + let {loc;v=orient} = rew.rew_orient in + of_option ?loc (fun b -> of_orient loc b) orient + in + let repeat = of_repeat rew.rew_repeat in + let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in + CAst.make ?loc @@ CTacRec ([ + std_proj "rew_orient", orient; + std_proj "rew_repeat", repeat; + std_proj "rew_equatn", equatn; + ]) + +let of_hyp ?loc id = + let hyp = global_ref ?loc (control_core "hyp") in + CAst.make ?loc @@ CTacApp (hyp, [of_ident id]) + +let of_exact_hyp ?loc id = + let refine = global_ref ?loc (control_core "refine") in + CAst.make ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) + +let of_exact_var ?loc id = + let refine = global_ref ?loc (control_core "refine") in + CAst.make ?loc @@ CTacApp (refine, [thunk (of_variable id)]) + +let of_dispatch tacs = + let loc = tacs.loc in + let default = function + | Some e -> thunk e + | None -> thunk (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0))) + in + let map e = of_pair default (fun l -> of_list ?loc default l) (CAst.make ?loc e) in + of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs + +let make_red_flag l = + let open Genredexpr in + let rec add_flag red = function + | [] -> red + | {v=flag} :: lf -> + let red = match flag with + | QBeta -> { red with rBeta = true } + | QMatch -> { red with rMatch = true } + | QFix -> { red with rFix = true } + | QCofix -> { red with rCofix = true } + | QZeta -> { red with rZeta = true } + | QConst {loc;v=l} -> + if red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l } + | QDeltaBut {loc;v=l} -> + if red.rConst <> [] && not red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l; rDelta = true } + | QIota -> + { red with rMatch = true; rFix = true; rCofix = true } + in + add_flag red lf + in + add_flag + {rBeta = false; rMatch = false; rFix = false; rCofix = false; + rZeta = false; rDelta = false; rConst = []} + l + +let of_reference r = + let of_ref ref = + inj_wit ?loc:ref.loc wit_reference ref + in + of_anti of_ref r + +let of_strategy_flag {loc;v=flag} = + let open Genredexpr in + let flag = make_red_flag flag in + CAst.make ?loc @@ CTacRec ([ + std_proj "rBeta", of_bool ?loc flag.rBeta; + std_proj "rMatch", of_bool ?loc flag.rMatch; + std_proj "rFix", of_bool ?loc flag.rFix; + std_proj "rCofix", of_bool ?loc flag.rCofix; + std_proj "rZeta", of_bool ?loc flag.rZeta; + std_proj "rDelta", of_bool ?loc flag.rDelta; + std_proj "rConst", of_list ?loc of_reference flag.rConst; + ]) + +let of_hintdb {loc;v=hdb} = match hdb with +| QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None +| QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) + +let extract_name ?loc oid = match oid with +| None -> Anonymous +| Some id -> + let () = check_pattern_id ?loc id in + Name id + +(** For every branch in the matching, generate a corresponding term of type + [(match_kind * pattern * (context -> constr array -> 'a))] + where the function binds the names from the pattern to the contents of the + constr array. *) +let of_constr_matching {loc;v=m} = + let map {loc;v=({loc=ploc;v=pat}, tac)} = + let (knd, pat, na) = match pat with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (knd, pat, Anonymous) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (knd, pat, na) + in + let vars = pattern_vars pat in + (* Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let vars = List.map (fun id -> Name id) vars in + let e = abstract_vars loc vars tac in + let e = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], e) in + let pat = inj_wit ?loc:ploc wit_pattern pat in + of_tuple [knd; pat; e] + in + of_list ?loc map m + +(** From the patterns and the body of the branch, generate: + - a goal pattern: (constr_match list * constr_match) + - a branch function (ident array -> context array -> constr array -> context -> 'a) +*) +let of_goal_matching {loc;v=gm} = + let mk_pat {loc;v=p} = match p with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (Anonymous, pat, knd) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (na, pat, knd) + in + let mk_gpat {loc;v=p} = + let concl_pat = p.q_goal_match_concl in + let hyps_pats = p.q_goal_match_hyps in + let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in + let vars = pattern_vars concl_pat in + let map accu (na, pat) = + let (ctx, pat, knd) = mk_pat pat in + let vars = pattern_vars pat in + (Id.Set.union vars accu, (na, ctx, pat, knd)) + in + let (vars, hyps_pats) = List.fold_left_map map vars hyps_pats in + let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in + let concl = of_tuple [concl_knd; of_pattern concl_pat] in + let r = of_tuple [of_list ?loc map hyps_pats; concl] in + let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in + let map (_, na, _, _) = na in + let hctx = List.map map hyps_pats in + (* Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let subst = List.map (fun id -> Name id) vars in + (r, hyps, hctx, subst, concl_ctx) + in + let map {loc;v=(pat, tac)} = + let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in + let tac = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar cctx], tac) in + let tac = abstract_vars loc subst tac in + let tac = abstract_vars loc hctx tac in + let tac = abstract_vars loc hyps tac in + of_tuple ?loc [pat; tac] + in + of_list ?loc map gm + +let of_move_location {loc;v=mv} = match mv with +| QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] +| QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] +| QMoveFirst -> std_constructor ?loc "MoveFirst" [] +| QMoveLast -> std_constructor ?loc "MoveLast" [] + +let of_pose p = + of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p + +let of_assertion {loc;v=ast} = match ast with +| QAssertType (ipat, c, tac) -> + let ipat = of_option of_intro_pattern ipat in + let c = of_constr c in + let tac = of_option thunk tac in + std_constructor ?loc "AssertType" [ipat; c; tac] +| QAssertValue (id, c) -> + let id = of_anti of_ident id in + let c = of_constr c in + std_constructor ?loc "AssertValue" [id; c] diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli new file mode 100644 index 0000000000..1b03dad8ec --- /dev/null +++ b/user-contrib/Ltac2/tac2quote.mli @@ -0,0 +1,102 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ltac_constructor -> raw_tacexpr list -> raw_tacexpr + +val thunk : raw_tacexpr -> raw_tacexpr + +val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr + +val of_int : int CAst.t -> raw_tacexpr + +val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) CAst.t -> raw_tacexpr + +val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr + +val of_variable : Id.t CAst.t -> raw_tacexpr + +val of_ident : Id.t CAst.t -> raw_tacexpr + +val of_constr : Constrexpr.constr_expr -> raw_tacexpr + +val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr + +val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr + +val of_bindings : bindings -> raw_tacexpr + +val of_intro_pattern : intro_pattern -> raw_tacexpr + +val of_intro_patterns : intro_pattern list CAst.t -> raw_tacexpr + +val of_clause : clause -> raw_tacexpr + +val of_destruction_arg : destruction_arg -> raw_tacexpr + +val of_induction_clause : induction_clause -> raw_tacexpr + +val of_conversion : conversion -> raw_tacexpr + +val of_rewriting : rewriting -> raw_tacexpr + +val of_occurrences : occurrences -> raw_tacexpr + +val of_hintdb : hintdb -> raw_tacexpr + +val of_move_location : move_location -> raw_tacexpr + +val of_reference : reference or_anti -> raw_tacexpr + +val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.hyp @id' *) + +val of_exact_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_exact_var : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_dispatch : dispatch -> raw_tacexpr + +val of_strategy_flag : strategy_flag -> raw_tacexpr + +val of_pose : pose -> raw_tacexpr + +val of_assertion : assertion -> raw_tacexpr + +val of_constr_matching : constr_matching -> raw_tacexpr + +val of_goal_matching : goal_matching -> raw_tacexpr + +(** {5 Generic arguments} *) + +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag + +val wit_ident : (Id.t, Id.t) Arg.tag + +val wit_reference : (reference, GlobRef.t) Arg.tag + +val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) + +val wit_ltac1val : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a value-returning expression, with type Ltac1.t. *) diff --git a/user-contrib/Ltac2/tac2stdlib.ml b/user-contrib/Ltac2/tac2stdlib.ml new file mode 100644 index 0000000000..fb51fc965b --- /dev/null +++ b/user-contrib/Ltac2/tac2stdlib.ml @@ -0,0 +1,572 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* assert false) f + +let return x = Proofview.tclUNIT x +let v_unit = Value.of_unit () +let thaw r f = Tac2ffi.app_fun1 f unit r () +let uthaw r f = Tac2ffi.app_fun1 (to_fun1 unit r f) unit r () +let thunk r = fun1 unit r + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let name = make_to_repr to_name + +let to_occurrences = function +| ValInt 0 -> AllOccurrences +| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list Value.to_int vl) +| ValInt 1 -> NoOccurrences +| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) +| _ -> assert false + +let occurrences = make_to_repr to_occurrences + +let to_hyp_location_flag v = match Value.to_int v with +| 0 -> InHyp +| 1 -> InHypTypeOnly +| 2 -> InHypValueOnly +| _ -> assert false + +let to_clause v = match Value.to_tuple v with +| [| hyps; concl |] -> + let cast v = match Value.to_tuple v with + | [| hyp; occ; flag |] -> + (Value.to_ident hyp, to_occurrences occ, to_hyp_location_flag flag) + | _ -> assert false + in + let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in + { onhyps = hyps; concl_occs = to_occurrences concl; } +| _ -> assert false + +let clause = make_to_repr to_clause + +let to_red_flag v = match Value.to_tuple v with +| [| beta; iota; fix; cofix; zeta; delta; const |] -> + { + rBeta = Value.to_bool beta; + rMatch = Value.to_bool iota; + rFix = Value.to_bool fix; + rCofix = Value.to_bool cofix; + rZeta = Value.to_bool zeta; + rDelta = Value.to_bool delta; + rConst = Value.to_list Value.to_reference const; + } +| _ -> assert false + +let red_flags = make_to_repr to_red_flag + +let pattern_with_occs = pair pattern occurrences + +let constr_with_occs = pair constr occurrences + +let reference_with_occs = pair reference occurrences + +let rec to_intro_pattern v = match Value.to_block v with +| (0, [| b |]) -> IntroForthcoming (Value.to_bool b) +| (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) +| (2, [| act |]) -> IntroAction (to_intro_pattern_action act) +| _ -> assert false + +and to_intro_pattern_naming = function +| ValBlk (0, [| id |]) -> IntroIdentifier (Value.to_ident id) +| ValBlk (1, [| id |]) -> IntroFresh (Value.to_ident id) +| ValInt 0 -> IntroAnonymous +| _ -> assert false + +and to_intro_pattern_action = function +| ValInt 0 -> IntroWildcard +| ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) +| ValBlk (1, [| inj |]) -> + let map ipat = to_intro_pattern ipat in + IntroInjection (Value.to_list map inj) +| ValBlk (2, [| c; ipat |]) -> + let c = Value.to_fun1 Value.unit Value.constr c in + IntroApplyOn (c, to_intro_pattern ipat) +| ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) +| _ -> assert false + +and to_or_and_intro_pattern v = match Value.to_block v with +| (0, [| ill |]) -> + IntroOrPattern (Value.to_list to_intro_patterns ill) +| (1, [| il |]) -> + IntroAndPattern (to_intro_patterns il) +| _ -> assert false + +and to_intro_patterns il = + Value.to_list to_intro_pattern il + +let intro_pattern = make_to_repr to_intro_pattern + +let intro_patterns = make_to_repr to_intro_patterns + +let to_destruction_arg v = match Value.to_block v with +| (0, [| c |]) -> + let c = uthaw constr_with_bindings c in + ElimOnConstr c +| (1, [| id |]) -> ElimOnIdent (Value.to_ident id) +| (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) +| _ -> assert false + +let destruction_arg = make_to_repr to_destruction_arg + +let to_induction_clause v = match Value.to_tuple v with +| [| arg; eqn; as_; in_ |] -> + let arg = to_destruction_arg arg in + let eqn = Value.to_option to_intro_pattern_naming eqn in + let as_ = Value.to_option to_or_and_intro_pattern as_ in + let in_ = Value.to_option to_clause in_ in + (arg, eqn, as_, in_) +| _ -> + assert false + +let induction_clause = make_to_repr to_induction_clause + +let to_assertion v = match Value.to_block v with +| (0, [| ipat; t; tac |]) -> + let to_tac t = Value.to_fun1 Value.unit Value.unit t in + let ipat = Value.to_option to_intro_pattern ipat in + let t = Value.to_constr t in + let tac = Value.to_option to_tac tac in + AssertType (ipat, t, tac) +| (1, [| id; c |]) -> + AssertValue (Value.to_ident id, Value.to_constr c) +| _ -> assert false + +let assertion = make_to_repr to_assertion + +let to_multi = function +| ValBlk (0, [| n |]) -> Precisely (Value.to_int n) +| ValBlk (1, [| n |]) -> UpTo (Value.to_int n) +| ValInt 0 -> RepeatStar +| ValInt 1 -> RepeatPlus +| _ -> assert false + +let to_rewriting v = match Value.to_tuple v with +| [| orient; repeat; c |] -> + let orient = Value.to_option Value.to_bool orient in + let repeat = to_multi repeat in + let c = uthaw constr_with_bindings c in + (orient, repeat, c) +| _ -> assert false + +let rewriting = make_to_repr to_rewriting + +let to_debug v = match Value.to_int v with +| 0 -> Hints.Off +| 1 -> Hints.Info +| 2 -> Hints.Debug +| _ -> assert false + +let debug = make_to_repr to_debug + +let to_strategy v = match Value.to_int v with +| 0 -> Class_tactics.Bfs +| 1 -> Class_tactics.Dfs +| _ -> assert false + +let strategy = make_to_repr to_strategy + +let to_inversion_kind v = match Value.to_int v with +| 0 -> Inv.SimpleInversion +| 1 -> Inv.FullInversion +| 2 -> Inv.FullInversionClear +| _ -> assert false + +let inversion_kind = make_to_repr to_inversion_kind + +let to_move_location = function +| ValInt 0 -> Logic.MoveFirst +| ValInt 1 -> Logic.MoveLast +| ValBlk (0, [|id|]) -> Logic.MoveAfter (Value.to_ident id) +| ValBlk (1, [|id|]) -> Logic.MoveBefore (Value.to_ident id) +| _ -> assert false + +let move_location = make_to_repr to_move_location + +let to_generalize_arg v = match Value.to_tuple v with +| [| c; occs; na |] -> + (Value.to_constr c, to_occurrences occs, to_name na) +| _ -> assert false + +let generalize_arg = make_to_repr to_generalize_arg + +(** Standard tactics sharing their implementation with Ltac1 *) + +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let lift tac = tac <*> return v_unit + +let define_prim0 name tac = + let tac _ = lift tac in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_prim1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_prim2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) + +let define_prim3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) + +let define_prim4 name r0 r1 r2 r3 f = + let tac x y z u = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) + +let define_prim5 name r0 r1 r2 r3 r4 f = + let tac x y z u v = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u) (Value.repr_to r4 v)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) + +(** Tactics from Tacexpr *) + +let () = define_prim2 "tac_intros" bool intro_patterns begin fun ev ipat -> + Tac2tactics.intros_patterns ev ipat +end + +let () = define_prim4 "tac_apply" bool bool (list (thunk constr_with_bindings)) (option (pair ident (option intro_pattern))) begin fun adv ev cb ipat -> + Tac2tactics.apply adv ev cb ipat +end + +let () = define_prim3 "tac_elim" bool constr_with_bindings (option constr_with_bindings) begin fun ev c copt -> + Tac2tactics.elim ev c copt +end + +let () = define_prim2 "tac_case" bool constr_with_bindings begin fun ev c -> + Tac2tactics.general_case_analysis ev c +end + +let () = define_prim1 "tac_generalize" (list generalize_arg) begin fun cl -> + Tac2tactics.generalize cl +end + +let () = define_prim1 "tac_assert" assertion begin fun ast -> + Tac2tactics.assert_ ast +end + +let () = define_prim3 "tac_enough" constr (option (option (thunk unit))) (option intro_pattern) begin fun c tac ipat -> + let tac = Option.map (fun o -> Option.map (fun f -> thaw unit f) o) tac in + Tac2tactics.forward false tac ipat c +end + +let () = define_prim2 "tac_pose" name constr begin fun na c -> + Tactics.letin_tac None na c None Locusops.nowhere +end + +let () = define_prim3 "tac_set" bool (thunk (pair name constr)) clause begin fun ev p cl -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw (pair name constr) p >>= fun (na, c) -> + Tac2tactics.letin_pat_tac ev None na (sigma, c) cl +end + +let () = define_prim5 "tac_remember" bool name (thunk constr) (option intro_pattern) clause begin fun ev na c eqpat cl -> + let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in + match eqpat with + | IntroNaming eqpat -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw constr c >>= fun c -> + Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl + | _ -> + Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") +end + +let () = define_prim3 "tac_destruct" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> + Tac2tactics.induction_destruct false ev ic using +end + +let () = define_prim3 "tac_induction" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> + Tac2tactics.induction_destruct true ev ic using +end + +let () = define_prim1 "tac_red" clause begin fun cl -> + Tac2tactics.reduce (Red false) cl +end + +let () = define_prim1 "tac_hnf" clause begin fun cl -> + Tac2tactics.reduce Hnf cl +end + +let () = define_prim3 "tac_simpl" red_flags (option pattern_with_occs) clause begin fun flags where cl -> + Tac2tactics.simpl flags where cl +end + +let () = define_prim2 "tac_cbv" red_flags clause begin fun flags cl -> + Tac2tactics.cbv flags cl +end + +let () = define_prim2 "tac_cbn" red_flags clause begin fun flags cl -> + Tac2tactics.cbn flags cl +end + +let () = define_prim2 "tac_lazy" red_flags clause begin fun flags cl -> + Tac2tactics.lazy_ flags cl +end + +let () = define_prim2 "tac_unfold" (list reference_with_occs) clause begin fun refs cl -> + Tac2tactics.unfold refs cl +end + +let () = define_prim2 "tac_fold" (list constr) clause begin fun args cl -> + Tac2tactics.reduce (Fold args) cl +end + +let () = define_prim2 "tac_pattern" (list constr_with_occs) clause begin fun where cl -> + Tac2tactics.pattern where cl +end + +let () = define_prim2 "tac_vm" (option pattern_with_occs) clause begin fun where cl -> + Tac2tactics.vm where cl +end + +let () = define_prim2 "tac_native" (option pattern_with_occs) clause begin fun where cl -> + Tac2tactics.native where cl +end + +(** Reduction functions *) + +let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + +let define_red1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_red2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) + +let define_red3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) + +let () = define_red1 "eval_red" constr begin fun c -> + Tac2tactics.eval_red c +end + +let () = define_red1 "eval_hnf" constr begin fun c -> + Tac2tactics.eval_hnf c +end + +let () = define_red3 "eval_simpl" red_flags (option pattern_with_occs) constr begin fun flags where c -> + Tac2tactics.eval_simpl flags where c +end + +let () = define_red2 "eval_cbv" red_flags constr begin fun flags c -> + Tac2tactics.eval_cbv flags c +end + +let () = define_red2 "eval_cbn" red_flags constr begin fun flags c -> + Tac2tactics.eval_cbn flags c +end + +let () = define_red2 "eval_lazy" red_flags constr begin fun flags c -> + Tac2tactics.eval_lazy flags c +end + +let () = define_red2 "eval_unfold" (list reference_with_occs) constr begin fun refs c -> + Tac2tactics.eval_unfold refs c +end + +let () = define_red2 "eval_fold" (list constr) constr begin fun args c -> + Tac2tactics.eval_fold args c +end + +let () = define_red2 "eval_pattern" (list constr_with_occs) constr begin fun where c -> + Tac2tactics.eval_pattern where c +end + +let () = define_red2 "eval_vm" (option pattern_with_occs) constr begin fun where c -> + Tac2tactics.eval_vm where c +end + +let () = define_red2 "eval_native" (option pattern_with_occs) constr begin fun where c -> + Tac2tactics.eval_native where c +end + +let () = define_prim3 "tac_change" (option pattern) (fun1 (array constr) constr) clause begin fun pat c cl -> + Tac2tactics.change pat c cl +end + +let () = define_prim4 "tac_rewrite" bool (list rewriting) clause (option (thunk unit)) begin fun ev rw cl by -> + Tac2tactics.rewrite ev rw cl by +end + +let () = define_prim4 "tac_inversion" inversion_kind destruction_arg (option intro_pattern) (option (list ident)) begin fun knd arg pat ids -> + Tac2tactics.inversion knd arg pat ids +end + +(** Tactics from coretactics *) + +let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity + +let () = define_prim2 "tac_move" ident move_location begin fun id mv -> + Tactics.move_hyp id mv +end + +let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> + let mv = Option.default Logic.MoveLast mv in + Tactics.intro_move id mv +end + +(* + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + +*) + +let () = define_prim0 "tac_assumption" Tactics.assumption + +let () = define_prim1 "tac_transitivity" constr begin fun c -> + Tactics.intros_transitivity (Some c) +end + +let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) + +let () = define_prim1 "tac_cut" constr begin fun c -> + Tactics.cut c +end + +let () = define_prim2 "tac_left" bool bindings begin fun ev bnd -> + Tac2tactics.left_with_bindings ev bnd +end +let () = define_prim2 "tac_right" bool bindings begin fun ev bnd -> + Tac2tactics.right_with_bindings ev bnd +end + +let () = define_prim1 "tac_introsuntil" qhyp begin fun h -> + Tactics.intros_until h +end + +let () = define_prim1 "tac_exactnocheck" constr begin fun c -> + Tactics.exact_no_check c +end + +let () = define_prim1 "tac_vmcastnocheck" constr begin fun c -> + Tactics.vm_cast_no_check c +end + +let () = define_prim1 "tac_nativecastnocheck" constr begin fun c -> + Tactics.native_cast_no_check c +end + +let () = define_prim1 "tac_constructor" bool begin fun ev -> + Tactics.any_constructor ev None +end + +let () = define_prim3 "tac_constructorn" bool int bindings begin fun ev n bnd -> + Tac2tactics.constructor_tac ev None n bnd +end + +let () = define_prim2 "tac_specialize" constr_with_bindings (option intro_pattern) begin fun c ipat -> + Tac2tactics.specialize c ipat +end + +let () = define_prim1 "tac_symmetry" clause begin fun cl -> + Tac2tactics.symmetry cl +end + +let () = define_prim2 "tac_split" bool bindings begin fun ev bnd -> + Tac2tactics.split_with_bindings ev bnd +end + +let () = define_prim1 "tac_rename" (list (pair ident ident)) begin fun ids -> + Tactics.rename_hyp ids +end + +let () = define_prim1 "tac_revert" (list ident) begin fun ids -> + Tactics.revert ids +end + +let () = define_prim0 "tac_admit" Proofview.give_up + +let () = define_prim2 "tac_fix" ident int begin fun ident n -> + Tactics.fix ident n +end + +let () = define_prim1 "tac_cofix" ident begin fun ident -> + Tactics.cofix ident +end + +let () = define_prim1 "tac_clear" (list ident) begin fun ids -> + Tactics.clear ids +end + +let () = define_prim1 "tac_keep" (list ident) begin fun ids -> + Tactics.keep ids +end + +let () = define_prim1 "tac_clearbody" (list ident) begin fun ids -> + Tactics.clear_body ids +end + +(** Tactics from extratactics *) + +let () = define_prim2 "tac_discriminate" bool (option destruction_arg) begin fun ev arg -> + Tac2tactics.discriminate ev arg +end + +let () = define_prim3 "tac_injection" bool (option intro_patterns) (option destruction_arg) begin fun ev ipat arg -> + Tac2tactics.injection ev ipat arg +end + +let () = define_prim1 "tac_absurd" constr begin fun c -> + Contradiction.absurd c +end + +let () = define_prim1 "tac_contradiction" (option constr_with_bindings) begin fun c -> + Tac2tactics.contradiction c +end + +let () = define_prim4 "tac_autorewrite" bool (option (thunk unit)) (list ident) clause begin fun all by ids cl -> + Tac2tactics.autorewrite ~all by ids cl +end + +let () = define_prim1 "tac_subst" (list ident) begin fun ids -> + Equality.subst ids +end + +let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) + +(** Auto *) + +let () = define_prim3 "tac_trivial" debug (list (thunk constr)) (option (list ident)) begin fun dbg lems dbs -> + Tac2tactics.trivial dbg lems dbs +end + +let () = define_prim5 "tac_eauto" debug (option int) (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n p lems dbs -> + Tac2tactics.eauto dbg n p lems dbs +end + +let () = define_prim4 "tac_auto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> + Tac2tactics.auto dbg n lems dbs +end + +let () = define_prim4 "tac_newauto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> + Tac2tactics.new_auto dbg n lems dbs +end + +let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> + Tac2tactics.typeclasses_eauto str n dbs +end diff --git a/user-contrib/Ltac2/tac2stdlib.mli b/user-contrib/Ltac2/tac2stdlib.mli new file mode 100644 index 0000000000..927b57074d --- /dev/null +++ b/user-contrib/Ltac2/tac2stdlib.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tactypes.ImplicitBindings l +| ExplicitBindings l -> + let l = List.map CAst.make l in + Tactypes.ExplicitBindings l +| NoBindings -> Tactypes.NoBindings + +let mk_with_bindings (x, b) = (x, mk_bindings b) + +let rec mk_intro_pattern = function +| IntroForthcoming b -> CAst.make @@ Tactypes.IntroForthcoming b +| IntroNaming ipat -> CAst.make @@ Tactypes.IntroNaming (mk_intro_pattern_naming ipat) +| IntroAction ipat -> CAst.make @@ Tactypes.IntroAction (mk_intro_pattern_action ipat) + +and mk_intro_pattern_naming = function +| IntroIdentifier id -> Namegen.IntroIdentifier id +| IntroFresh id -> Namegen.IntroFresh id +| IntroAnonymous -> Namegen.IntroAnonymous + +and mk_intro_pattern_action = function +| IntroWildcard -> Tactypes.IntroWildcard +| IntroOrAndPattern ipat -> Tactypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) +| IntroInjection ipats -> Tactypes.IntroInjection (List.map mk_intro_pattern ipats) +| IntroApplyOn (c, ipat) -> + let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in + Tactypes.IntroApplyOn (c, mk_intro_pattern ipat) +| IntroRewrite b -> Tactypes.IntroRewrite b + +and mk_or_and_intro_pattern = function +| IntroOrPattern ipatss -> + Tactypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) +| IntroAndPattern ipats -> + Tactypes.IntroAndPattern (List.map mk_intro_pattern ipats) + +let mk_intro_patterns ipat = List.map mk_intro_pattern ipat + +let mk_occurrences f = function +| AllOccurrences -> Locus.AllOccurrences +| AllOccurrencesBut l -> Locus.AllOccurrencesBut (List.map f l) +| NoOccurrences -> Locus.NoOccurrences +| OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) + +let mk_occurrences_expr occ = + mk_occurrences (fun i -> Locus.ArgArg i) occ + +let mk_hyp_location (id, occs, h) = + ((mk_occurrences_expr occs, id), h) + +let mk_clause cl = { + Locus.onhyps = Option.map (fun l -> List.map mk_hyp_location l) cl.onhyps; + Locus.concl_occs = mk_occurrences_expr cl.concl_occs; +} + +let intros_patterns ev ipat = + let ipat = mk_intro_patterns ipat in + Tactics.intros_patterns ev ipat + +let apply adv ev cb cl = + let map c = + let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in + None, CAst.make (delayed_of_tactic c) + in + let cb = List.map map cb in + match cl with + | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb + | Some (id, cl) -> + let cl = Option.map mk_intro_pattern cl in + Tactics.apply_delayed_in adv ev id cb cl + +let mk_destruction_arg = function +| ElimOnConstr c -> + let c = c >>= fun c -> return (mk_with_bindings c) in + Tactics.ElimOnConstr (delayed_of_tactic c) +| ElimOnIdent id -> Tactics.ElimOnIdent CAst.(make id) +| ElimOnAnonHyp n -> Tactics.ElimOnAnonHyp n + +let mk_induction_clause (arg, eqn, as_, occ) = + let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in + let as_ = Option.map (fun ipat -> CAst.make @@ mk_or_and_intro_pattern ipat) as_ in + let occ = Option.map mk_clause occ in + ((None, mk_destruction_arg arg), (eqn, as_), occ) + +let induction_destruct isrec ev (ic : induction_clause list) using = + let ic = List.map mk_induction_clause ic in + let using = Option.map mk_with_bindings using in + Tactics.induction_destruct isrec ev (ic, using) + +let elim ev c copt = + let c = mk_with_bindings c in + let copt = Option.map mk_with_bindings copt in + Tactics.elim ev None c copt + +let generalize pl = + let mk_occ occs = mk_occurrences (fun i -> i) occs in + let pl = List.map (fun (c, occs, na) -> (mk_occ occs, c), na) pl in + Tactics.new_generalize_gen pl + +let general_case_analysis ev c = + let c = mk_with_bindings c in + Tactics.general_case_analysis ev None c + +let constructor_tac ev n i bnd = + let bnd = mk_bindings bnd in + Tactics.constructor_tac ev n i bnd + +let left_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.left_with_bindings ev bnd + +let right_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.right_with_bindings ev bnd + +let split_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.split_with_bindings ev [bnd] + +let specialize c pat = + let c = mk_with_bindings c in + let pat = Option.map mk_intro_pattern pat in + Tactics.specialize c pat + +let change pat c cl = + let open Tac2ffi in + Proofview.Goal.enter begin fun gl -> + let c subst env sigma = + let subst = Array.map_of_list snd (Id.Map.bindings subst) in + delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma + in + let cl = mk_clause cl in + Tactics.change pat c cl + end + +let rewrite ev rw cl by = + let map_rw (orient, repeat, c) = + let c = c >>= fun c -> return (mk_with_bindings c) in + (Option.default true orient, repeat, None, delayed_of_tactic c) + in + let rw = List.map map_rw rw in + let cl = mk_clause cl in + let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE (thaw Tac2ffi.unit tac), Equality.Naive) by in + Equality.general_multi_rewrite ev rw cl by + +let symmetry cl = + let cl = mk_clause cl in + Tactics.intros_symmetry cl + +let forward fst tac ipat c = + let ipat = Option.map mk_intro_pattern ipat in + Tactics.forward fst tac ipat c + +let assert_ = function +| AssertValue (id, c) -> + let ipat = CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id) in + Tactics.forward true None (Some ipat) c +| AssertType (ipat, c, tac) -> + let ipat = Option.map mk_intro_pattern ipat in + let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in + Tactics.forward true (Some tac) ipat c + +let letin_pat_tac ev ipat na c cl = + let ipat = Option.map (fun (b, ipat) -> (b, CAst.make @@ mk_intro_pattern_naming ipat)) ipat in + let cl = mk_clause cl in + Tactics.letin_pat_tac ev ipat na c cl + +(** Ltac interface treats differently global references than other term + arguments in reduction expressions. In Ltac1, this is done at parsing time. + Instead, we parse indifferently any pattern and dispatch when the tactic is + called. *) +let map_pattern_with_occs (pat, occ) = match pat with +| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) +| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| _ -> (mk_occurrences_expr occ, Inr pat) + +let get_evaluable_reference = function +| VarRef id -> Proofview.tclUNIT (EvalVarRef id) +| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| r -> + Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ + Nametab.pr_global_env Id.Set.empty r ++ spc () ++ + str "to an evaluable reference.") + +let reduce r cl = + let cl = mk_clause cl in + Tactics.reduce r cl + +let simpl flags where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Simpl (flags, where)) cl + +let cbv flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbv flags) cl + +let cbn flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbn flags) cl + +let lazy_ flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Lazy flags) cl + +let unfold occs cl = + let cl = mk_clause cl in + let map (gr, occ) = + let occ = mk_occurrences_expr occ in + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + Tactics.reduce (Unfold occs) cl + +let pattern where cl = + let where = List.map (fun (c, occ) -> (mk_occurrences_expr occ, c)) where in + let cl = mk_clause cl in + Tactics.reduce (Pattern where) cl + +let vm where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Tactics.reduce (CbvVm where) cl + +let native where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Tactics.reduce (CbvNative where) cl + +let eval_fun red c = + Tac2core.pf_apply begin fun env sigma -> + let (redfun, _) = Redexpr.reduction_of_red_expr env red in + let (sigma, ans) = redfun env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT ans + end + +let eval_red c = + eval_fun (Red false) c + +let eval_hnf c = + eval_fun Hnf c + +let eval_simpl flags where c = + let where = Option.map map_pattern_with_occs where in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Simpl (flags, where)) c + +let eval_cbv flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbv flags) c + +let eval_cbn flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbn flags) c + +let eval_lazy flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Lazy flags) c + +let eval_unfold occs c = + let map (gr, occ) = + let occ = mk_occurrences_expr occ in + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + eval_fun (Unfold occs) c + +let eval_fold cl c = + eval_fun (Fold cl) c + +let eval_pattern where c = + let where = List.map (fun (pat, occ) -> (mk_occurrences_expr occ, pat)) where in + eval_fun (Pattern where) c + +let eval_vm where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvVm where) c + +let eval_native where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvNative where) c + +let on_destruction_arg tac ev arg = + Proofview.Goal.enter begin fun gl -> + match arg with + | None -> tac ev None + | Some (clear, arg) -> + let arg = match arg with + | ElimOnConstr c -> + let env = Proofview.Goal.env gl in + Proofview.tclEVARMAP >>= fun sigma -> + c >>= fun (c, lbind) -> + let lbind = mk_bindings lbind in + Proofview.tclEVARMAP >>= fun sigma' -> + let flags = tactic_infer_flags ev in + let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in + Proofview.tclUNIT (Some sigma', Tactics.ElimOnConstr (c, lbind)) + | ElimOnIdent id -> Proofview.tclUNIT (None, Tactics.ElimOnIdent CAst.(make id)) + | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Tactics.ElimOnAnonHyp n) + in + arg >>= fun (sigma', arg) -> + let arg = Some (clear, arg) in + match sigma' with + | None -> tac ev arg + | Some sigma' -> + Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' + end + +let discriminate ev arg = + let arg = Option.map (fun arg -> None, arg) arg in + on_destruction_arg Equality.discr_tac ev arg + +let injection ev ipat arg = + let arg = Option.map (fun arg -> None, arg) arg in + let ipat = Option.map mk_intro_patterns ipat in + let tac ev arg = Equality.injClause None ipat ev arg in + on_destruction_arg tac ev arg + +let autorewrite ~all by ids cl = + let conds = if all then Some Equality.AllMatches else None in + let ids = List.map Id.to_string ids in + let cl = mk_clause cl in + match by with + | None -> Autorewrite.auto_multi_rewrite ?conds ids cl + | Some by -> + let by = thaw Tac2ffi.unit by in + Autorewrite.auto_multi_rewrite_with ?conds by ids cl + +(** Auto *) + +let trivial debug lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_trivial ~debug lems dbs + +let auto debug n lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_auto ~debug n lems dbs + +let new_auto debug n lems dbs = + let make_depth n = snd (Eauto.make_dimension n None) in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + match dbs with + | None -> Auto.new_full_auto ~debug (make_depth n) lems + | Some dbs -> + let dbs = List.map Id.to_string dbs in + Auto.new_auto ~debug (make_depth n) lems dbs + +let eauto debug n p lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs + +let typeclasses_eauto strategy depth dbs = + let only_classes, dbs = match dbs with + | None -> + true, [Class_tactics.typeclasses_db] + | Some dbs -> + let dbs = List.map Id.to_string dbs in + false, dbs + in + Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs + +(** Inversion *) + +let inversion knd arg pat ids = + let ids = match ids with + | None -> [] + | Some l -> l + in + begin match pat with + | None -> Proofview.tclUNIT None + | Some (IntroAction (IntroOrAndPattern p)) -> + Proofview.tclUNIT (Some (CAst.make @@ mk_or_and_intro_pattern p)) + | Some _ -> + Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") + end >>= fun pat -> + let inversion _ arg = + begin match arg with + | None -> assert false + | Some (_, Tactics.ElimOnAnonHyp n) -> + Inv.inv_clause knd pat ids (AnonHyp n) + | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> + Inv.inv_clause knd pat ids (NamedHyp id) + | Some (_, Tactics.ElimOnConstr c) -> + let open Tactypes in + let anon = CAst.make @@ IntroNaming Namegen.IntroAnonymous in + Tactics.specialize c (Some anon) >>= fun () -> + Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) + end + in + on_destruction_arg inversion true (Some (None, arg)) + +let contradiction c = + let c = Option.map mk_with_bindings c in + Contradiction.contradiction c diff --git a/user-contrib/Ltac2/tac2tactics.mli b/user-contrib/Ltac2/tac2tactics.mli new file mode 100644 index 0000000000..e56544cd68 --- /dev/null +++ b/user-contrib/Ltac2/tac2tactics.mli @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* intro_pattern list -> unit tactic + +val apply : advanced_flag -> evars_flag -> + constr_with_bindings thunk list -> + (Id.t * intro_pattern option) option -> unit tactic + +val induction_destruct : rec_flag -> evars_flag -> + induction_clause list -> constr_with_bindings option -> unit tactic + +val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> + unit tactic + +val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic + +val generalize : (constr * occurrences * Name.t) list -> unit tactic + +val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic + +val left_with_bindings : evars_flag -> bindings -> unit tactic +val right_with_bindings : evars_flag -> bindings -> unit tactic +val split_with_bindings : evars_flag -> bindings -> unit tactic + +val specialize : constr_with_bindings -> intro_pattern option -> unit tactic + +val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic + +val rewrite : + evars_flag -> rewriting list -> clause -> unit thunk option -> unit tactic + +val symmetry : clause -> unit tactic + +val forward : bool -> unit tactic option option -> + intro_pattern option -> constr -> unit tactic + +val assert_ : assertion -> unit tactic + +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> + Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic + +val reduce : Redexpr.red_expr -> clause -> unit tactic + +val simpl : GlobRef.t glob_red_flag -> + (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val cbv : GlobRef.t glob_red_flag -> clause -> unit tactic + +val cbn : GlobRef.t glob_red_flag -> clause -> unit tactic + +val lazy_ : GlobRef.t glob_red_flag -> clause -> unit tactic + +val unfold : (GlobRef.t * occurrences) list -> clause -> unit tactic + +val pattern : (constr * occurrences) list -> clause -> unit tactic + +val vm : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val native : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val eval_red : constr -> constr tactic + +val eval_hnf : constr -> constr tactic + +val eval_simpl : GlobRef.t glob_red_flag -> + (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val eval_cbv : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_cbn : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_lazy : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_unfold : (GlobRef.t * occurrences) list -> constr -> constr tactic + +val eval_fold : constr list -> constr -> constr tactic + +val eval_pattern : (EConstr.t * occurrences) list -> constr -> constr tactic + +val eval_vm : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val eval_native : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val discriminate : evars_flag -> destruction_arg option -> unit tactic + +val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic + +val autorewrite : all:bool -> unit thunk option -> Id.t list -> clause -> unit tactic + +val trivial : Hints.debug -> constr thunk list -> Id.t list option -> + unit Proofview.tactic + +val auto : Hints.debug -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val new_auto : Hints.debug -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val eauto : Hints.debug -> int option -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> + Id.t list option -> unit Proofview.tactic + +val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic + +val contradiction : constr_with_bindings option -> unit tactic diff --git a/user-contrib/Ltac2/tac2types.mli b/user-contrib/Ltac2/tac2types.mli new file mode 100644 index 0000000000..fa31153a27 --- /dev/null +++ b/user-contrib/Ltac2/tac2types.mli @@ -0,0 +1,92 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* -**Table of Contents** - -- [Summary](#summary) -- [Contents](#contents) -- [General design](#general-design) -- [ML component](#ml-component) - - [Overview](#overview) - - [Type Syntax](#type-syntax) - - [Type declarations](#type-declarations) - - [Term Syntax](#term-syntax) - - [Ltac Definitions](#ltac-definitions) - - [Reduction](#reduction) - - [Typing](#typing) - - [Effects](#effects) - - [Standard IO](#standard-io) - - [Fatal errors](#fatal-errors) - - [Backtrack](#backtrack) - - [Goals](#goals) -- [Meta-programming](#meta-programming) - - [Overview](#overview-1) - - [Generic Syntax for Quotations](#generic-syntax-for-quotations) - - [Built-in quotations](#built-in-quotations) - - [Strict vs. non-strict mode](#strict-vs-non-strict-mode) - - [Term Antiquotations](#term-antiquotations) - - [Syntax](#syntax) - - [Semantics](#semantics) - - [Static semantics](#static-semantics) - - [Dynamic semantics](#dynamic-semantics) - - [Trivial Term Antiquotations](#trivial-term-antiquotations) - - [Match over terms](#match-over-terms) - - [Match over goals](#match-over-goals) -- [Notations](#notations) - - [Scopes](#scopes) - - [Notations](#notations-1) - - [Abbreviations](#abbreviations) -- [Evaluation](#evaluation) -- [Debug](#debug) -- [Compatibility layer with Ltac1](#compatibility-layer-with-ltac1) - - [Ltac1 from Ltac2](#ltac1-from-ltac2) - - [Ltac2 from Ltac1](#ltac2-from-ltac1) -- [Transition from Ltac1](#transition-from-ltac1) - - [Syntax changes](#syntax-changes) - - [Tactic delay](#tactic-delay) - - [Variable binding](#variable-binding) - - [In Ltac expressions](#in-ltac-expressions) - - [In quotations](#in-quotations) - - [Exception catching](#exception-catching) -- [TODO](#todo) - - - - -# General design - -There are various alternatives to Ltac1, such that Mtac or Rtac for instance. -While those alternatives can be quite distinct from Ltac1, we designed -Ltac2 to be closest as reasonably possible to Ltac1, while fixing the -aforementioned defects. - -In particular, Ltac2 is: -- a member of the ML family of languages, i.e. - * a call-by-value functional language - * with effects - * together with Hindley-Milner type system -- a language featuring meta-programming facilities for the manipulation of - Coq-side terms -- a language featuring notation facilities to help writing palatable scripts - -We describe more in details each point in the remainder of this document. - -# ML component - -## Overview - -Ltac2 is a member of the ML family of languages, in the sense that it is an -effectful call-by-value functional language, with static typing à la -Hindley-Milner. It is commonly accepted that ML constitutes a sweet spot in PL -design, as it is relatively expressive while not being either too lax -(contrarily to dynamic typing) nor too strict (contrarily to say, dependent -types). - -The main goal of Ltac2 is to serve as a meta-language for Coq. As such, it -naturally fits in the ML lineage, just as the historical ML was designed as -the tactic language for the LCF prover. It can also be seen as a general-purpose -language, by simply forgetting about the Coq-specific features. - -Sticking to a standard ML type system can be considered somewhat weak for a -meta-language designed to manipulate Coq terms. In particular, there is no -way to statically guarantee that a Coq term resulting from an Ltac2 -computation will be well-typed. This is actually a design choice, motivated -by retro-compatibility with Ltac1. Instead, well-typedness is deferred to -dynamic checks, allowing many primitive functions to fail whenever they are -provided with an ill-typed term. - -The language is naturally effectful as it manipulates the global state of the -proof engine. This allows to think of proof-modifying primitives as effects -in a straightforward way. Semantically, proof manipulation lives in a monad, -which allows to ensure that Ltac2 satisfies the same equations as a generic ML -with unspecified effects would do, e.g. function reduction is substitution -by a value. - -## Type Syntax - -At the level of terms, we simply elaborate on Ltac1 syntax, which is quite -close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. - -``` -TYPE := -| "(" TYPE₀ "," ... "," TYPEₙ ")" TYPECONST -| "(" TYPE₀ "*" ... "*" TYPEₙ ")" -| TYPE₁ "->" TYPE₂ -| TYPEVAR - -TYPECONST := ( MODPATH "." )* LIDENT - -TYPEVAR := "'" LIDENT - -TYPEPARAMS := "(" TYPEVAR₀ "," ... "," TYPEVARₙ ")" -``` - -The set of base types can be extended thanks to the usual ML type -declarations such as algebraic datatypes and records. - -Built-in types include: -- `int`, machine integers (size not specified, in practice inherited from OCaml) -- `string`, mutable strings -- `'a array`, mutable arrays -- `exn`, exceptions -- `constr`, kernel-side terms -- `pattern`, term patterns -- `ident`, well-formed identifiers - -## Type declarations - -One can define new types by the following commands. - -``` -VERNAC ::= -| "Ltac2" "Type" TYPEPARAMS LIDENT -| "Ltac2" "Type" RECFLAG TYPEPARAMS LIDENT ":=" TYPEDEF - -RECFLAG := ( "rec" ) -``` - -The first command defines an abstract type. It has no use for the end user and -is dedicated to types representing data coming from the OCaml world. - -The second command defines a type with a manifest. There are four possible -kinds of such definitions: alias, variant, record and open variant types. - -``` -TYPEDEF := -| TYPE -| "[" CONSTRUCTORDEF₀ "|" ... "|" CONSTRUCTORDEFₙ "]" -| "{" FIELDDEF₀ ";" ... ";" FIELDDEFₙ "}" -| "[" ".." "]" - -CONSTRUCTORDEF := -| IDENT ( "(" TYPE₀ "," ... "," TYPE₀ ")" ) - -FIELDDEF := -| MUTFLAG IDENT ":" TYPE - -MUTFLAG := ( "mutable" ) -``` - -Aliases are just a name for a given type expression and are transparently -unfoldable to it. They cannot be recursive. - -Variants are sum types defined by constructors and eliminated by -pattern-matching. They can be recursive, but the `RECFLAG` must be explicitly -set. Pattern-maching must be exhaustive. - -Records are product types with named fields and eliminated by projection. -Likewise they can be recursive if the `RECFLAG` is set. - -Open variants are a special kind of variant types whose constructors are not -statically defined, but can instead be extended dynamically. A typical example -is the standard `exn` type. Pattern-matching must always include a catch-all -clause. They can be extended by the following command. - -``` -VERNAC ::= -| "Ltac2" "Type" TYPEPARAMS QUALID ":=" "[" CONSTRUCTORDEF "]" -``` - -## Term Syntax - -The syntax of the functional fragment is very close to the one of Ltac1, except -that it adds a true pattern-matching feature, as well as a few standard -constructions from ML. - -``` -VAR := LIDENT - -QUALID := ( MODPATH "." )* LIDENT - -CONSTRUCTOR := UIDENT - -TERM := -| QUALID -| CONSTRUCTOR TERM₀ ... TERMₙ -| TERM TERM₀ ... TERMₙ -| "fun" VAR "=>" TERM -| "let" VAR ":=" TERM "in" TERM -| "let" "rec" VAR ":=" TERM "in" TERM -| "match" TERM "with" BRANCH* "end" -| INT -| STRING -| "[|" TERM₀ ";" ... ";" TERMₙ "|]" -| "(" TERM₀ "," ... "," TERMₙ ")" -| "{" FIELD+ "}" -| TERM "." "(" QUALID ")" -| TERM₁ "." "(" QUALID ")" ":=" TERM₂ -| "["; TERM₀ ";" ... ";" TERMₙ "]" -| TERM₁ "::" TERM₂ -| ... - -BRANCH := -| PATTERN "=>" TERM - -PATTERN := -| VAR -| "_" -| "(" PATTERN₀ "," ... "," PATTERNₙ ")" -| CONSTRUCTOR PATTERN₀ ... PATTERNₙ -| "[" "]" -| PATTERN₁ "::" PATTERN₂ - -FIELD := -| QUALID ":=" TERM - -``` - -In practice, there is some additional syntactic sugar that allows e.g. to -bind a variable and match on it at the same time, in the usual ML style. - -There is a dedicated syntax for list and array litterals. - -Limitations: for now, deep pattern matching is not implemented yet. - -## Ltac Definitions - -One can define a new global Ltac2 value using the following syntax. -``` -VERNAC ::= -| "Ltac2" MUTFLAG RECFLAG LIDENT ":=" TERM -``` - -For semantic reasons, the body of the Ltac2 definition must be a syntactical -value, i.e. a function, a constant or a pure constructor recursively applied to -values. - -If the `RECFLAG` is set, the tactic is expanded into a recursive binding. - -If the `MUTFLAG` is set, the definition can be redefined at a later stage. This -can be performed through the following command. - -``` -VERNAC ::= -| "Ltac2" "Set" QUALID ":=" TERM -``` - -Mutable definitions act like dynamic binding, i.e. at runtime, the last defined -value for this entry is chosen. This is useful for global flags and the like. - -## Reduction - -We use the usual ML call-by-value reduction, with an otherwise unspecified -evaluation order. This is a design choice making it compatible with OCaml, -if ever we implement native compilation. The expected equations are as follows. -``` -(fun x => t) V ≡ t{x := V} (βv) - -let x := V in t ≡ t{x := V} (let) - -match C V₀ ... Vₙ with ... | C x₀ ... xₙ => t | ... end ≡ t {xᵢ := Vᵢ} (ι) - -(t any term, V values, C constructor) -``` - -Note that call-by-value reduction is already a departure from Ltac1 which uses -heuristics to decide when evaluating an expression. For instance, the following -expressions do not evaluate the same way in Ltac1. - -``` -foo (idtac; let x := 0 in bar) - -foo (let x := 0 in bar) -``` - -Instead of relying on the `idtac` hack, we would now require an explicit thunk -not to compute the argument, and `foo` would have e.g. type -`(unit -> unit) -> unit`. - -``` -foo (fun () => let x := 0 in bar) -``` - -## Typing - -Typing is strict and follows Hindley-Milner system. We will not implement the -current hackish subtyping semantics, and one will have to resort to conversion -functions. See notations though to make things more palatable. - -In this setting, all usual argument-free tactics have type `unit -> unit`, but -one can return as well a value of type `t` thanks to terms of type `unit -> t`, -or take additional arguments. - -## Effects - -Regarding effects, nothing involved here, except that instead of using the -standard IO monad as the ambient effectful world, Ltac2 is going to use the -tactic monad. - -Note that the order of evaluation of application is *not* specified and is -implementation-dependent, as in OCaml. - -We recall that the `Proofview.tactic` monad is essentially a IO monad together -with backtracking state representing the proof state. - -Intuitively a thunk of type `unit -> 'a` can do the following: -- It can perform non-backtracking IO like printing and setting mutable variables -- It can fail in a non-recoverable way -- It can use first-class backtrack. The proper way to figure that is that we - morally have the following isomorphism: - `(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a - lazy list of results where each tail is waiting for a continuation exception. -- It can access a backtracking proof state, made out amongst other things of - the current evar assignation and the list of goals under focus. - -We describe more thoroughly the various effects existing in Ltac2 hereafter. - -### Standard IO - -The Ltac2 language features non-backtracking IO, notably mutable data and -printing operations. - -Mutable fields of records can be modified using the set syntax. Likewise, -built-in types like `string` and `array` feature imperative assignment. See -modules `String` and `Array` respectively. - -A few printing primitives are provided in the `Message` module, allowing to -display information to the user. - -### Fatal errors - -The Ltac2 language provides non-backtracking exceptions through the -following primitive in module `Control`. - -``` -val throw : exn -> 'a -``` - -Contrarily to backtracking exceptions from the next section, this kind of error -is never caught by backtracking primitives, that is, throwing an exception -destroys the stack. This is materialized by the following equation, where `E` -is an evaluation context. - -``` -E[throw e] ≡ throw e - -(e value) -``` - -There is currently no way to catch such an exception and it is a design choice. -There might be at some future point a way to catch it in a brutal way, -destroying all backtrack and return values. - -### Backtrack - -In Ltac2, we have the following backtracking primitives, defined in the -`Control` module. - -``` -Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. - -val zero : exn -> 'a -val plus : (unit -> 'a) -> (exn -> 'a) -> 'a -val case : (unit -> 'a) -> ('a * (exn -> 'a)) result -``` - -If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is -list concatenation, while `case` is pattern-matching. - -The backtracking is first-class, i.e. one can write -`plus (fun () => "x") (fun _ => "y") : string` producing a backtracking string. - -These operations are expected to satisfy a few equations, most notably that they -form a monoid compatible with sequentialization. - -``` -plus t zero ≡ t () -plus (fun () => zero e) f ≡ f e -plus (plus t f) g ≡ plus t (fun e => plus (f e) g) - -case (fun () => zero e) ≡ Err e -case (fun () => plus (fun () => t) f) ≡ Val t f - -let x := zero e in u ≡ zero e -let x := plus t f in u ≡ plus (fun () => let x := t in u) (fun e => let x := f e in u) - -(t, u, f, g, e values) -``` - -### Goals - -A goal is given by the data of its conclusion and hypotheses, i.e. it can be -represented as `[Γ ⊢ A]`. - -The tactic monad naturally operates over the whole proofview, which may -represent several goals, including none. Thus, there is no such thing as -*the current goal*. Goals are naturally ordered, though. - -It is natural to do the same in Ltac2, but we must provide a way to get access -to a given goal. This is the role of the `enter` primitive, that applies a -tactic to each currently focused goal in turn. - -``` -val enter : (unit -> unit) -> unit -``` - -It is guaranteed that when evaluating `enter f`, `f` is called with exactly one -goal under focus. Note that `f` may be called several times, or never, depending -on the number of goals under focus before the call to `enter`. - -Accessing the goal data is then implicit in the Ltac2 primitives, and may panic -if the invariants are not respected. The two essential functions for observing -goals are given below. - -``` -val hyp : ident -> constr -val goal : unit -> constr -``` - -The two above functions panic if there is not exactly one goal under focus. -In addition, `hyp` may also fail if there is no hypothesis with the -corresponding name. - -# Meta-programming - -## Overview - -One of the horrendous implementation issues of Ltac is the fact that it is -never clear whether an object refers to the object world or the meta-world. -This is an incredible source of slowness, as the interpretation must be -aware of bound variables and must use heuristics to decide whether a variable -is a proper one or referring to something in the Ltac context. - -Likewise, in Ltac1, constr parsing is implicit, so that `foo 0` is -not `foo` applied to the Ltac integer expression `0` (Ltac does have a -non-first-class notion of integers), but rather the Coq term `Datatypes.O`. - -We should stop doing that! We need to mark when quoting and unquoting, although -we need to do that in a short and elegant way so as not to be too cumbersome -to the user. - -## Generic Syntax for Quotations - -In general, quotations can be introduced in term by the following syntax, where -`QUOTENTRY` is some parsing entry. -``` -TERM ::= -| QUOTNAME ":" "(" QUOTENTRY ")" - -QUOTNAME := IDENT -``` - -### Built-in quotations - -The current implementation recognizes the following built-in quotations: -- "ident", which parses identifiers (type `Init.ident`). -- "constr", which parses Coq terms and produces an-evar free term at runtime - (type `Init.constr`). -- "open_constr", which parses Coq terms and produces a term potentially with - holes at runtime (type `Init.constr` as well). -- "pattern", which parses Coq patterns and produces a pattern used for term - matching (type `Init.pattern`). -- "reference", which parses either a `QUALID` or `"&" IDENT`. Qualified names - are globalized at internalization into the corresponding global reference, - while `&id` is turned into `Std.VarRef id`. This produces at runtime a - `Std.reference`. - -The following syntactic sugar is provided for two common cases. -- `@id` is the same as ident:(id) -- `'t` is the same as open_constr:(t) - -### Strict vs. non-strict mode - -Depending on the context, quotations producing terms (i.e. `constr` or -`open_constr`) are not internalized in the same way. There are two possible -modes, respectively called the *strict* and the *non-strict* mode. - -- In strict mode, all simple identifiers appearing in a term quotation are -required to be resolvable statically. That is, they must be the short name of -a declaration which is defined globally, excluding section variables and -hypotheses. If this doesn't hold, internalization will fail. To work around -this error, one has to specifically use the `&` notation. -- In non-strict mode, any simple identifier appearing in a term quotation which -is not bound in the global context is turned into a dynamic reference to a -hypothesis. That is to say, internalization will succeed, but the evaluation -of the term at runtime will fail if there is no such variable in the dynamic -context. - -Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict -mode is only set when evaluating Ltac2 snippets in interactive proof mode. The -rationale is that it is cumbersome to explicitly add `&` interactively, while it -is expected that global tactics enforce more invariants on their code. - -## Term Antiquotations - -### Syntax - -One can also insert Ltac2 code into Coq term, similarly to what was possible in -Ltac1. - -``` -COQCONSTR ::= -| "ltac2" ":" "(" TERM ")" -``` - -Antiquoted terms are expected to have type `unit`, as they are only evaluated -for their side-effects. - -### Semantics - -Interpretation of a quoted Coq term is done in two phases, internalization and -evaluation. - -- Internalization is part of the static semantics, i.e. it is done at Ltac2 - typing time. -- Evaluation is part of the dynamic semantics, i.e. it is done when - a term gets effectively computed by Ltac2. - -Remark that typing of Coq terms is a *dynamic* process occuring at Ltac2 -evaluation time, and not at Ltac2 typing time. - -#### Static semantics - -During internalization, Coq variables are resolved and antiquotations are -type-checked as Ltac2 terms, effectively producing a `glob_constr` in Coq -implementation terminology. Note that although it went through the -type-checking of **Ltac2**, the resulting term has not been fully computed and -is potentially ill-typed as a runtime **Coq** term. - -``` -Ltac2 Definition myconstr () := constr:(nat -> 0). -// Valid with type `unit -> constr`, but will fail at runtime. -``` - -Term antiquotations are type-checked in the enclosing Ltac2 typing context -of the corresponding term expression. For instance, the following will -type-check. - -``` -let x := '0 in constr:(1 + ltac2:(exact x)) -// type constr -``` - -Beware that the typing environment of typing of antiquotations is **not** -expanded by the Coq binders from the term. Namely, it means that the following -Ltac2 expression will **not** type-check. -``` -constr:(fun x : nat => ltac2:(exact x)) -// Error: Unbound variable 'x' -``` - -There is a simple reason for that, which is that the following expression would -not make sense in general. -``` -constr:(fun x : nat => ltac2:(clear @x; exact x)) -``` -Indeed, a hypothesis can suddenly disappear from the runtime context if some -other tactic pulls the rug from under you. - -Rather, the tactic writer has to resort to the **dynamic** goal environment, -and must write instead explicitly that she is accessing a hypothesis, typically -as follows. -``` -constr:(fun x : nat => ltac2:(exact (hyp @x))) -``` - -This pattern is so common that we provide dedicated Ltac2 and Coq term notations -for it. - -- `&x` as an Ltac2 expression expands to `hyp @x`. -- `&x` as a Coq constr expression expands to - `ltac2:(Control.refine (fun () => hyp @x))`. - -#### Dynamic semantics - -During evaluation, a quoted term is fully evaluated to a kernel term, and is -in particular type-checked in the current environment. - -Evaluation of a quoted term goes as follows. -- The quoted term is first evaluated by the pretyper. -- Antiquotations are then evaluated in a context where there is exactly one goal -under focus, with the hypotheses coming from the current environment extended -with the bound variables of the term, and the resulting term is fed into the -quoted term. - -Relative orders of evaluation of antiquotations and quoted term are not -specified. - -For instance, in the following example, `tac` will be evaluated in a context -with exactly one goal under focus, whose last hypothesis is `H : nat`. The -whole expression will thus evaluate to the term `fun H : nat => nat`. -``` -let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ())) -``` - -Many standard tactics perform type-checking of their argument before going -further. It is your duty to ensure that terms are well-typed when calling -such tactics. Failure to do so will result in non-recoverable exceptions. - -## Trivial Term Antiquotations - -It is possible to refer to a variable of type `constr` in the Ltac2 environment -through a specific syntax consistent with the antiquotations presented in -the notation section. - -``` -COQCONSTR ::= -| "$" LIDENT -``` - -In a Coq term, writing `$x` is semantically equivalent to -`ltac2:(Control.refine (fun () => x))`, up to re-typechecking. It allows to -insert in a concise way an Ltac2 variable of type `constr` into a Coq term. - -## Match over terms - -Ltac2 features a construction similar to Ltac1 `match` over terms, although -in a less hard-wired way. - -``` -TERM ::= -| "match!" TERM "with" CONSTR-MATCHING* "end" -| "lazy_match!" TERM "with" CONSTR-MATCHING* "end" -| "multi_match!" TERM "with" CONSTR-MATCHING*"end" - -CONSTR-MATCHING := -| "|" CONSTR-PATTERN "=>" TERM - -CONSTR-PATTERN := -| CONSTR -| "context" LIDENT? "[" CONSTR "]" -``` - -This construction is not primitive and is desugared at parsing time into -calls to term matching functions from the `Pattern` module. Internally, it is -implemented thanks to a specific scope accepting the `CONSTR-MATCHING` syntax. - -Variables from the `CONSTR-PATTERN` are statically bound in the body of the branch, to -values of type `constr` for the variables from the `CONSTR` pattern and to a -value of type `Pattern.context` for the variable `LIDENT`. - -Note that contrarily to Ltac, only lowercase identifiers are valid as Ltac2 -bindings, so that there will be a syntax error if one of the bound variables -starts with an uppercase character. - -The semantics of this construction is otherwise the same as the corresponding -one from Ltac1, except that it requires the goal to be focused. - -## Match over goals - -Similarly, there is a way to match over goals in an elegant way, which is -just a notation desugared at parsing time. - -``` -TERM ::= -| "match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" -| "lazy_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING* "end" -| "multi_match!" MATCH-ORDER? "goal" "with" GOAL-MATCHING*"end" - -GOAL-MATCHING := -| "|" "[" HYP-MATCHING* "|-" CONSTR-PATTERN "]" "=>" TERM - -HYP-MATCHING := -| LIDENT ":" CONSTR-PATTERN - -MATCH-ORDER := -| "reverse" -``` - -Variables from `HYP-MATCHING` and `CONSTR-PATTERN` are bound in the body of the -branch. Their types are: -- `constr` for pattern variables appearing in a `CONSTR` -- `Pattern.context` for variables binding a context -- `ident` for variables binding a hypothesis name. - -The same identifier caveat as in the case of matching over constr applies, and -this features has the same semantics as in Ltac1. In particular, a `reverse` -flag can be specified to match hypotheses from the more recently introduced to -the least recently introduced one. - -# Notations - -Notations are the crux of the usability of Ltac1. We should be able to recover -a feeling similar to the old implementation by using and abusing notations. - -## Scopes - -A scope is a name given to a grammar entry used to produce some Ltac2 expression -at parsing time. Scopes are described using a form of S-expression. - -``` -SCOPE := -| STRING -| INT -| LIDENT ( "(" SCOPE₀ "," ... "," SCOPEₙ ")" ) -``` - -A few scopes contain antiquotation features. For sake of uniformity, all -antiquotations are introduced by the syntax `"$" VAR`. - -The following scopes are built-in. -- constr: - + parses `c = COQCONSTR` and produces `constr:(c)` -- ident: - + parses `id = IDENT` and produces `ident:(id)` - + parses `"$" (x = IDENT)` and produces the variable `x` -- list0(*scope*): - + if *scope* parses `ENTRY`, parses ̀`(x₀, ..., xₙ = ENTRY*)` and produces - `[x₀; ...; xₙ]`. -- list0(*scope*, sep = STRING): - + if *scope* parses `ENTRY`, parses `(x₀ = ENTRY, "sep", ..., "sep", xₙ = ENTRY)` - and produces `[x₀; ...; xₙ]`. -- list1: same as list0 (with or without separator) but parses `ENTRY+` instead - of `ENTRY*`. -- opt(*scope*) - + if *scope* parses `ENTRY`, parses `ENTRY?` and produces either `None` or - `Some x` where `x` is the parsed expression. -- self: - + parses a Ltac2 expression at the current level and return it as is. -- next: - + parses a Ltac2 expression at the next level and return it as is. -- tactic(n = INT): - + parses a Ltac2 expression at the provided level *n* and return it as is. -- thunk(*scope*): - + parses the same as *scope*, and if *e* is the parsed expression, returns - `fun () => e`. -- STRING: - + parses the corresponding string as a CAMLP5 IDENT and returns `()`. -- keyword(s = STRING): - + parses the string *s* as a keyword and returns `()`. -- terminal(s = STRING): - + parses the string *s* as a keyword, if it is already a - keyword, otherwise as an IDENT. Returns `()`. -- seq(*scope₁*, ..., *scopeₙ*): - + parses *scope₁*, ..., *scopeₙ* in this order, and produces a tuple made - out of the parsed values in the same order. As an optimization, all - subscopes of the form STRING are left out of the returned tuple, instead - of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using self of next. - -A few other specific scopes exist to handle Ltac1-like syntax, but their use is -discouraged and they are thus not documented. - -For now there is no way to declare new scopes from Ltac2 side, but this is -planned. - -## Notations - -The Ltac2 parser can be extended by syntactic notations. -``` -VERNAC ::= -| "Ltac2" "Notation" TOKEN+ LEVEL? ":=" TERM - -LEVEL := ":" INT - -TOKEN := -| VAR "(" SCOPE ")" -| STRING -``` - -A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded -to the provided body where every token from the notation is let-bound to the -corresponding generated expression. - -For instance, assume we perform: -``` -Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. -``` -Then the following expression -``` -let y := @X in foo (nat -> nat) x $y -``` -will expand at parsing time to -``` -let y := @X in -let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids -``` - -Beware that the order of evaluation of multiple let-bindings is not specified, -so that you may have to resort to thunking to ensure that side-effects are -performed at the right time. - -## Abbreviations - -There exists a special kind of notations, called abbreviations, that is designed -so that it does not add any parsing rules. It is similar in spirit to Coq -abbreviations, insofar as its main purpose is to give an absolute name to a -piece of pure syntax, which can be transparently referred by this name as if it -were a proper definition. Abbreviations are introduced by the following -syntax. - -``` -VERNAC ::= -| "Ltac2" "Notation" IDENT ":=" TERM -``` - -The abbreviation can then be manipulated just as a normal Ltac2 definition, -except that it is expanded at internalization time into the given expression. -Furthermore, in order to make this kind of construction useful in practice in -an effectful language such as Ltac2, any syntactic argument to an abbreviation -is thunked on-the-fly during its expansion. - -For instance, suppose that we define the following. -``` -Ltac2 Notation foo := fun x => x (). -``` -Then we have the following expansion at internalization time. -``` -foo 0 ↦ (fun x => x ()) (fun _ => 0) -``` - -Note that abbreviations are not typechecked at all, and may result in typing -errors after expansion. - -# Evaluation - -Ltac2 features a toplevel loop that can be used to evaluate expressions. - -``` -VERNAC ::= -| "Ltac2" "Eval" TERM -``` - -This command evaluates the term in the current proof if there is one, or in the -global environment otherwise, and displays the resulting value to the user -together with its type. This function is pure in the sense that it does not -modify the state of the proof, and in particular all side-effects are discarded. - -# Debug - -When the option `Ltac2 Backtrace` is set, toplevel failures will be printed with -a backtrace. - -# Compatibility layer with Ltac1 - -## Ltac1 from Ltac2 - -### Simple API - -One can call Ltac1 code from Ltac2 by using the `ltac1` quotation. It parses -a Ltac1 expression, and semantics of this quotation is the evaluation of the -corresponding code for its side effects. In particular, in cannot return values, -and the quotation has type `unit`. - -Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited -to the use of standalone function calls. - -### Low-level API - -There exists a lower-level FFI into Ltac1 that is not recommended for daily use, -which is available in the `Ltac2.Ltac1` module. This API allows to directly -manipulate dynamically-typed Ltac1 values, either through the function calls, -or using the `ltac1val` quotation. The latter parses the same as `ltac1`, but -has type `Ltac2.Ltac1.t` instead of `unit`, and dynamically behaves as an Ltac1 -thunk, i.e. `ltac1val:(foo)` corresponds to the tactic closure that Ltac1 -would generate from `idtac; foo`. - -Due to intricate dynamic semantics, understanding when Ltac1 value quotations -focus is very hard. This is why some functions return a continuation-passing -style value, as it can dispatch dynamically between focused and unfocused -behaviour. - -## Ltac2 from Ltac1 - -Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation -instead. - -Note that the tactic expression is evaluated eagerly, if one wants to use it as -an argument to a Ltac1 function, she has to resort to the good old -`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately -and won't print anything. - -``` -Ltac mytac tac := idtac "wow"; tac. - -Goal True. -Proof. -mytac ltac2:(fail). -``` - -# Transition from Ltac1 - -Owing to the use of a bunch of notations, the transition shouldn't be -atrociously horrible and shockingly painful up to the point you want to retire -in the Ariège mountains, living off the land and insulting careless bypassers in -proto-georgian. - -That said, we do *not* guarantee you it is going to be a blissful walk either. -Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq -will help you. - -We list the major changes and the transition strategies hereafter. - -## Syntax changes - -Due to conflicts, a few syntactic rules have changed. - -- The dispatch tactical `tac; [foo|bar]` is now written `tac > [foo|bar]`. -- Levels of a few operators have been revised. Some tacticals now parse as if - they were a normal function, i.e. one has to put parentheses around the - argument when it is complex, e.g an abstraction. List of affected tacticals: - `try`, `repeat`, `do`, `once`, `progress`, `time`, `abstract`. -- `idtac` is no more. Either use `()` if you expect nothing to happen, - `(fun () => ())` if you want a thunk (see next section), or use printing - primitives from the `Message` module if you want to display something. - -## Tactic delay - -Tactics are not magically delayed anymore, neither as functions nor as -arguments. It is your responsibility to thunk them beforehand and apply them -at the call site. - -A typical example of a delayed function: -``` -Ltac foo := blah. -``` -becomes -``` -Ltac2 foo () := blah. -``` - -All subsequent calls to `foo` must be applied to perform the same effect as -before. - -Likewise, for arguments: -``` -Ltac bar tac := tac; tac; tac. -``` -becomes -``` -Ltac2 bar tac := tac (); tac (); tac (). -``` - -We recommend the use of syntactic notations to ease the transition. For -instance, the first example can alternatively written as: -``` -Ltac2 foo0 () := blah. -Ltac2 Notation foo := foo0 (). -``` - -This allows to keep the subsequent calls to the tactic as-is, as the -expression `foo` will be implicitly expanded everywhere into `foo0 ()`. Such -a trick also works for arguments, as arguments of syntactic notations are -implicitly thunked. The second example could thus be written as follows. - -``` -Ltac2 bar0 tac := tac (); tac (); tac (). -Ltac2 Notation bar := bar0. -``` - -## Variable binding - -Ltac1 relies on a crazy amount of dynamic trickery to be able to tell apart -bound variables from terms, hypotheses and whatnot. There is no such thing in -Ltac2, as variables are recognized statically and other constructions do not -live in the same syntactic world. Due to the abuse of quotations, it can -sometimes be complicated to know what a mere identifier represents in a tactic -expression. We recommend tracking the context and letting the compiler spit -typing errors to understand what is going on. - -We list below the typical changes one has to perform depending on the static -errors produced by the typechecker. - -### In Ltac expressions - -- `Unbound value X`, `Unbound constructor X`: - * if `X` is meant to be a term from the current stactic environment, replace - the problematic use by `'X`. - * if `X` is meant to be a hypothesis from the goal context, replace the - problematic use by `&X`. - -### In quotations - -- `The reference X was not found in the current environment`: - * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, - replace the problematic use by `$X`. - * if `X` is meant to be a hypothesis from the goal context, replace the - problematic use by `&X`. - -## Exception catching - -Ltac2 features a proper exception-catching mechanism. For this reason, the -Ltac1 mechanism relying on `fail` taking integers and tacticals decreasing it -has been removed. Now exceptions are preserved by all tacticals, and it is -your duty to catch it and reraise it depending on your use. - -# TODO - -- Implement deep pattern-matching. -- Craft an expressive set of primitive functions -- Implement native compilation to OCaml diff --git a/vendor/Ltac2/dune b/vendor/Ltac2/dune deleted file mode 100644 index 5dbc4db66a..0000000000 --- a/vendor/Ltac2/dune +++ /dev/null @@ -1,3 +0,0 @@ -(env - (dev (flags :standard -rectypes)) - (release (flags :standard -rectypes))) diff --git a/vendor/Ltac2/dune-project b/vendor/Ltac2/dune-project deleted file mode 100644 index 8154e999de..0000000000 --- a/vendor/Ltac2/dune-project +++ /dev/null @@ -1,3 +0,0 @@ -(lang dune 1.6) -(using coq 0.1) -(name ltac2) diff --git a/vendor/Ltac2/ltac2.opam b/vendor/Ltac2/ltac2.opam deleted file mode 100644 index 47ceb882b1..0000000000 --- a/vendor/Ltac2/ltac2.opam +++ /dev/null @@ -1,18 +0,0 @@ -synopsis: "A Tactic Language for Coq." -description: "A Tactic Language for Coq." -name: "coq-ltac2" -opam-version: "2.0" -maintainer: "Pierre-Marie Pédrot " -authors: "Pierre-Marie Pédrot " -homepage: "https://github.com/ppedrot/ltac2" -dev-repo: "https://github.com/ppedrot/ltac2.git" -bug-reports: "https://github.com/ppedrot/ltac2/issues" -license: "LGPL 2.1" -doc: "https://ppedrot.github.io/ltac2/doc" - -depends: [ - "coq" { = "dev" } - "dune" { build & >= "1.9.0" } -] - -build: [ "dune" "build" "-p" name "-j" jobs ] diff --git a/vendor/Ltac2/src/dune b/vendor/Ltac2/src/dune deleted file mode 100644 index 332f3644b0..0000000000 --- a/vendor/Ltac2/src/dune +++ /dev/null @@ -1,11 +0,0 @@ -(library - (name ltac2_plugin) - (public_name ltac2.plugin) - (modules_without_implementation tac2expr tac2qexpr tac2types) - (flags :standard -warn-error -9-27-50) - (libraries coq.plugins.firstorder)) - -(rule - (targets g_ltac2.ml) - (deps (:mlg-file g_ltac2.mlg)) - (action (run coqpp %{mlg-file}))) diff --git a/vendor/Ltac2/src/g_ltac2.mlg b/vendor/Ltac2/src/g_ltac2.mlg deleted file mode 100644 index 0071dbb088..0000000000 --- a/vendor/Ltac2/src/g_ltac2.mlg +++ /dev/null @@ -1,933 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tok.t Stream.t -> int option - -let entry_of_lookahead s (lk : lookahead) = - let run strm = match lk 0 strm with None -> err () | Some _ -> () in - Pcoq.Entry.of_parser s run - -let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> None -| Some n -> lk2 n strm - -let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> lk2 n strm -| Some n -> Some n - -let lk_kw kw n strm = match stream_nth n strm with -| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None -| _ -> None - -let lk_ident n strm = match stream_nth n strm with -| IDENT _ -> Some (n + 1) -| _ -> None - -let lk_int n strm = match stream_nth n strm with -| NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) -| _ -> None - -let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) - -(* lookahead for (x:=t), (?x:=t) and (1:=t) *) -let test_lpar_idnum_coloneq = - entry_of_lookahead "test_lpar_idnum_coloneq" begin - lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" - end - -(* lookahead for (x:t), (?x:t) *) -let test_lpar_id_colon = - entry_of_lookahead "test_lpar_id_colon" begin - lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" - end - -(* Hack to recognize "(x := t)" and "($x := t)" *) -let test_lpar_id_coloneq = - entry_of_lookahead "test_lpar_id_coloneq" begin - lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" - end - -(* Hack to recognize "(x)" *) -let test_lpar_id_rpar = - entry_of_lookahead "test_lpar_id_rpar" begin - lk_kw "(" >> lk_ident >> lk_kw ")" - end - -let test_ampersand_ident = - entry_of_lookahead "test_ampersand_ident" begin - lk_kw "&" >> lk_ident - end - -let test_dollar_ident = - entry_of_lookahead "test_dollar_ident" begin - lk_kw "$" >> lk_ident - end - -let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Entry.create "tactic:tac2type" -let tac2def_val = Entry.create "tactic:tac2def_val" -let tac2def_typ = Entry.create "tactic:tac2def_typ" -let tac2def_ext = Entry.create "tactic:tac2def_ext" -let tac2def_syn = Entry.create "tactic:tac2def_syn" -let tac2def_mut = Entry.create "tactic:tac2def_mut" -let tac2def_run = Entry.create "tactic:tac2def_run" -let tac2mode = Entry.create "vernac:ltac2_command" - -let ltac1_expr = Pltac.tactic_expr - -let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) -let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c -let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c -let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c -let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e -let inj_ltac1val loc e = inj_wit Tac2quote.wit_ltac1val loc e - -let pattern_of_qualid qid = - if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) - else - let open Libnames in - if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) - else - CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") - -} - -GRAMMAR EXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut tac2def_run; - tac2pat: - [ "1" LEFTA - [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { - if Tac2env.is_constructor qid then - CAst.make ~loc @@ CPatRef (RelId qid, pl) - else - CErrors.user_err ~loc (Pp.str "Syntax error") } - | qid = Prim.qualid -> { pattern_of_qualid qid } - | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } - | p1 = tac2pat; "::"; p2 = tac2pat -> - { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])} - ] - | "0" - [ "_" -> { CAst.make ~loc @@ CPatVar Anonymous } - | "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } - | qid = Prim.qualid -> { pattern_of_qualid qid } - | "("; p = atomic_tac2pat; ")" -> { p } - ] ] - ; - atomic_tac2pat: - [ [ -> - { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } - | p = tac2pat; ":"; t = tac2type -> - { CAst.make ~loc @@ CPatCnv (p, t) } - | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> - { let pl = p :: pl in - CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) } - | p = tac2pat -> { p } - ] ] - ; - tac2expr: - [ "6" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] - | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> - { CAst.make ~loc @@ CTacFun (it, body) } - | "let"; isrec = rec_flag; - lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "6" -> - { CAst.make ~loc @@ CTacLet (isrec, lc, e) } - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> - { CAst.make ~loc @@ CTacCse (e, bl) } - ] - | "4" LEFTA [ ] - | "::" RIGHTA - [ e1 = tac2expr; "::"; e2 = tac2expr -> - { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } - ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> - { let el = e0 :: el in - CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] - | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> - { CAst.make ~loc @@ CTacApp (e, el) } - | e = SELF; ".("; qid = Prim.qualid; ")" -> - { CAst.make ~loc @@ CTacPrj (e, RelId qid) } - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> - { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] - | "0" - [ "("; a = SELF; ")" -> { a } - | "("; a = SELF; ":"; t = tac2type; ")" -> - { CAst.make ~loc @@ CTacCnv (a, t) } - | "()" -> - { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } - | "("; ")" -> - { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } - | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> - { Tac2quote.of_list ~loc (fun x -> x) a } - | "{"; a = tac2rec_fieldexprs; "}" -> - { CAst.make ~loc @@ CTacRec a } - | a = tactic_atom -> { a } ] - ] - ; - branches: - [ [ -> { [] } - | "|"; bl = LIST1 branch SEP "|" -> { bl } - | bl = LIST1 branch SEP "|" -> { bl } ] - ] - ; - branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] - ; - rec_flag: - [ [ IDENT "rec" -> { true } - | -> { false } ] ] - ; - mut_flag: - [ [ IDENT "mutable" -> { true } - | -> { false } ] ] - ; - typ_param: - [ [ "'"; id = Prim.ident -> { id } ] ] - ; - tactic_atom: - [ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) } - | s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) } - | qid = Prim.qualid -> - { if Tac2env.is_constructor qid then - CAst.make ~loc @@ CTacCst (RelId qid) - else - CAst.make ~loc @@ CTacRef (RelId qid) } - | "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) } - | "&"; id = lident -> { Tac2quote.of_hyp ~loc id } - | "'"; c = Constr.constr -> { inj_open_constr loc c } - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } - | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } - | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } - | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } - | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } - | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1val loc qid } - ] ] - ; - let_clause: - [ [ binder = let_binder; ":="; te = tac2expr -> - { let (pat, fn) = binder in - let te = match fn with - | None -> te - | Some args -> CAst.make ~loc @@ CTacFun (args, te) - in - (pat, te) } - ] ] - ; - let_binder: - [ [ pats = LIST1 input_fun -> - { match pats with - | [{CAst.v=CPatVar _} as pat] -> (pat, None) - | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) - | [pat] -> (pat, None) - | _ -> CErrors.user_err ~loc (str "Invalid pattern") } - ] ] - ; - tac2type: - [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] - | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> - { let tl = t :: tl in - CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] - | "1" LEFTA - [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] - | "0" - [ "("; t = tac2type LEVEL "5"; ")" -> { t } - | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } - | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } - | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } - | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> - { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] - ]; - locident: - [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] - ; - binder: - [ [ "_" -> { CAst.make ~loc Anonymous } - | l = Prim.ident -> { CAst.make ~loc (Name l) } ] ] - ; - input_fun: - [ [ b = tac2pat LEVEL "0" -> { b } ] ] - ; - tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> - { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in - (name, e) } - ] ] - ; - tac2def_val: - [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> - { StrVal (mut, isrec, l) } - ] ] - ; - tac2def_mut: - [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] - ; - tac2def_run: - [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] - ; - tac2typ_knd: - [ [ t = tac2type -> { CTydDef (Some t) } - | "["; ".."; "]" -> { CTydOpn } - | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } - | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] - ; - tac2alg_constructors: - [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs } - | cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ] - ; - tac2alg_constructor: - [ [ c = Prim.ident -> { (c, []) } - | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] - ; - tac2rec_fields: - [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } - | f = tac2rec_field; ";" -> { [f] } - | f = tac2rec_field -> { [f] } - | -> { [] } ] ] - ; - tac2rec_field: - [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] - ; - tac2rec_fieldexprs: - [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } - | f = tac2rec_fieldexpr; ";" -> { [f] } - | f = tac2rec_fieldexpr-> { [f] } - | -> { [] } ] ] - ; - tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] - ; - tac2typ_prm: - [ [ -> { [] } - | id = typ_param -> { [CAst.make ~loc id] } - | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } - ] ] - ; - tac2typ_def: - [ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ] - ; - tac2type_body: - [ [ -> { false, CTydDef None } - | ":="; e = tac2typ_knd -> { false, e } - | "::="; e = tac2typ_knd -> { true, e } - ] ] - ; - tac2def_typ: - [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> - { StrTyp (isrec, l) } - ] ] - ; - tac2def_ext: - [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; - plugin = Prim.string; name = Prim.string -> - { let ml = { mltac_plugin = plugin; mltac_tactic = name } in - StrPrm (id, t, ml) } - ] ] - ; - syn_node: - [ [ "_" -> { CAst.make ~loc None } - | id = Prim.ident -> { CAst.make ~loc (Some id) } - ] ] - ; - sexpr: - [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } - | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } - | id = syn_node -> { SexprRec (loc, id, []) } - | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> - { SexprRec (loc, id, tok) } - ] ] - ; - syn_level: - [ [ -> { None } - | ":"; n = Prim.integer -> { Some n } - ] ] - ; - tac2def_syn: - [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; - e = tac2expr -> - { StrSyn (toks, n, e) } - ] ] - ; - lident: - [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] - ; - globref: - [ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) } - | qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid } - ] ] - ; -END - -(* Quotation scopes used by notations *) - -{ - -open Tac2entries.Pltac - -let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) - -} - -GRAMMAR EXTEND Gram - GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause - q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag - q_destruction_arg q_reference q_with_bindings q_constr_matching - q_goal_matching q_hintdb q_move_location q_pose q_assert; - anti: - [ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ] - ; - ident_or_anti: - [ [ id = lident -> { QExpr id } - | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } - ] ] - ; - lident: - [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] - ; - lnatural: - [ [ n = Prim.natural -> { CAst.make ~loc n } ] ] - ; - q_ident: - [ [ id = ident_or_anti -> { id } ] ] - ; - qhyp: - [ [ x = anti -> { x } - | n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) } - | id = lident -> { QExpr (CAst.make ~loc @@ QNamedHyp id) } - ] ] - ; - simple_binding: - [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> - { CAst.make ~loc (h, c) } - ] ] - ; - bindings: - [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - { CAst.make ~loc @@ QExplicitBindings bl } - | bl = LIST1 Constr.constr -> - { CAst.make ~loc @@ QImplicitBindings bl } - ] ] - ; - q_bindings: - [ [ bl = bindings -> { bl } ] ] - ; - q_with_bindings: - [ [ bl = with_bindings -> { bl } ] ] - ; - intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ] - ; -(* ne_intropatterns: *) -(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) -(* ; *) - or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc } - | "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) } - | "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) } - | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> - { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) } - | "("; si = simple_intropattern; "&"; - tc = LIST1 simple_intropattern SEP "&" ; ")" -> - (* (A & B & C) is translated into (A,(B,C)) *) - { let rec pairify = function - | ([]|[_]|[_;_]) as l -> CAst.make ~loc l - | t::q -> - let q = - CAst.make ~loc @@ - QIntroAction (CAst.make ~loc @@ - QIntroOrAndPattern (CAst.make ~loc @@ - QIntroAndPattern (pairify q))) - in - CAst.make ~loc [t; q] - in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ] - ; - equality_intropattern: - [ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true } - | "<-" -> { CAst.make ~loc @@ QIntroRewrite false } - | "[="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ] - ; - naming_intropattern: - [ [ LEFTQMARK; id = lident -> - { CAst.make ~loc @@ QIntroFresh (QExpr id) } - | "?$"; id = lident -> - { CAst.make ~loc @@ QIntroFresh (QAnti id) } - | "?" -> - { CAst.make ~loc @@ QIntroAnonymous } - | id = ident_or_anti -> - { CAst.make ~loc @@ QIntroIdentifier id } - ] ] - ; - nonsimple_intropattern: - [ [ l = simple_intropattern -> { l } - | "*" -> { CAst.make ~loc @@ QIntroForthcoming true } - | "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ] - ; - simple_intropattern: - [ [ pat = simple_intropattern_closed -> -(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) - (** TODO: handle %pat *) - { pat } - ] ] - ; - simple_intropattern_closed: - [ [ pat = or_and_intropattern -> - { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) } - | pat = equality_intropattern -> - { CAst.make ~loc @@ QIntroAction pat } - | "_" -> - { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) } - | pat = naming_intropattern -> - { CAst.make ~loc @@ QIntroNaming pat } - ] ] - ; - q_intropatterns: - [ [ ipat = intropatterns -> { ipat } ] ] - ; - q_intropattern: - [ [ ipat = simple_intropattern -> { ipat } ] ] - ; - nat_or_anti: - [ [ n = lnatural -> { QExpr n } - | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } - ] ] - ; - eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat } - | -> { None } - ] ] - ; - with_bindings: - [ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ] - ; - constr_with_bindings: - [ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ] - ; - destruction_arg: - [ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n } - | id = lident -> { CAst.make ~loc @@ QElimOnIdent id } - | c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c } - ] ] - ; - q_destruction_arg: - [ [ arg = destruction_arg -> { arg } ] ] - ; - as_or_and_ipat: - [ [ "as"; ipat = or_and_intropattern -> { Some ipat } - | -> { None } - ] ] - ; - occs_nums: - [ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl } - | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> - { CAst.make ~loc @@ QAllOccurrencesBut (n::nl) } - ] ] - ; - occs: - [ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ] - ; - hypident: - [ [ id = ident_or_anti -> - { id,Locus.InHyp } - | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> - { id,Locus.InHypTypeOnly } - | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> - { id,Locus.InHypValueOnly } - ] ] - ; - hypident_occ: - [ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ] - ; - in_clause: - [ [ "*"; occs=occs -> - { { q_onhyps = None; q_concl_occs = occs } } - | "*"; "|-"; occs = concl_occ -> - { { q_onhyps = None; q_concl_occs = occs } } - | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> - { { q_onhyps = Some hl; q_concl_occs = occs } } - | hl = LIST0 hypident_occ SEP "," -> - { { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } } - ] ] - ; - clause: - [ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl } - | "at"; occs = occs_nums -> - { CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } } - ] ] - ; - q_clause: - [ [ cl = clause -> { cl } ] ] - ; - concl_occ: - [ [ "*"; occs = occs -> { occs } - | -> { CAst.make ~loc QNoOccurrences } - ] ] - ; - induction_clause: - [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = OPT clause -> - { CAst.make ~loc @@ { - indcl_arg = c; - indcl_eqn = eq; - indcl_as = pat; - indcl_in = cl; - } } - ] ] - ; - q_induction_clause: - [ [ cl = induction_clause -> { cl } ] ] - ; - conversion: - [ [ c = Constr.constr -> - { CAst.make ~loc @@ QConvert c } - | c1 = Constr.constr; "with"; c2 = Constr.constr -> - { CAst.make ~loc @@ QConvertWith (c1, c2) } - ] ] - ; - q_conversion: - [ [ c = conversion -> { c } ] ] - ; - orient: - [ [ "->" -> { CAst.make ~loc (Some true) } - | "<-" -> { CAst.make ~loc (Some false) } - | -> { CAst.make ~loc None } - ]] - ; - rewriter: - [ [ "!"; c = constr_with_bindings -> - { (CAst.make ~loc @@ QRepeatPlus,c) } - | [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> - { (CAst.make ~loc @@ QRepeatStar,c) } - | n = lnatural; "!"; c = constr_with_bindings -> - { (CAst.make ~loc @@ QPrecisely n,c) } - | n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> - { (CAst.make ~loc @@ QUpTo n,c) } - | n = lnatural; c = constr_with_bindings -> - { (CAst.make ~loc @@ QPrecisely n,c) } - | c = constr_with_bindings -> - { (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) } - ] ] - ; - oriented_rewriter: - [ [ b = orient; r = rewriter -> - { let (m, c) = r in - CAst.make ~loc @@ { - rew_orient = b; - rew_repeat = m; - rew_equatn = c; - } } - ] ] - ; - q_rewriting: - [ [ r = oriented_rewriter -> { r } ] ] - ; - tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } - | -> { [] } - ] ] - ; - tactic_then_gen: - [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } - | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } - | ".."; l = tactic_then_last -> { ([], Some (None, l)) } - | ta = tac2expr -> { ([Some ta], None) } - | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } - | -> { ([None], None) } - ] ] - ; - q_dispatch: - [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] - ; - q_occurrences: - [ [ occs = occs -> { occs } ] ] - ; - red_flag: - [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } - | IDENT "iota" -> { CAst.make ~loc @@ QIota } - | IDENT "match" -> { CAst.make ~loc @@ QMatch } - | IDENT "fix" -> { CAst.make ~loc @@ QFix } - | IDENT "cofix" -> { CAst.make ~loc @@ QCofix } - | IDENT "zeta" -> { CAst.make ~loc @@ QZeta } - | IDENT "delta"; d = delta_flag -> { d } - ] ] - ; - refglobal: - [ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) } - | qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) } - | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } - ] ] - ; - q_reference: - [ [ r = refglobal -> { r } ] ] - ; - refglobals: - [ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ] - ; - delta_flag: - [ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl } - | "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl } - | -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) } - ] ] - ; - strategy_flag: - [ [ s = LIST1 red_flag -> { CAst.make ~loc s } - | d = delta_flag -> - { CAst.make ~loc - [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } - ] ] - ; - q_strategy_flag: - [ [ flag = strategy_flag -> { flag } ] ] - ; - hintdb: - [ [ "*" -> { CAst.make ~loc @@ QHintAll } - | l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l } - ] ] - ; - q_hintdb: - [ [ db = hintdb -> { db } ] ] - ; - match_pattern: - [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } - | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; tac = tac2expr -> - { CAst.make ~loc @@ (mp, tac) } - ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } - | "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] - ; - q_constr_matching: - [ [ m = match_list -> { m } ] ] - ; - gmatch_hyp_pattern: - [ [ na = Prim.name; ":"; pat = match_pattern -> { (na, pat) } ] ] - ; - gmatch_pattern: - [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> - { CAst.make ~loc @@ { - q_goal_match_concl = p; - q_goal_match_hyps = hl; - } } - ] ] - ; - gmatch_rule: - [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> - { CAst.make ~loc @@ (mp, tac) } - ] ] - ; - gmatch_list: - [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } - | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] - ; - q_goal_matching: - [ [ m = gmatch_list -> { m } ] ] - ; - move_location: - [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } - | "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast } - | IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id } - | IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id } - ] ] - ; - q_move_location: - [ [ mv = move_location -> { mv } ] ] - ; - as_name: - [ [ -> { None } - | "as"; id = ident_or_anti -> { Some id } - ] ] - ; - pose: - [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - { CAst.make ~loc (Some id, c) } - | c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) } - ] ] - ; - q_pose: - [ [ p = pose -> { p } ] ] - ; - as_ipat: - [ [ "as"; ipat = simple_intropattern -> { Some ipat } - | -> { None } - ] ] - ; - by_tactic: - [ [ "by"; tac = tac2expr -> { Some tac } - | -> { None } - ] ] - ; - assertion: - [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> - { CAst.make ~loc (QAssertValue (id, c)) } - | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> - { let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in - CAst.make ~loc (QAssertType (Some ipat, c, tac)) } - | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> - { CAst.make ~loc (QAssertType (ipat, c, tac)) } - ] ] - ; - q_assert: - [ [ a = assertion -> { a } ] ] - ; -END - -(** Extension of constr syntax *) - -(* -GRAMMAR EXTEND Gram - Pcoq.Constr.operconstr: LEVEL "0" - [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> - { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } - | test_ampersand_ident; "&"; id = Prim.ident -> - { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } - | test_dollar_ident; "$"; id = Prim.ident -> - { let id = Loc.tag ~loc id in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } - ] ] - ; -END -*) -{ - -let () = - -let open Extend in -let open Tok in -let (++) r s = Next (r, s) in -let rules = [ - Rule ( - Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, - begin fun id _ _ loc -> - let id = Loc.tag ~loc id in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - end - ); - - Rule ( - Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, - begin fun id _ _ loc -> - let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - end - ); - - Rule ( - Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ - Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), - begin fun _ tac _ _ _ loc -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in - CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) - end - ) -] in - -Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) -end - -} - -{ - -let pr_ltac2entry _ = mt () (* FIXME *) -let pr_ltac2expr _ = mt () (* FIXME *) - -} - -VERNAC ARGUMENT EXTEND ltac2_entry -PRINTED BY { pr_ltac2entry } -| [ tac2def_val(v) ] -> { v } -| [ tac2def_typ(t) ] -> { t } -| [ tac2def_ext(e) ] -> { e } -| [ tac2def_syn(e) ] -> { e } -| [ tac2def_mut(e) ] -> { e } -| [ tac2def_run(e) ] -> { e } -END - -{ - -let classify_ltac2 = function -| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) -| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff - -} - -VERNAC COMMAND EXTEND VernacDeclareTactic2Definition -| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { - fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate - } -END - -{ - -let _ = Pvernac.register_proof_mode "Ltac2" tac2mode - -} - -VERNAC ARGUMENT EXTEND ltac2_expr -PRINTED BY { pr_ltac2expr } -| [ tac2expr(e) ] -> { e } -END - -{ - -open G_ltac -open Vernacextend - -} - -VERNAC { tac2mode } EXTEND VernacLtac2 -| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => - { classify_as_proofstep } -> { -(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - fun ~pstate -> - Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate - } -END - -{ - -open Stdarg - -} - -VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF -| [ "Print" "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac tac } -END diff --git a/vendor/Ltac2/src/ltac2_plugin.mlpack b/vendor/Ltac2/src/ltac2_plugin.mlpack deleted file mode 100644 index 2a25e825cb..0000000000 --- a/vendor/Ltac2/src/ltac2_plugin.mlpack +++ /dev/null @@ -1,14 +0,0 @@ -Tac2dyn -Tac2ffi -Tac2env -Tac2print -Tac2intern -Tac2interp -Tac2entries -Tac2quote -Tac2match -Tac2core -Tac2extffi -Tac2tactics -Tac2stdlib -G_ltac2 diff --git a/vendor/Ltac2/src/tac2core.ml b/vendor/Ltac2/src/tac2core.ml deleted file mode 100644 index d7e7b91ee6..0000000000 --- a/vendor/Ltac2/src/tac2core.ml +++ /dev/null @@ -1,1446 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Value.of_option Value.of_ident None -| Name id -> Value.of_option Value.of_ident (Some id) - -let to_name c = match Value.to_option Value.to_ident c with -| None -> Anonymous -| Some id -> Name id - -let of_relevance = function - | Sorts.Relevant -> ValInt 0 - | Sorts.Irrelevant -> ValInt 1 - -let to_relevance = function - | ValInt 0 -> Sorts.Relevant - | ValInt 1 -> Sorts.Irrelevant - | _ -> assert false - -let of_annot f Context.{binder_name;binder_relevance} = - of_tuple [|(f binder_name); of_relevance binder_relevance|] - -let to_annot f x = - match to_tuple x with - | [|x;y|] -> - let x = f x in - let y = to_relevance y in - Context.make_annot x y - | _ -> assert false - -let of_instance u = - let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in - Value.of_array (fun v -> Value.of_ext Value.val_univ v) u - -let to_instance u = - let u = Value.to_array (fun v -> Value.to_ext Value.val_univ v) u in - EConstr.EInstance.make (Univ.Instance.of_array u) - -let of_rec_declaration (nas, ts, cs) = - (Value.of_array (of_annot of_name) nas, - Value.of_array Value.of_constr ts, - Value.of_array Value.of_constr cs) - -let to_rec_declaration (nas, ts, cs) = - (Value.to_array (to_annot to_name) nas, - Value.to_array Value.to_constr ts, - Value.to_array Value.to_constr cs) - -let of_result f = function -| Inl c -> v_blk 0 [|f c|] -| Inr e -> v_blk 1 [|Value.of_exn e|] - -(** Stdlib exceptions *) - -let err_notfocussed = - Tac2interp.LtacError (coq_core "Not_focussed", [||]) - -let err_outofbounds = - Tac2interp.LtacError (coq_core "Out_of_bounds", [||]) - -let err_notfound = - Tac2interp.LtacError (coq_core "Not_found", [||]) - -let err_matchfailure = - Tac2interp.LtacError (coq_core "Match_failure", [||]) - -(** Helper functions *) - -let thaw f = Tac2ffi.apply f [v_unit] - -let fatal_flag : unit Exninfo.t = Exninfo.make () - -let set_bt info = - if !Tac2interp.print_ltac2_backtrace then - Tac2interp.get_backtrace >>= fun bt -> - Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) - else Proofview.tclUNIT info - -let throw ?(info = Exninfo.null) e = - set_bt info >>= fun info -> - let info = Exninfo.add info fatal_flag () in - Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) - -let fail ?(info = Exninfo.null) e = - set_bt info >>= fun info -> - Proofview.tclZERO ~info e - -let return x = Proofview.tclUNIT x -let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } - -let wrap f = - return () >>= fun () -> return (f ()) - -let wrap_unit f = - return () >>= fun () -> f (); return v_unit - -let assert_focussed = - Proofview.Goal.goals >>= fun gls -> - match gls with - | [_] -> Proofview.tclUNIT () - | [] | _ :: _ :: _ -> throw err_notfocussed - -let pf_apply f = - Proofview.Goal.goals >>= function - | [] -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - f env sigma - | [gl] -> - gl >>= fun gl -> - f (Proofview.Goal.env gl) (Tacmach.New.project gl) - | _ :: _ :: _ -> - throw err_notfocussed - -(** Primitives *) - -let define_primitive name arity f = - Tac2env.define_primitive (pname name) (mk_closure arity f) - -let define0 name f = define_primitive name arity_one (fun _ -> f) - -let define1 name r0 f = define_primitive name arity_one begin fun x -> - f (Value.repr_to r0 x) -end - -let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> - f (Value.repr_to r0 x) (Value.repr_to r1 y) -end - -let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> - f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) -end - -(** Printing *) - -let () = define1 "print" pp begin fun pp -> - wrap_unit (fun () -> Feedback.msg_notice pp) -end - -let () = define1 "message_of_int" int begin fun n -> - return (Value.of_pp (Pp.int n)) -end - -let () = define1 "message_of_string" string begin fun s -> - return (Value.of_pp (str (Bytes.to_string s))) -end - -let () = define1 "message_of_constr" constr begin fun c -> - pf_apply begin fun env sigma -> - let pp = Printer.pr_econstr_env env sigma c in - return (Value.of_pp pp) - end -end - -let () = define1 "message_of_ident" ident begin fun c -> - let pp = Id.print c in - return (Value.of_pp pp) -end - -let () = define1 "message_of_exn" valexpr begin fun v -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - let pp = Tac2print.pr_valexpr env sigma v (GTypRef (Other Core.t_exn, [])) in - return (Value.of_pp pp) -end - - -let () = define2 "message_concat" pp pp begin fun m1 m2 -> - return (Value.of_pp (Pp.app m1 m2)) -end - -(** Array *) - -let () = define2 "array_make" int valexpr begin fun n x -> - if n < 0 || n > Sys.max_array_length then throw err_outofbounds - else wrap (fun () -> v_blk 0 (Array.make n x)) -end - -let () = define1 "array_length" block begin fun (_, v) -> - return (Value.of_int (Array.length v)) -end - -let () = define3 "array_set" block int valexpr begin fun (_, v) n x -> - if n < 0 || n >= Array.length v then throw err_outofbounds - else wrap_unit (fun () -> v.(n) <- x) -end - -let () = define2 "array_get" block int begin fun (_, v) n -> - if n < 0 || n >= Array.length v then throw err_outofbounds - else wrap (fun () -> v.(n)) -end - -(** Ident *) - -let () = define2 "ident_equal" ident ident begin fun id1 id2 -> - return (Value.of_bool (Id.equal id1 id2)) -end - -let () = define1 "ident_to_string" ident begin fun id -> - return (Value.of_string (Bytes.of_string (Id.to_string id))) -end - -let () = define1 "ident_of_string" string begin fun s -> - let id = try Some (Id.of_string (Bytes.to_string s)) with _ -> None in - return (Value.of_option Value.of_ident id) -end - -(** Int *) - -let () = define2 "int_equal" int int begin fun m n -> - return (Value.of_bool (m == n)) -end - -let binop n f = define2 n int int begin fun m n -> - return (Value.of_int (f m n)) -end - -let () = binop "int_compare" Int.compare -let () = binop "int_add" (+) -let () = binop "int_sub" (-) -let () = binop "int_mul" ( * ) - -let () = define1 "int_neg" int begin fun m -> - return (Value.of_int (~- m)) -end - -(** Char *) - -let () = define1 "char_of_int" int begin fun n -> - wrap (fun () -> Value.of_char (Char.chr n)) -end - -let () = define1 "char_to_int" char begin fun n -> - wrap (fun () -> Value.of_int (Char.code n)) -end - -(** String *) - -let () = define2 "string_make" int char begin fun n c -> - if n < 0 || n > Sys.max_string_length then throw err_outofbounds - else wrap (fun () -> Value.of_string (Bytes.make n c)) -end - -let () = define1 "string_length" string begin fun s -> - return (Value.of_int (Bytes.length s)) -end - -let () = define3 "string_set" string int char begin fun s n c -> - if n < 0 || n >= Bytes.length s then throw err_outofbounds - else wrap_unit (fun () -> Bytes.set s n c) -end - -let () = define2 "string_get" string int begin fun s n -> - if n < 0 || n >= Bytes.length s then throw err_outofbounds - else wrap (fun () -> Value.of_char (Bytes.get s n)) -end - -(** Terms *) - -(** constr -> constr *) -let () = define1 "constr_type" constr begin fun c -> - let get_type env sigma = - Proofview.V82.wrap_exceptions begin fun () -> - let (sigma, t) = Typing.type_of env sigma c in - let t = Value.of_constr t in - Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t - end in - pf_apply get_type -end - -(** constr -> constr *) -let () = define2 "constr_equal" constr constr begin fun c1 c2 -> - Proofview.tclEVARMAP >>= fun sigma -> - let b = EConstr.eq_constr sigma c1 c2 in - Proofview.tclUNIT (Value.of_bool b) -end - -let () = define1 "constr_kind" constr begin fun c -> - let open Constr in - Proofview.tclEVARMAP >>= fun sigma -> - return begin match EConstr.kind sigma c with - | Rel n -> - v_blk 0 [|Value.of_int n|] - | Var id -> - v_blk 1 [|Value.of_ident id|] - | Meta n -> - v_blk 2 [|Value.of_int n|] - | Evar (evk, args) -> - v_blk 3 [| - Value.of_int (Evar.repr evk); - Value.of_array Value.of_constr args; - |] - | Sort s -> - v_blk 4 [|Value.of_ext Value.val_sort s|] - | Cast (c, k, t) -> - v_blk 5 [| - Value.of_constr c; - Value.of_ext Value.val_cast k; - Value.of_constr t; - |] - | Prod (na, t, u) -> - v_blk 6 [| - of_annot of_name na; - Value.of_constr t; - Value.of_constr u; - |] - | Lambda (na, t, c) -> - v_blk 7 [| - of_annot of_name na; - Value.of_constr t; - Value.of_constr c; - |] - | LetIn (na, b, t, c) -> - v_blk 8 [| - of_annot of_name na; - Value.of_constr b; - Value.of_constr t; - Value.of_constr c; - |] - | App (c, cl) -> - v_blk 9 [| - Value.of_constr c; - Value.of_array Value.of_constr cl; - |] - | Const (cst, u) -> - v_blk 10 [| - Value.of_constant cst; - of_instance u; - |] - | Ind (ind, u) -> - v_blk 11 [| - Value.of_ext Value.val_inductive ind; - of_instance u; - |] - | Construct (cstr, u) -> - v_blk 12 [| - Value.of_ext Value.val_constructor cstr; - of_instance u; - |] - | Case (ci, c, t, bl) -> - v_blk 13 [| - Value.of_ext Value.val_case ci; - Value.of_constr c; - Value.of_constr t; - Value.of_array Value.of_constr bl; - |] - | Fix ((recs, i), def) -> - let (nas, ts, cs) = of_rec_declaration def in - v_blk 14 [| - Value.of_array Value.of_int recs; - Value.of_int i; - nas; - ts; - cs; - |] - | CoFix (i, def) -> - let (nas, ts, cs) = of_rec_declaration def in - v_blk 15 [| - Value.of_int i; - nas; - ts; - cs; - |] - | Proj (p, c) -> - v_blk 16 [| - Value.of_ext Value.val_projection p; - Value.of_constr c; - |] - | Int _ -> - assert false - end -end - -let () = define1 "constr_make" valexpr begin fun knd -> - let c = match Tac2ffi.to_block knd with - | (0, [|n|]) -> - let n = Value.to_int n in - EConstr.mkRel n - | (1, [|id|]) -> - let id = Value.to_ident id in - EConstr.mkVar id - | (2, [|n|]) -> - let n = Value.to_int n in - EConstr.mkMeta n - | (3, [|evk; args|]) -> - let evk = Evar.unsafe_of_int (Value.to_int evk) in - let args = Value.to_array Value.to_constr args in - EConstr.mkEvar (evk, args) - | (4, [|s|]) -> - let s = Value.to_ext Value.val_sort s in - EConstr.mkSort (EConstr.Unsafe.to_sorts s) - | (5, [|c; k; t|]) -> - let c = Value.to_constr c in - let k = Value.to_ext Value.val_cast k in - let t = Value.to_constr t in - EConstr.mkCast (c, k, t) - | (6, [|na; t; u|]) -> - let na = to_annot to_name na in - let t = Value.to_constr t in - let u = Value.to_constr u in - EConstr.mkProd (na, t, u) - | (7, [|na; t; c|]) -> - let na = to_annot to_name na in - let t = Value.to_constr t in - let u = Value.to_constr c in - EConstr.mkLambda (na, t, u) - | (8, [|na; b; t; c|]) -> - let na = to_annot to_name na in - let b = Value.to_constr b in - let t = Value.to_constr t in - let c = Value.to_constr c in - EConstr.mkLetIn (na, b, t, c) - | (9, [|c; cl|]) -> - let c = Value.to_constr c in - let cl = Value.to_array Value.to_constr cl in - EConstr.mkApp (c, cl) - | (10, [|cst; u|]) -> - let cst = Value.to_constant cst in - let u = to_instance u in - EConstr.mkConstU (cst, u) - | (11, [|ind; u|]) -> - let ind = Value.to_ext Value.val_inductive ind in - let u = to_instance u in - EConstr.mkIndU (ind, u) - | (12, [|cstr; u|]) -> - let cstr = Value.to_ext Value.val_constructor cstr in - let u = to_instance u in - EConstr.mkConstructU (cstr, u) - | (13, [|ci; c; t; bl|]) -> - let ci = Value.to_ext Value.val_case ci in - let c = Value.to_constr c in - let t = Value.to_constr t in - let bl = Value.to_array Value.to_constr bl in - EConstr.mkCase (ci, c, t, bl) - | (14, [|recs; i; nas; ts; cs|]) -> - let recs = Value.to_array Value.to_int recs in - let i = Value.to_int i in - let def = to_rec_declaration (nas, ts, cs) in - EConstr.mkFix ((recs, i), def) - | (15, [|i; nas; ts; cs|]) -> - let i = Value.to_int i in - let def = to_rec_declaration (nas, ts, cs) in - EConstr.mkCoFix (i, def) - | (16, [|p; c|]) -> - let p = Value.to_ext Value.val_projection p in - let c = Value.to_constr c in - EConstr.mkProj (p, c) - | _ -> assert false - in - return (Value.of_constr c) -end - -let () = define1 "constr_check" constr begin fun c -> - pf_apply begin fun env sigma -> - try - let (sigma, _) = Typing.type_of env sigma c in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - return (of_result Value.of_constr (Inl c)) - with e when CErrors.noncritical e -> - let e = CErrors.push e in - return (of_result Value.of_constr (Inr e)) - end -end - -let () = define3 "constr_substnl" (list constr) int constr begin fun subst k c -> - let ans = EConstr.Vars.substnl subst k c in - return (Value.of_constr ans) -end - -let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> - let ans = EConstr.Vars.substn_vars k ids c in - return (Value.of_constr ans) -end - -let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> - Proofview.tclENV >>= fun env -> - try - let ans = Inductiveops.make_case_info env ind Sorts.Relevant Constr.RegularStyle in - return (Value.of_ext Value.val_case ans) - with e when CErrors.noncritical e -> - throw err_notfound -end - -let () = define2 "constr_constructor" (repr_ext val_inductive) int begin fun (ind, i) k -> - Proofview.tclENV >>= fun env -> - try - let open Declarations in - let ans = Environ.lookup_mind ind env in - let _ = ans.mind_packets.(i).mind_consnames.(k) in - return (Value.of_ext val_constructor ((ind, i), (k + 1))) - with e when CErrors.noncritical e -> - throw err_notfound -end - -let () = define3 "constr_in_context" ident constr closure begin fun id t c -> - Proofview.Goal.goals >>= function - | [gl] -> - gl >>= fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let has_var = - try - let _ = Environ.lookup_named_val id env in - true - with Not_found -> false - in - if has_var then - Tacticals.New.tclZEROMSG (str "Variable already exists") - else - let open Context.Named.Declaration in - let nenv = EConstr.push_named (LocalAssum (Context.make_annot id Sorts.Relevant, t)) env in - let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in - let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> - thaw c >>= fun _ -> - Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> - let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in - let args = Array.of_list (EConstr.mkRel 1 :: args) in - let ans = EConstr.mkEvar (evk, args) in - let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in - return (Value.of_constr ans) - | _ -> - throw err_notfocussed -end - -(** Patterns *) - -let empty_context = EConstr.mkMeta Constr_matching.special_meta - -let () = define0 "pattern_empty_context" begin - return (Value.of_constr empty_context) -end - -let () = define2 "pattern_matches" pattern constr begin fun pat c -> - pf_apply begin fun env sigma -> - let ans = - try Some (Constr_matching.matches env sigma pat c) - with Constr_matching.PatternMatchingFailure -> None - in - begin match ans with - | None -> fail err_matchfailure - | Some ans -> - let ans = Id.Map.bindings ans in - let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - return (Value.of_list of_pair ans) - end - end -end - -let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> - let open Constr_matching in - let rec of_ans s = match IStream.peek s with - | IStream.Nil -> fail err_matchfailure - | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> - let ans = Id.Map.bindings sub in - let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in - let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_list of_pair ans |] in - Proofview.tclOR (return ans) (fun _ -> of_ans s) - in - pf_apply begin fun env sigma -> - let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in - of_ans ans - end -end - -let () = define2 "pattern_matches_vect" pattern constr begin fun pat c -> - pf_apply begin fun env sigma -> - let ans = - try Some (Constr_matching.matches env sigma pat c) - with Constr_matching.PatternMatchingFailure -> None - in - begin match ans with - | None -> fail err_matchfailure - | Some ans -> - let ans = Id.Map.bindings ans in - let ans = Array.map_of_list snd ans in - return (Value.of_array Value.of_constr ans) - end - end -end - -let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c -> - let open Constr_matching in - let rec of_ans s = match IStream.peek s with - | IStream.Nil -> fail err_matchfailure - | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> - let ans = Id.Map.bindings sub in - let ans = Array.map_of_list snd ans in - let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_array Value.of_constr ans |] in - Proofview.tclOR (return ans) (fun _ -> of_ans s) - in - pf_apply begin fun env sigma -> - let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in - of_ans ans - end -end - -let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bool pattern) begin fun rev hp cp -> - assert_focussed >>= fun () -> - Proofview.Goal.enter_one begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let concl = Proofview.Goal.concl gl in - let mk_pattern (b, pat) = if b then Tac2match.MatchPattern pat else Tac2match.MatchContext pat in - let r = (List.map mk_pattern hp, mk_pattern cp) in - Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> - let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in - let hids = Value.of_array Value.of_ident (Array.map_of_list fst hyps) in - let hctx = Value.of_array of_ctxopt (Array.map_of_list snd hyps) in - let subs = Value.of_array Value.of_constr (Array.map_of_list snd (Id.Map.bindings subst)) in - let cctx = of_ctxopt ctx in - let ans = Value.of_tuple [| hids; hctx; subs; cctx |] in - Proofview.tclUNIT ans - end -end - -let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> - let ctx = EConstr.Unsafe.to_constr ctx in - let c = EConstr.Unsafe.to_constr c in - let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in - return (Value.of_constr (EConstr.of_constr ans)) -end - -(** Error *) - -let () = define1 "throw" exn begin fun (e, info) -> - throw ~info e -end - -(** Control *) - -(** exn -> 'a *) -let () = define1 "zero" exn begin fun (e, info) -> - fail ~info e -end - -(** (unit -> 'a) -> (exn -> 'a) -> 'a *) -let () = define2 "plus" closure closure begin fun x k -> - Proofview.tclOR (thaw x) (fun e -> Tac2ffi.apply k [Value.of_exn e]) -end - -(** (unit -> 'a) -> 'a *) -let () = define1 "once" closure begin fun f -> - Proofview.tclONCE (thaw f) -end - -(** (unit -> unit) list -> unit *) -let () = define1 "dispatch" (list closure) begin fun l -> - let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in - Proofview.tclDISPATCH l >>= fun () -> return v_unit -end - -(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) -let () = define3 "extend" (list closure) closure (list closure) begin fun lft tac rgt -> - let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in - let tac = Proofview.tclIGNORE (thaw tac) in - let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in - Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit -end - -(** (unit -> unit) -> unit *) -let () = define1 "enter" closure begin fun f -> - let f = Proofview.tclIGNORE (thaw f) in - Proofview.tclINDEPENDENT f >>= fun () -> return v_unit -end - -(** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) -let () = define1 "case" closure begin fun f -> - Proofview.tclCASE (thaw f) >>= begin function - | Proofview.Next (x, k) -> - let k = Tac2ffi.mk_closure arity_one begin fun e -> - let (e, info) = Value.to_exn e in - set_bt info >>= fun info -> - k (e, info) - end in - return (v_blk 0 [| Value.of_tuple [| x; Value.of_closure k |] |]) - | Proofview.Fail e -> return (v_blk 1 [| Value.of_exn e |]) - end -end - -(** int -> int -> (unit -> 'a) -> 'a *) -let () = define3 "focus" int int closure begin fun i j tac -> - Proofview.tclFOCUS i j (thaw tac) -end - -(** unit -> unit *) -let () = define0 "shelve" begin - Proofview.shelve >>= fun () -> return v_unit -end - -(** unit -> unit *) -let () = define0 "shelve_unifiable" begin - Proofview.shelve_unifiable >>= fun () -> return v_unit -end - -let () = define1 "new_goal" int begin fun ev -> - let ev = Evar.unsafe_of_int ev in - Proofview.tclEVARMAP >>= fun sigma -> - if Evd.mem sigma ev then - Proofview.Unsafe.tclNEWGOALS [Proofview.with_empty_state ev] <*> Proofview.tclUNIT v_unit - else throw err_notfound -end - -(** unit -> constr *) -let () = define0 "goal" begin - assert_focussed >>= fun () -> - Proofview.Goal.enter_one begin fun gl -> - let concl = Tacmach.New.pf_nf_concl gl in - return (Value.of_constr concl) - end -end - -(** ident -> constr *) -let () = define1 "hyp" ident begin fun id -> - pf_apply begin fun env _ -> - let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in - if mem then return (Value.of_constr (EConstr.mkVar id)) - else Tacticals.New.tclZEROMSG - (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (* FIXME: Do something more sensible *) - end -end - -let () = define0 "hyps" begin - pf_apply begin fun env _ -> - let open Context in - let open Named.Declaration in - let hyps = List.rev (Environ.named_context env) in - let map = function - | LocalAssum (id, t) -> - let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr None; Value.of_constr t|] - | LocalDef (id, c, t) -> - let c = EConstr.of_constr c in - let t = EConstr.of_constr t in - Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr (Some c); Value.of_constr t|] - in - return (Value.of_list map hyps) - end -end - -(** (unit -> constr) -> unit *) -let () = define1 "refine" closure begin fun c -> - let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in - Proofview.Goal.enter begin fun gl -> - Refine.generic_refine ~typecheck:true c gl - end >>= fun () -> return v_unit -end - -let () = define2 "with_holes" closure closure begin fun x f -> - Proofview.tclEVARMAP >>= fun sigma0 -> - thaw x >>= fun ans -> - Proofview.tclEVARMAP >>= fun sigma -> - Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> - Tacticals.New.tclWITHHOLES false (Tac2ffi.apply f [ans]) sigma -end - -let () = define1 "progress" closure begin fun f -> - Proofview.tclPROGRESS (thaw f) -end - -let () = define2 "abstract" (option ident) closure begin fun id f -> - Abstract.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> - return v_unit -end - -let () = define2 "time" (option string) closure begin fun s f -> - let s = Option.map Bytes.to_string s in - Proofview.tclTIME s (thaw f) -end - -let () = define0 "check_interrupt" begin - Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit -end - -(** Fresh *) - -let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun set1 set2 -> - let ans = Id.Set.union set1 set2 in - return (Value.of_ext Value.val_free ans) -end - -let () = define1 "fresh_free_of_ids" (list ident) begin fun ids -> - let free = List.fold_right Id.Set.add ids Id.Set.empty in - return (Value.of_ext Value.val_free free) -end - -let () = define1 "fresh_free_of_constr" constr begin fun c -> - Proofview.tclEVARMAP >>= fun sigma -> - let rec fold accu c = match EConstr.kind sigma c with - | Constr.Var id -> Id.Set.add id accu - | _ -> EConstr.fold sigma fold accu c - in - let ans = fold Id.Set.empty c in - return (Value.of_ext Value.val_free ans) -end - -let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> - let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in - return (Value.of_ident nid) -end - -(** Env *) - -let () = define1 "env_get" (list ident) begin fun ids -> - let r = match ids with - | [] -> None - | _ :: _ as ids -> - let (id, path) = List.sep_last ids in - let path = DirPath.make (List.rev path) in - let fp = Libnames.make_path path id in - try Some (Nametab.global_of_path fp) with Not_found -> None - in - return (Value.of_option Value.of_reference r) -end - -let () = define1 "env_expand" (list ident) begin fun ids -> - let r = match ids with - | [] -> [] - | _ :: _ as ids -> - let (id, path) = List.sep_last ids in - let path = DirPath.make (List.rev path) in - let qid = Libnames.make_qualid path id in - Nametab.locate_all qid - in - return (Value.of_list Value.of_reference r) -end - -let () = define1 "env_path" reference begin fun r -> - match Nametab.path_of_global r with - | fp -> - let (path, id) = Libnames.repr_path fp in - let path = DirPath.repr path in - return (Value.of_list Value.of_ident (List.rev_append path [id])) - | exception Not_found -> - throw err_notfound -end - -let () = define1 "env_instantiate" reference begin fun r -> - Proofview.tclENV >>= fun env -> - Proofview.tclEVARMAP >>= fun sigma -> - let (sigma, c) = Evd.fresh_global env sigma r in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - return (Value.of_constr c) -end - -(** Ltac1 in Ltac2 *) - -let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 -let of_ltac1 v = Value.of_ext Value.val_ltac1 v - -let () = define1 "ltac1_ref" (list ident) begin fun ids -> - let open Ltac_plugin in - let r = match ids with - | [] -> raise Not_found - | _ :: _ as ids -> - let (id, path) = List.sep_last ids in - let path = DirPath.make (List.rev path) in - let fp = Libnames.make_path path id in - if Tacenv.exists_tactic fp then - List.hd (Tacenv.locate_extended_all_tactic (Libnames.qualid_of_path fp)) - else raise Not_found - in - let tac = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) (Tacenv.interp_ltac r) in - return (Value.of_ext val_ltac1 tac) -end - -let () = define1 "ltac1_run" ltac1 begin fun v -> - let open Ltac_plugin in - Tacinterp.tactic_of_value (Tacinterp.default_ist ()) v >>= fun () -> - return v_unit -end - -let () = define3 "ltac1_apply" ltac1 (list ltac1) closure begin fun f args k -> - let open Ltac_plugin in - let open Tacexpr in - let open Locus in - let k ret = - Proofview.tclIGNORE (Tac2ffi.apply k [Value.of_ext val_ltac1 ret]) - in - let fold arg (i, vars, lfun) = - let id = Id.of_string ("x" ^ string_of_int i) in - let x = Reference (ArgVar CAst.(make id)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in - Tacinterp.val_interp ist tac k >>= fun () -> - return v_unit -end - -let () = define1 "ltac1_of_constr" constr begin fun c -> - let open Ltac_plugin in - return (Value.of_ext val_ltac1 (Tacinterp.Value.of_constr c)) -end - -let () = define1 "ltac1_to_constr" ltac1 begin fun v -> - let open Ltac_plugin in - return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) -end - -let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> - let open Geninterp.Val in - return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) -end - -let () = define1 "ltac1_to_list" ltac1 begin fun v -> - let open Ltac_plugin in - return (Value.of_option (Value.of_list of_ltac1) (Tacinterp.Value.to_list v)) -end - -(** ML types *) - -let constr_flags () = - let open Pretyping in - { - use_typeclasses = true; - solve_unification_constraints = true; - fail_evar = true; - expand_evars = true; - program_mode = false; - polymorphic = false; - } - -let open_constr_no_classes_flags () = - let open Pretyping in - { - use_typeclasses = false; - solve_unification_constraints = true; - fail_evar = false; - expand_evars = true; - program_mode = false; - polymorphic = false; - } - -(** Embed all Ltac2 data into Values *) -let to_lvar ist = - let open Glob_ops in - let lfun = Tac2interp.set_env ist Id.Map.empty in - { empty_lvar with Ltac_pretype.ltac_genargs = lfun } - -let gtypref kn = GTypRef (Other kn, []) - -let intern_constr self ist c = - let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in - (GlbVal c, gtypref t_constr) - -let catchable_exception = function - | Logic_monad.Exception _ -> false - | e -> CErrors.noncritical e - -let interp_constr flags ist c = - let open Pretyping in - let ist = to_lvar ist in - pf_apply begin fun env sigma -> - try - let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in - let c = Value.of_constr c in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT c - with e when catchable_exception e -> - let (e, info) = CErrors.push e in - set_bt info >>= fun info -> - match Exninfo.get info fatal_flag with - | None -> Proofview.tclZERO ~info e - | Some () -> throw ~info e - end - -let () = - let intern = intern_constr in - let interp ist c = interp_constr (constr_flags ()) ist c in - let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in - let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_constr obj - -let () = - let intern = intern_constr in - let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in - let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in - let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_open_constr obj - -let () = - let interp _ id = return (Value.of_ident id) in - let print _ id = str "ident:(" ++ Id.print id ++ str ")" in - let obj = { - ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); - ml_interp = interp; - ml_subst = (fun _ id -> id); - ml_print = print; - } in - define_ml_object Tac2quote.wit_ident obj - -let () = - let intern self ist c = - let env = ist.Genintern.genv in - let sigma = Evd.from_env env in - let warn = if !Ltac_plugin.Tacintern.strict_check then fun x -> x else Constrintern.for_grammar in - let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in - GlbVal pat, gtypref t_pattern - in - let subst subst c = - let env = Global.env () in - let sigma = Evd.from_env env in - Patternops.subst_pattern env sigma subst c - in - let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in - let interp _ c = return (Value.of_pattern c) in - let obj = { - ml_intern = intern; - ml_interp = interp; - ml_subst = subst; - ml_print = print; - } in - define_ml_object Tac2quote.wit_pattern obj - -let () = - let intern self ist ref = match ref.CAst.v with - | Tac2qexpr.QHypothesis id -> - GlbVal (Globnames.VarRef id), gtypref t_reference - | Tac2qexpr.QReference qid -> - let gr = - try Nametab.locate qid - with Not_found -> - Nametab.error_global_not_found qid - in - GlbVal gr, gtypref t_reference - in - let subst s c = Globnames.subst_global_reference s c in - let interp _ gr = return (Value.of_reference gr) in - let print _ = function - | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" - | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" - in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_reference obj - -let () = - let intern self ist tac = - (* Prevent inner calls to Ltac2 values *) - let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in - let ist = { ist with Genintern.extra } in - let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in - GlbVal tac, gtypref t_unit - in - let interp ist tac = - let ist = { env_ist = Id.Map.empty } in - let lfun = Tac2interp.set_env ist Id.Map.empty in - let ist = Ltac_plugin.Tacinterp.default_ist () in - let ist = { ist with Geninterp.lfun = lfun } in - let tac = (Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in - let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in - Proofview.tclOR tac wrap >>= fun () -> - return v_unit - in - let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in - let print env tac = - str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" - in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_ltac1 obj - -let () = - let open Ltac_plugin in - let intern self ist tac = - (* Prevent inner calls to Ltac2 values *) - let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in - let ist = { ist with Genintern.extra } in - let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in - GlbVal tac, gtypref t_ltac1 - in - let interp ist tac = - let ist = { env_ist = Id.Map.empty } in - let lfun = Tac2interp.set_env ist Id.Map.empty in - let ist = Ltac_plugin.Tacinterp.default_ist () in - let ist = { ist with Geninterp.lfun = lfun } in - return (Value.of_ext val_ltac1 (Tacinterp.Value.of_closure ist tac)) - in - let subst s tac = Genintern.substitute Tacarg.wit_tactic s tac in - let print env tac = - str "ltac1val:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" - in - let obj = { - ml_intern = intern; - ml_subst = subst; - ml_interp = interp; - ml_print = print; - } in - define_ml_object Tac2quote.wit_ltac1val obj - -(** Ltac2 in terms *) - -let () = - let interp ist poly env sigma concl tac = - let ist = Tac2interp.get_env ist in - let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in - let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in - (EConstr.of_constr c, sigma) - in - GlobEnv.register_constr_interp0 wit_ltac2 interp - -let () = - let interp ist poly env sigma concl id = - let ist = Tac2interp.get_env ist in - let c = Id.Map.find id ist.env_ist in - let c = Value.to_constr c in - let sigma = Typing.check env sigma c concl in - (c, sigma) - in - GlobEnv.register_constr_interp0 wit_ltac2_quotation interp - -let () = - let pr_raw id = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in - let pr_glb id = Genprint.PrinterBasic (fun _env _sigma -> str "$" ++ Id.print id) in - let pr_top _ = Genprint.TopPrinterBasic mt in - Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top - -(** Ltac2 in Ltac1 *) - -let () = - let e = Tac2entries.Pltac.tac2expr in - let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in - Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) - -let () = - let open Ltac_plugin in - let open Tacinterp in - let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in - let interp ist tac = -(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) - let ist = { env_ist = Id.Map.empty } in - Tac2interp.interp ist tac >>= fun _ -> - Ftactic.return idtac - in - Geninterp.register_interp0 wit_ltac2 interp - -let () = - let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in - let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in - let pr_top _ = Genprint.TopPrinterBasic mt in - Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top - -(** Built-in notation scopes *) - -let add_scope s f = - Tac2entries.register_scope (Id.of_string s) f - -let rec pr_scope = let open CAst in function -| SexprStr {v=s} -> qstring s -| SexprInt {v=n} -> Pp.int n -| SexprRec (_, {v=na}, args) -> - let na = match na with - | None -> str "_" - | Some id -> Id.print id - in - na ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" - -let scope_fail s args = - let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in - CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) - -let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) - -let add_generic_scope s entry arg = - let parse = function - | [] -> - let scope = Extend.Aentry entry in - let act x = CAst.make @@ CTacExt (arg, x) in - Tac2entries.ScopeRule (scope, act) - | arg -> scope_fail s arg - in - add_scope s parse - -open CAst - -let () = add_scope "keyword" begin function -| [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (Tok.PKEYWORD s) in - Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) -| arg -> scope_fail "keyword" arg -end - -let () = add_scope "terminal" begin function -| [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (CLexer.terminal s) in - Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) -| arg -> scope_fail "terminal" arg -end - -let () = add_scope "list0" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist0 scope in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr {v=str}] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist0sep (scope, sep) in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "list0" arg -end - -let () = add_scope "list1" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist1 scope in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| [tok; SexprStr {v=str}] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist1sep (scope, sep) in - let act l = Tac2quote.of_list act l in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "list1" arg -end - -let () = add_scope "opt" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Aopt scope in - let act opt = match opt with - | None -> - CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) - | Some x -> - CAst.make @@ CTacApp (CAst.make @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) - in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "opt" arg -end - -let () = add_scope "self" begin function -| [] -> - let scope = Extend.Aself in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "self" arg -end - -let () = add_scope "next" begin function -| [] -> - let scope = Extend.Anext in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "next" arg -end - -let () = add_scope "tactic" begin function -| [] -> - (* Default to level 5 parsing *) - let scope = Extend.Aentryl (tac2expr, "5") in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| [SexprInt {loc;v=n}] as arg -> - let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Extend.Aentryl (tac2expr, string_of_int n) in - let act tac = tac in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "tactic" arg -end - -let () = add_scope "thunk" begin function -| [tok] -> - let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let act e = Tac2quote.thunk (act e) in - Tac2entries.ScopeRule (scope, act) -| arg -> scope_fail "thunk" arg -end - -let add_expr_scope name entry f = - add_scope name begin function - | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) - | arg -> scope_fail name arg - end - -let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) -let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings -let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings -let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern -let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns -let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg -let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause -let () = add_expr_scope "conversion" q_conversion Tac2quote.of_conversion -let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting -let () = add_expr_scope "clause" q_clause Tac2quote.of_clause -let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb -let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences -let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch -let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag -let () = add_expr_scope "reference" q_reference Tac2quote.of_reference -let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location -let () = add_expr_scope "pose" q_pose Tac2quote.of_pose -let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion -let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching -let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching - -let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr -let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr -let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern - -(** seq scope, a bit hairy *) - -open Extend -exception SelfSymbol - -let rec generalize_symbol : - type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function -| Atoken tok -> Atoken tok -| Alist1 e -> Alist1 (generalize_symbol e) -| Alist1sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist1sep (e, sep) -| Alist0 e -> Alist0 (generalize_symbol e) -| Alist0sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist0sep (e, sep) -| Aopt e -> Aopt (generalize_symbol e) -| Aself -> raise SelfSymbol -| Anext -> raise SelfSymbol -| Aentry e -> Aentry e -| Aentryl (e, l) -> Aentryl (e, l) -| Arules r -> Arules r - -type _ converter = -| CvNil : (Loc.t -> raw_tacexpr) converter -| CvCns : 'act converter * ('a -> raw_tacexpr) option -> ('a -> 'act) converter - -let rec apply : type a. a converter -> raw_tacexpr list -> a = function -| CvNil -> fun accu loc -> Tac2quote.of_tuple ~loc accu -| CvCns (c, None) -> fun accu x -> apply c accu -| CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) - -type seqrule = -| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule - -let rec make_seq_rule = function -| [] -> - Seqrule (Stop, CvNil) -| tok :: rem -> - let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in - let scope = generalize_symbol scope in - let Seqrule (r, c) = make_seq_rule rem in - let r = NextNoRec (r, scope) in - let f = match tok with - | SexprStr _ -> None (* Leave out mere strings *) - | _ -> Some f - in - Seqrule (r, CvCns (c, f)) - -let () = add_scope "seq" begin fun toks -> - let scope = - try - let Seqrule (r, c) = make_seq_rule (List.rev toks) in - Arules [Rules (r, apply c [])] - with SelfSymbol -> - CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") - in - Tac2entries.ScopeRule (scope, (fun e -> e)) -end diff --git a/vendor/Ltac2/src/tac2core.mli b/vendor/Ltac2/src/tac2core.mli deleted file mode 100644 index 9fae65bb3e..0000000000 --- a/vendor/Ltac2/src/tac2core.mli +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/vendor/Ltac2/src/tac2dyn.ml b/vendor/Ltac2/src/tac2dyn.ml deleted file mode 100644 index 896676f08b..0000000000 --- a/vendor/Ltac2/src/tac2dyn.ml +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('raw * 'glb) pack - include Arg.Map(struct type 'a t = 'a pack end) -end - -module Val = Dyn.Make(struct end) diff --git a/vendor/Ltac2/src/tac2dyn.mli b/vendor/Ltac2/src/tac2dyn.mli deleted file mode 100644 index e995296840..0000000000 --- a/vendor/Ltac2/src/tac2dyn.mli +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('a, 'b) tag - val eq : ('a1, 'b1) tag -> ('a2, 'b2) tag -> ('a1 * 'b1, 'a2 * 'b2) CSig.eq option - val repr : ('a, 'b) tag -> string -end -(** Arguments that are part of an AST. *) - -module type Param = sig type ('raw, 'glb) t end - -module ArgMap (M : Param) : -sig - type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack - type t - val empty : t - val add : ('a, 'b) Arg.tag -> ('a * 'b) pack -> t -> t - val remove : ('a, 'b) Arg.tag -> t -> t - val find : ('a, 'b) Arg.tag -> t -> ('a * 'b) pack - val mem : ('a, 'b) Arg.tag -> t -> bool -end - -module Val : Dyn.S -(** Toplevel values *) diff --git a/vendor/Ltac2/src/tac2entries.ml b/vendor/Ltac2/src/tac2entries.ml deleted file mode 100644 index 9fd01426de..0000000000 --- a/vendor/Ltac2/src/tac2entries.ml +++ /dev/null @@ -1,938 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = - declare_object {(default_object "TAC2-DEFINITION") with - cache_function = cache_tacdef; - load_function = load_tacdef; - open_function = open_tacdef; - subst_function = subst_tacdef; - classify_function = classify_tacdef} - -(** Type definition *) - -type typdef = { - typdef_local : bool; - typdef_expr : glb_quant_typedef; -} - -let change_kn_label kn id = - let mp = KerName.modpath kn in - KerName.make mp (Label.of_id id) - -let change_sp_label sp id = - let (dp, _) = Libnames.repr_path sp in - Libnames.make_path dp id - -let push_typedef visibility sp kn (_, def) = match def with -| GTydDef _ -> - Tac2env.push_type visibility sp kn -| GTydAlg { galg_constructors = cstrs } -> - (* Register constructors *) - let iter (c, _) = - let spc = change_sp_label sp c in - let knc = change_kn_label kn c in - Tac2env.push_constructor visibility spc knc - in - Tac2env.push_type visibility sp kn; - List.iter iter cstrs -| GTydRec fields -> - (* Register fields *) - let iter (c, _, _) = - let spc = change_sp_label sp c in - let knc = change_kn_label kn c in - Tac2env.push_projection visibility spc knc - in - Tac2env.push_type visibility sp kn; - List.iter iter fields -| GTydOpn -> - Tac2env.push_type visibility sp kn - -let next i = - let ans = !i in - let () = incr i in - ans - -let define_typedef kn (params, def as qdef) = match def with -| GTydDef _ -> - Tac2env.define_type kn qdef -| GTydAlg { galg_constructors = cstrs } -> - (* Define constructors *) - let constant = ref 0 in - let nonconstant = ref 0 in - let iter (c, args) = - let knc = change_kn_label kn c in - let tag = if List.is_empty args then next constant else next nonconstant in - let data = { - Tac2env.cdata_prms = params; - cdata_type = kn; - cdata_args = args; - cdata_indx = Some tag; - } in - Tac2env.define_constructor knc data - in - Tac2env.define_type kn qdef; - List.iter iter cstrs -| GTydRec fs -> - (* Define projections *) - let iter i (id, mut, t) = - let knp = change_kn_label kn id in - let proj = { - Tac2env.pdata_prms = params; - pdata_type = kn; - pdata_ptyp = t; - pdata_mutb = mut; - pdata_indx = i; - } in - Tac2env.define_projection knp proj - in - Tac2env.define_type kn qdef; - List.iteri iter fs -| GTydOpn -> - Tac2env.define_type kn qdef - -let perform_typdef vs ((sp, kn), def) = - let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in - define_typedef kn def.typdef_expr - -let load_typdef i obj = perform_typdef (Until i) obj -let open_typdef i obj = perform_typdef (Exactly i) obj - -let cache_typdef ((sp, kn), def) = - let () = push_typedef (Until 1) sp kn def.typdef_expr in - define_typedef kn def.typdef_expr - -let subst_typdef (subst, def) = - let expr' = subst_quant_typedef subst def.typdef_expr in - if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } - -let classify_typdef o = Substitute o - -let inTypDef : typdef -> obj = - declare_object {(default_object "TAC2-TYPE-DEFINITION") with - cache_function = cache_typdef; - load_function = load_typdef; - open_function = open_typdef; - subst_function = subst_typdef; - classify_function = classify_typdef} - -(** Type extension *) - -type extension_data = { - edata_name : Id.t; - edata_args : int glb_typexpr list; -} - -type typext = { - typext_local : bool; - typext_prms : int; - typext_type : type_constant; - typext_expr : extension_data list; -} - -let push_typext vis sp kn def = - let iter data = - let spc = change_sp_label sp data.edata_name in - let knc = change_kn_label kn data.edata_name in - Tac2env.push_constructor vis spc knc - in - List.iter iter def.typext_expr - -let define_typext kn def = - let iter data = - let knc = change_kn_label kn data.edata_name in - let cdata = { - Tac2env.cdata_prms = def.typext_prms; - cdata_type = def.typext_type; - cdata_args = data.edata_args; - cdata_indx = None; - } in - Tac2env.define_constructor knc cdata - in - List.iter iter def.typext_expr - -let cache_typext ((sp, kn), def) = - let () = define_typext kn def in - push_typext (Until 1) sp kn def - -let perform_typext vs ((sp, kn), def) = - let () = if not def.typext_local then push_typext vs sp kn def in - define_typext kn def - -let load_typext i obj = perform_typext (Until i) obj -let open_typext i obj = perform_typext (Exactly i) obj - -let subst_typext (subst, e) = - let open Mod_subst in - let subst_data data = - let edata_args = List.Smart.map (fun e -> subst_type subst e) data.edata_args in - if edata_args == data.edata_args then data - else { data with edata_args } - in - let typext_type = subst_kn subst e.typext_type in - let typext_expr = List.Smart.map subst_data e.typext_expr in - if typext_type == e.typext_type && typext_expr == e.typext_expr then - e - else - { e with typext_type; typext_expr } - -let classify_typext o = Substitute o - -let inTypExt : typext -> obj = - declare_object {(default_object "TAC2-TYPE-EXTENSION") with - cache_function = cache_typext; - load_function = load_typext; - open_function = open_typext; - subst_function = subst_typext; - classify_function = classify_typext} - -(** Toplevel entries *) - -let fresh_var avoid x = - let bad id = - Id.Set.mem id avoid || - (try ignore (Tac2env.locate_ltac (qualid_of_ident id)); true with Not_found -> false) - in - Namegen.next_ident_away_from (Id.of_string x) bad - -let extract_pattern_type ({loc;v=p} as pat) = match p with -| CPatCnv (pat, ty) -> pat, Some ty -| CPatVar _ | CPatRef _ -> pat, None - -(** Mangle recursive tactics *) -let inline_rec_tactic tactics = - let avoid = List.fold_left (fun accu ({v=id}, _) -> Id.Set.add id accu) Id.Set.empty tactics in - let map (id, e) = match e.v with - | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) - | _ -> - user_err ?loc:id.loc (str "Recursive tactic definitions must be functions") - in - let tactics = List.map map tactics in - let map (id, pat, e) = - let fold_var (avoid, ans) (pat, _) = - let id = fresh_var avoid "x" in - let loc = pat.loc in - (Id.Set.add id avoid, CAst.make ?loc id :: ans) - in - (* Fresh variables to abstract over the function patterns *) - let _, vars = List.fold_left fold_var (avoid, []) pat in - let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in - let bnd = List.map map_body tactics in - let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in - let var_of_id {loc;v=id} = - let qid = qualid_of_ident ?loc id in - CAst.make ?loc @@ CTacRef (RelId qid) - in - let loc0 = e.loc in - let vpat = List.map pat_of_id vars in - let varg = List.map var_of_id vars in - let e = CAst.make ?loc:loc0 @@ CTacLet (true, bnd, CAst.make ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in - (id, CAst.make ?loc:loc0 @@ CTacFun (vpat, e)) - in - List.map map tactics - -let check_lowercase {loc;v=id} = - if Tac2env.is_constructor (Libnames.qualid_of_ident id) then - user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") - -let register_ltac ?(local = false) ?(mut = false) isrec tactics = - let map ({loc;v=na}, e) = - let id = match na with - | Anonymous -> - user_err ?loc (str "Tactic definition must have a name") - | Name id -> id - in - let () = check_lowercase CAst.(make ?loc id) in - (CAst.(make ?loc id), e) - in - let tactics = List.map map tactics in - let tactics = - if isrec then inline_rec_tactic tactics else tactics - in - let map ({loc;v=id}, e) = - let (e, t) = intern ~strict:true e in - let () = - if not (is_value e) then - user_err ?loc (str "Tactic definition must be a syntactical value") - in - let kn = Lib.make_kn id in - let exists = - try let _ = Tac2env.interp_global kn in true with Not_found -> false - in - let () = - if exists then - user_err ?loc (str "Tactic " ++ Names.Id.print id ++ str " already exists") - in - (id, e, t) - in - let defs = List.map map tactics in - let iter (id, e, t) = - let def = { - tacdef_local = local; - tacdef_mutable = mut; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) - in - List.iter iter defs - -let qualid_to_ident qid = - if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid - else user_err ?loc:qid.CAst.loc (str "Identifier expected") - -let register_typedef ?(local = false) isrec types = - let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name types with - | [] -> () - | ({loc;v=id}, _) :: _ -> - user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) - in - let check ({loc;v=id}, (params, def)) = - let same_name {v=id1} {v=id2} = Id.equal id1 id2 in - let () = match List.duplicates same_name params with - | [] -> () - | {loc;v=id} :: _ -> - user_err ?loc (str "The type parameter " ++ Id.print id ++ - str " occurs several times") - in - match def with - | CTydDef _ -> - if isrec then - user_err ?loc (str "The type abbreviation " ++ Id.print id ++ - str " cannot be recursive") - | CTydAlg cs -> - let same_name (id1, _) (id2, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name cs with - | [] -> () - | (id, _) :: _ -> - user_err (str "Multiple definitions of the constructor " ++ Id.print id) - in - () - | CTydRec ps -> - let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in - let () = match List.duplicates same_name ps with - | [] -> () - | (id, _, _) :: _ -> - user_err (str "Multiple definitions of the projection " ++ Id.print id) - in - () - | CTydOpn -> - if isrec then - user_err ?loc (str "The open type declaration " ++ Id.print id ++ - str " cannot be recursive") - in - let () = List.iter check types in - let self = - if isrec then - let fold accu ({v=id}, (params, _)) = - Id.Map.add id (Lib.make_kn id, List.length params) accu - in - List.fold_left fold Id.Map.empty types - else Id.Map.empty - in - let map ({v=id}, def) = - let typdef = { - typdef_local = local; - typdef_expr = intern_typedef self def; - } in - (id, typdef) - in - let types = List.map map types in - let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in - List.iter iter types - -let register_primitive ?(local = false) {loc;v=id} t ml = - let t = intern_open_type t in - let rec count_arrow = function - | GTypArrow (_, t) -> 1 + count_arrow t - | _ -> 0 - in - let arrows = count_arrow (snd t) in - let () = if Int.equal arrows 0 then - user_err ?loc (str "External tactic must have at least one argument") in - let () = - try let _ = Tac2env.interp_primitive ml in () with Not_found -> - user_err ?loc (str "Unregistered primitive " ++ - quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) - in - let init i = Id.of_string (Printf.sprintf "x%i" i) in - let names = List.init arrows init in - let bnd = List.map (fun id -> Name id) names in - let arg = List.map (fun id -> GTacVar id) names in - let e = GTacFun (bnd, GTacPrm (ml, arg)) in - let def = { - tacdef_local = local; - tacdef_mutable = false; - tacdef_expr = e; - tacdef_type = t; - } in - ignore (Lib.add_leaf id (inTacDef def)) - -let register_open ?(local = false) qid (params, def) = - let kn = - try Tac2env.locate_type qid - with Not_found -> - user_err ?loc:qid.CAst.loc (str "Unbound type " ++ pr_qualid qid) - in - let (tparams, t) = Tac2env.interp_type kn in - let () = match t with - | GTydOpn -> () - | GTydAlg _ | GTydRec _ | GTydDef _ -> - user_err ?loc:qid.CAst.loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") - in - let () = - if not (Int.equal (List.length params) tparams) then - Tac2intern.error_nparams_mismatch ?loc:qid.CAst.loc (List.length params) tparams - in - match def with - | CTydOpn -> () - | CTydAlg def -> - let intern_type t = - let tpe = CTydDef (Some t) in - let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in - match ans with - | GTydDef (Some t) -> t - | _ -> assert false - in - let map (id, tpe) = - let tpe = List.map intern_type tpe in - { edata_name = id; edata_args = tpe } - in - let def = List.map map def in - let def = { - typext_local = local; - typext_type = kn; - typext_prms = tparams; - typext_expr = def; - } in - Lib.add_anonymous_leaf (inTypExt def) - | CTydRec _ | CTydDef _ -> - user_err ?loc:qid.CAst.loc (str "Extensions only accept inductive constructors") - -let register_type ?local isrec types = match types with -| [qid, true, def] -> - let () = if isrec then user_err ?loc:qid.CAst.loc (str "Extensions cannot be recursive") in - register_open ?local qid def -| _ -> - let map (qid, redef, def) = - let () = if redef then - user_err ?loc:qid.loc (str "Types can only be extended one by one") - in - (qualid_to_ident qid, def) - in - let types = List.map map types in - register_typedef ?local isrec types - -(** Parsing *) - -type 'a token = -| TacTerm of string -| TacNonTerm of Name.t * 'a - -type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule - -type scope_interpretation = sexpr list -> scope_rule - -let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty - -let register_scope id s = - scope_table := Id.Map.add id s !scope_table - -module ParseToken = -struct - -let loc_of_token = function -| SexprStr {loc} -> loc -| SexprInt {loc} -> loc -| SexprRec (loc, _, _) -> Some loc - -let parse_scope = function -| SexprRec (_, {loc;v=Some id}, toks) -> - if Id.Map.mem id !scope_table then - Id.Map.find id !scope_table toks - else - CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) -| SexprStr {v=str} -> - let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in - ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) -| tok -> - let loc = loc_of_token tok in - CErrors.user_err ?loc (str "Invalid parsing token") - -let parse_token = function -| SexprStr {v=s} -> TacTerm s -| SexprRec (_, {v=na}, [tok]) -> - let na = match na with None -> Anonymous | Some id -> Name id in - let scope = parse_scope tok in - TacNonTerm (na, scope) -| tok -> - let loc = loc_of_token tok in - CErrors.user_err ?loc (str "Invalid parsing token") - -end - -let parse_scope = ParseToken.parse_scope - -type synext = { - synext_tok : sexpr list; - synext_exp : raw_tacexpr; - synext_lev : int option; - synext_loc : bool; -} - -type krule = -| KRule : - (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * - ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule - -let rec get_rule (tok : scope_rule token list) : krule = match tok with -| [] -> KRule (Extend.Stop, fun k loc -> k loc []) -| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> - let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, scope) in - let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in - KRule (rule, act) -| TacTerm t :: tok -> - let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in - let act k _ = act k in - KRule (rule, act) - -let perform_notation syn st = - let tok = List.rev_map ParseToken.parse_token syn.synext_tok in - let KRule (rule, act) = get_rule tok in - let mk loc args = - let map (na, e) = - ((CAst.make ?loc:e.loc @@ CPatVar na), e) - in - let bnd = List.map map args in - CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) - in - let rule = Extend.Rule (rule, act mk) in - let lev = match syn.synext_lev with - | None -> None - | Some lev -> Some (string_of_int lev) - in - let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) - -let ltac2_notation = - Pcoq.create_grammar_command "ltac2-notation" perform_notation - -let cache_synext (_, syn) = - Pcoq.extend_grammar_command ltac2_notation syn - -let open_synext i (_, syn) = - if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn - -let subst_synext (subst, syn) = - let e = Tac2intern.subst_rawexpr subst syn.synext_exp in - if e == syn.synext_exp then syn else { syn with synext_exp = e } - -let classify_synext o = - if o.synext_loc then Dispose else Substitute o - -let inTac2Notation : synext -> obj = - declare_object {(default_object "TAC2-NOTATION") with - cache_function = cache_synext; - open_function = open_synext; - subst_function = subst_synext; - classify_function = classify_synext} - -type abbreviation = { - abbr_body : raw_tacexpr; -} - -let perform_abbreviation visibility ((sp, kn), abbr) = - let () = Tac2env.push_ltac visibility sp (TacAlias kn) in - Tac2env.define_alias kn abbr.abbr_body - -let load_abbreviation i obj = perform_abbreviation (Until i) obj -let open_abbreviation i obj = perform_abbreviation (Exactly i) obj - -let cache_abbreviation ((sp, kn), abbr) = - let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in - Tac2env.define_alias kn abbr.abbr_body - -let subst_abbreviation (subst, abbr) = - let body' = subst_rawexpr subst abbr.abbr_body in - if body' == abbr.abbr_body then abbr - else { abbr_body = body' } - -let classify_abbreviation o = Substitute o - -let inTac2Abbreviation : abbreviation -> obj = - declare_object {(default_object "TAC2-ABBREVIATION") with - cache_function = cache_abbreviation; - load_function = load_abbreviation; - open_function = open_abbreviation; - subst_function = subst_abbreviation; - classify_function = classify_abbreviation} - -let register_notation ?(local = false) tkn lev body = match tkn, lev with -| [SexprRec (_, {loc;v=Some id}, [])], None -> - (* Tactic abbreviation *) - let () = check_lowercase CAst.(make ?loc id) in - let body = Tac2intern.globalize Id.Set.empty body in - let abbr = { abbr_body = body } in - ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) -| _ -> - (* Check that the tokens make sense *) - let entries = List.map ParseToken.parse_token tkn in - let fold accu tok = match tok with - | TacTerm _ -> accu - | TacNonTerm (Name id, _) -> Id.Set.add id accu - | TacNonTerm (Anonymous, _) -> accu - in - let ids = List.fold_left fold Id.Set.empty entries in - (* Globalize so that names are absolute *) - let body = Tac2intern.globalize ids body in - let lev = match lev with Some _ -> lev | None -> Some 5 in - let ext = { - synext_tok = tkn; - synext_exp = body; - synext_lev = lev; - synext_loc = local; - } in - Lib.add_anonymous_leaf (inTac2Notation ext) - -type redefinition = { - redef_kn : ltac_constant; - redef_body : glb_tacexpr; -} - -let perform_redefinition (_, redef) = - let kn = redef.redef_kn in - let data = Tac2env.interp_global kn in - let data = { data with Tac2env.gdata_expr = redef.redef_body } in - Tac2env.define_global kn data - -let subst_redefinition (subst, redef) = - let kn = Mod_subst.subst_kn subst redef.redef_kn in - let body = Tac2intern.subst_expr subst redef.redef_body in - if kn == redef.redef_kn && body == redef.redef_body then redef - else { redef_kn = kn; redef_body = body } - -let classify_redefinition o = Substitute o - -let inTac2Redefinition : redefinition -> obj = - declare_object {(default_object "TAC2-REDEFINITION") with - cache_function = perform_redefinition; - open_function = (fun _ -> perform_redefinition); - subst_function = subst_redefinition; - classify_function = classify_redefinition } - -let register_redefinition ?(local = false) qid e = - let kn = - try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) - in - let kn = match kn with - | TacConstant kn -> kn - | TacAlias _ -> - user_err ?loc:qid.CAst.loc (str "Cannot redefine syntactic abbreviations") - in - let data = Tac2env.interp_global kn in - let () = - if not (data.Tac2env.gdata_mutable) then - user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") - in - let (e, t) = intern ~strict:true e in - let () = - if not (is_value e) then - user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") - in - let () = - if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then - let name = int_name () in - user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ - str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) - in - let def = { - redef_kn = kn; - redef_body = e; - } in - Lib.add_anonymous_leaf (inTac2Redefinition def) - -let perform_eval ~pstate e = - let open Proofview.Notations in - let env = Global.env () in - let (e, ty) = Tac2intern.intern ~strict:false e in - let v = Tac2interp.interp Tac2interp.empty_environment e in - let selector, proof = - match pstate with - | None -> - let sigma = Evd.from_env env in - let name, poly = Id.of_string "ltac2", false in - Goal_select.SelectAll, Proof.start ~name ~poly sigma [] - | Some pstate -> - Goal_select.get_default_goal_selector (), - Proof_global.give_me_the_proof pstate - in - let v = match selector with - | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v - | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v - | Goal_select.SelectId id -> Proofview.tclFOCUSID id v - | Goal_select.SelectAll -> v - | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) - in - (* HACK: the API doesn't allow to return a value *) - let ans = ref None in - let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in - let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in - let sigma = Proof.in_proof proof (fun sigma -> sigma) in - let ans = match !ans with None -> assert false | Some r -> r in - let name = int_name () in - Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) - ++ spc () ++ str "=" ++ spc () ++ - Tac2print.pr_valexpr env sigma ans (snd ty)) - -(** Toplevel entries *) - -let register_struct ?local ~pstate str = match str with -| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e -| StrTyp (isrec, t) -> register_type ?local isrec t -| StrPrm (id, t, ml) -> register_primitive ?local id t ml -| StrSyn (tok, lev, e) -> register_notation ?local tok lev e -| StrMut (qid, e) -> register_redefinition ?local qid e -| StrRun e -> perform_eval ~pstate e - -(** Toplevel exception *) - -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "print Ltac2 backtrace"; - Goptions.optkey = ["Ltac2"; "Backtrace"]; - Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); - Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); -} - -let backtrace : backtrace Exninfo.t = Exninfo.make () - -let pr_frame = function -| FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" -| FrLtac kn -> - str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) -| FrPrim ml -> - str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" -| FrExtn (tag, arg) -> - let obj = Tac2env.interp_ml_object tag in - str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ - obj.Tac2env.ml_print (Global.env ()) arg - -let () = register_handler begin function -| Tac2interp.LtacError (kn, args) -> - let t_exn = KerName.make Tac2env.coq_prefix (Label.make "exn") in - let v = Tac2ffi.of_open (kn, args) in - let t = GTypRef (Other t_exn, []) in - let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in - hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) -| _ -> raise Unhandled -end - -let () = ExplainErr.register_additional_error_info begin fun (e, info) -> - if !Tac2interp.print_ltac2_backtrace then - let bt = Exninfo.get info backtrace in - let bt = match bt with - | Some bt -> bt - | None -> raise Exit - in - let bt = - str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () - in - Some (Loc.tag @@ Some bt) - else raise Exit -end - -(** Printing *) - -let print_ltac qid = - if Tac2env.is_constructor qid then - let kn = - try Tac2env.locate_constructor qid - with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown constructor " ++ pr_qualid qid) - in - let _ = Tac2env.interp_constructor kn in - Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) - else - let kn = - try Tac2env.locate_ltac qid - with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) - in - match kn with - | TacConstant kn -> - let data = Tac2env.interp_global kn in - let e = data.Tac2env.gdata_expr in - let (_, t) = data.Tac2env.gdata_type in - let name = int_name () in - Feedback.msg_notice ( - hov 0 ( - hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ - hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) - ) - ) - | TacAlias kn -> - Feedback.msg_notice (str "Alias to ...") - -(** Calling tactics *) - -let solve ~pstate default tac = - let pstate, status = Proof_global.with_current_proof begin fun etac p -> - let with_end_tac = if default then Some etac else None in - let g = Goal_select.get_default_goal_selector () in - let (p, status) = Pfedit.solve g None tac ?with_end_tac p in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p, status - end pstate in - if not status then Feedback.feedback Feedback.AddedAxiom; - pstate - -let call ~pstate ~default e = - let loc = e.loc in - let (e, t) = intern ~strict:false e in - let () = check_unit ?loc t in - let tac = Tac2interp.interp Tac2interp.empty_environment e in - solve ~pstate default (Proofview.tclIGNORE tac) - -(** Primitive algebraic types than can't be defined Coq-side *) - -let register_prim_alg name params def = - let id = Id.of_string name in - let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in - let getn (const, nonconst) (c, args) = match args with - | [] -> (succ const, nonconst) - | _ :: _ -> (const, succ nonconst) - in - let nconst, nnonconst = List.fold_left getn (0, 0) def in - let alg = { - galg_constructors = def; - galg_nconst = nconst; - galg_nnonconst = nnonconst; - } in - let def = (params, GTydAlg alg) in - let def = { typdef_local = false; typdef_expr = def } in - ignore (Lib.add_leaf id (inTypDef def)) - -let coq_def n = KerName.make Tac2env.coq_prefix (Label.make n) - -let def_unit = { - typdef_local = false; - typdef_expr = 0, GTydDef (Some (GTypRef (Tuple 0, []))); -} - -let t_list = coq_def "list" - -let (f_register_constr_quotations, register_constr_quotations) = Hook.make () - -let cache_ltac2_init (_, ()) = - Hook.get f_register_constr_quotations () - -let load_ltac2_init _ (_, ()) = - Hook.get f_register_constr_quotations () - -let open_ltac2_init _ (_, ()) = - Goptions.set_string_option_value_gen ["Default"; "Proof"; "Mode"] "Ltac2" - -(** Dummy object that register global rules when Require is called *) -let inTac2Init : unit -> obj = - declare_object {(default_object "TAC2-INIT") with - cache_function = cache_ltac2_init; - load_function = load_ltac2_init; - open_function = open_ltac2_init; - } - -let _ = Mltop.declare_cache_obj begin fun () -> - ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); - register_prim_alg "list" 1 [ - ("[]", []); - ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); - ]; - Lib.add_anonymous_leaf (inTac2Init ()); -end "ltac2_plugin" diff --git a/vendor/Ltac2/src/tac2entries.mli b/vendor/Ltac2/src/tac2entries.mli deleted file mode 100644 index d493192bb3..0000000000 --- a/vendor/Ltac2/src/tac2entries.mli +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?mut:bool -> rec_flag -> - (Names.lname * raw_tacexpr) list -> unit - -val register_type : ?local:bool -> rec_flag -> - (qualid * redef_flag * raw_quant_typedef) list -> unit - -val register_primitive : ?local:bool -> - Names.lident -> raw_typexpr -> ml_tactic_name -> unit - -val register_struct - : ?local:bool - -> pstate:Proof_global.t option - -> strexpr - -> unit - -val register_notation : ?local:bool -> sexpr list -> int option -> - raw_tacexpr -> unit - -(** {5 Notations} *) - -type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule - -type scope_interpretation = sexpr list -> scope_rule - -val register_scope : Id.t -> scope_interpretation -> unit -(** Create a new scope with the provided name *) - -val parse_scope : sexpr -> scope_rule -(** Use this to interpret the subscopes for interpretation functions *) - -(** {5 Inspecting} *) - -val print_ltac : Libnames.qualid -> unit - -(** {5 Eval loop} *) - -(** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t - -(** {5 Toplevel exceptions} *) - -val backtrace : backtrace Exninfo.t - -(** {5 Parsing entries} *) - -module Pltac : -sig -val tac2expr : raw_tacexpr Pcoq.Entry.t - -(** Quoted entries. To be used for complex notations. *) - -open Tac2qexpr - -val q_ident : Id.t CAst.t or_anti Pcoq.Entry.t -val q_bindings : bindings Pcoq.Entry.t -val q_with_bindings : bindings Pcoq.Entry.t -val q_intropattern : intro_pattern Pcoq.Entry.t -val q_intropatterns : intro_pattern list CAst.t Pcoq.Entry.t -val q_destruction_arg : destruction_arg Pcoq.Entry.t -val q_induction_clause : induction_clause Pcoq.Entry.t -val q_conversion : conversion Pcoq.Entry.t -val q_rewriting : rewriting Pcoq.Entry.t -val q_clause : clause Pcoq.Entry.t -val q_dispatch : dispatch Pcoq.Entry.t -val q_occurrences : occurrences Pcoq.Entry.t -val q_reference : reference or_anti Pcoq.Entry.t -val q_strategy_flag : strategy_flag Pcoq.Entry.t -val q_constr_matching : constr_matching Pcoq.Entry.t -val q_goal_matching : goal_matching Pcoq.Entry.t -val q_hintdb : hintdb Pcoq.Entry.t -val q_move_location : move_location Pcoq.Entry.t -val q_pose : pose Pcoq.Entry.t -val q_assert : assertion Pcoq.Entry.t -end - -(** {5 Hooks} *) - -val register_constr_quotations : (unit -> unit) Hook.t diff --git a/vendor/Ltac2/src/tac2env.ml b/vendor/Ltac2/src/tac2env.ml deleted file mode 100644 index 93ad57e97e..0000000000 --- a/vendor/Ltac2/src/tac2env.ml +++ /dev/null @@ -1,298 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* KerName.compare c1 c2 -| TacAlias c1, TacAlias c2 -> KerName.compare c1 c2 -| TacConstant _, TacAlias _ -> -1 -| TacAlias _, TacConstant _ -> 1 - -let equal r1 r2 = compare r1 r2 == 0 - -end - -module KnTab = Nametab.Make(FullPath)(KerName) -module RfTab = Nametab.Make(FullPath)(TacRef) -module RfMap = Map.Make(TacRef) - -type nametab = { - tab_ltac : RfTab.t; - tab_ltac_rev : full_path RfMap.t; - tab_cstr : KnTab.t; - tab_cstr_rev : full_path KNmap.t; - tab_type : KnTab.t; - tab_type_rev : full_path KNmap.t; - tab_proj : KnTab.t; - tab_proj_rev : full_path KNmap.t; -} - -let empty_nametab = { - tab_ltac = RfTab.empty; - tab_ltac_rev = RfMap.empty; - tab_cstr = KnTab.empty; - tab_cstr_rev = KNmap.empty; - tab_type = KnTab.empty; - tab_type_rev = KNmap.empty; - tab_proj = KnTab.empty; - tab_proj_rev = KNmap.empty; -} - -let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" - -let push_ltac vis sp kn = - let tab = !nametab in - let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in - let tab_ltac_rev = RfMap.add kn sp tab.tab_ltac_rev in - nametab := { tab with tab_ltac; tab_ltac_rev } - -let locate_ltac qid = - let tab = !nametab in - RfTab.locate qid tab.tab_ltac - -let locate_extended_all_ltac qid = - let tab = !nametab in - RfTab.find_prefixes qid tab.tab_ltac - -let shortest_qualid_of_ltac kn = - let tab = !nametab in - let sp = RfMap.find kn tab.tab_ltac_rev in - RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac - -let push_constructor vis sp kn = - let tab = !nametab in - let tab_cstr = KnTab.push vis sp kn tab.tab_cstr in - let tab_cstr_rev = KNmap.add kn sp tab.tab_cstr_rev in - nametab := { tab with tab_cstr; tab_cstr_rev } - -let locate_constructor qid = - let tab = !nametab in - KnTab.locate qid tab.tab_cstr - -let locate_extended_all_constructor qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_cstr - -let shortest_qualid_of_constructor kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_cstr_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr - -let push_type vis sp kn = - let tab = !nametab in - let tab_type = KnTab.push vis sp kn tab.tab_type in - let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in - nametab := { tab with tab_type; tab_type_rev } - -let locate_type qid = - let tab = !nametab in - KnTab.locate qid tab.tab_type - -let locate_extended_all_type qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_type - -let shortest_qualid_of_type ?loc kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_type_rev in - KnTab.shortest_qualid ?loc Id.Set.empty sp tab.tab_type - -let push_projection vis sp kn = - let tab = !nametab in - let tab_proj = KnTab.push vis sp kn tab.tab_proj in - let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in - nametab := { tab with tab_proj; tab_proj_rev } - -let locate_projection qid = - let tab = !nametab in - KnTab.locate qid tab.tab_proj - -let locate_extended_all_projection qid = - let tab = !nametab in - KnTab.find_prefixes qid tab.tab_proj - -let shortest_qualid_of_projection kn = - let tab = !nametab in - let sp = KNmap.find kn tab.tab_proj_rev in - KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj - -type 'a or_glb_tacexpr = -| GlbVal of 'a -| GlbTacexpr of glb_tacexpr - -type environment = { - env_ist : valexpr Id.Map.t; -} - -type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr - -type ('a, 'b) ml_object = { - ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; - ml_subst : Mod_subst.substitution -> 'b -> 'b; - ml_interp : environment -> 'b -> valexpr Proofview.tactic; - ml_print : Environ.env -> 'b -> Pp.t; -} - -module MLTypeObj = -struct - type ('a, 'b) t = ('a, 'b) ml_object -end - -module MLType = Tac2dyn.ArgMap(MLTypeObj) - -let ml_object_table = ref MLType.empty - -let define_ml_object t tpe = - ml_object_table := MLType.add t (MLType.Pack tpe) !ml_object_table - -let interp_ml_object t = - try - let MLType.Pack ans = MLType.find t !ml_object_table in - ans - with Not_found -> - CErrors.anomaly Pp.(str "Unknown object type " ++ str (Tac2dyn.Arg.repr t)) - -(** Absolute paths *) - -let coq_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) - -let std_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) - -let ltac1_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Ltac1"; "Ltac2"])) - -(** Generic arguments *) - -let wit_ltac2 = Genarg.make0 "ltac2:value" -let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" -let () = Geninterp.register_val0 wit_ltac2 None -let () = Geninterp.register_val0 wit_ltac2_quotation None - -let is_constructor qid = - let (_, id) = repr_qualid qid in - let id = Id.to_string id in - assert (String.length id > 0); - match id with - | "true" | "false" -> true (* built-in constructors *) - | _ -> - match id.[0] with - | 'A'..'Z' -> true - | _ -> false diff --git a/vendor/Ltac2/src/tac2env.mli b/vendor/Ltac2/src/tac2env.mli deleted file mode 100644 index c7e87c5432..0000000000 --- a/vendor/Ltac2/src/tac2env.mli +++ /dev/null @@ -1,146 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* global_data -> unit -val interp_global : ltac_constant -> global_data - -(** {5 Toplevel definition of types} *) - -val define_type : type_constant -> glb_quant_typedef -> unit -val interp_type : type_constant -> glb_quant_typedef - -(** {5 Toplevel definition of algebraic constructors} *) - -type constructor_data = { - cdata_prms : int; - (** Type parameters *) - cdata_type : type_constant; - (** Inductive definition to which the constructor pertains *) - cdata_args : int glb_typexpr list; - (** Types of the constructor arguments *) - cdata_indx : int option; - (** Index of the constructor in the ADT. Numbering is duplicated between - argumentless and argument-using constructors, e.g. in type ['a option] - [None] and [Some] have both index 0. This field is empty whenever the - constructor is a member of an open type. *) -} - -val define_constructor : ltac_constructor -> constructor_data -> unit -val interp_constructor : ltac_constructor -> constructor_data - -(** {5 Toplevel definition of projections} *) - -type projection_data = { - pdata_prms : int; - (** Type parameters *) - pdata_type : type_constant; - (** Record definition to which the projection pertains *) - pdata_ptyp : int glb_typexpr; - (** Type of the projection *) - pdata_mutb : bool; - (** Whether the field is mutable *) - pdata_indx : int; - (** Index of the projection *) -} - -val define_projection : ltac_projection -> projection_data -> unit -val interp_projection : ltac_projection -> projection_data - -(** {5 Toplevel definition of aliases} *) - -val define_alias : ltac_constant -> raw_tacexpr -> unit -val interp_alias : ltac_constant -> raw_tacexpr - -(** {5 Name management} *) - -val push_ltac : visibility -> full_path -> tacref -> unit -val locate_ltac : qualid -> tacref -val locate_extended_all_ltac : qualid -> tacref list -val shortest_qualid_of_ltac : tacref -> qualid - -val push_constructor : visibility -> full_path -> ltac_constructor -> unit -val locate_constructor : qualid -> ltac_constructor -val locate_extended_all_constructor : qualid -> ltac_constructor list -val shortest_qualid_of_constructor : ltac_constructor -> qualid - -val push_type : visibility -> full_path -> type_constant -> unit -val locate_type : qualid -> type_constant -val locate_extended_all_type : qualid -> type_constant list -val shortest_qualid_of_type : ?loc:Loc.t -> type_constant -> qualid - -val push_projection : visibility -> full_path -> ltac_projection -> unit -val locate_projection : qualid -> ltac_projection -val locate_extended_all_projection : qualid -> ltac_projection list -val shortest_qualid_of_projection : ltac_projection -> qualid - -(** {5 Toplevel definitions of ML tactics} *) - -(** This state is not part of the summary, contrarily to the ones above. It is - intended to be used from ML plugins to register ML-side functions. *) - -val define_primitive : ml_tactic_name -> closure -> unit -val interp_primitive : ml_tactic_name -> closure - -(** {5 ML primitive types} *) - -type 'a or_glb_tacexpr = -| GlbVal of 'a -| GlbTacexpr of glb_tacexpr - -type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr - -type environment = { - env_ist : valexpr Id.Map.t; -} - -type ('a, 'b) ml_object = { - ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; - ml_subst : Mod_subst.substitution -> 'b -> 'b; - ml_interp : environment -> 'b -> valexpr Proofview.tactic; - ml_print : Environ.env -> 'b -> Pp.t; -} - -val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit -val interp_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object - -(** {5 Absolute paths} *) - -val coq_prefix : ModPath.t -(** Path where primitive datatypes are defined in Ltac2 plugin. *) - -val std_prefix : ModPath.t -(** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) - -val ltac1_prefix : ModPath.t -(** Path where the Ltac1 legacy FFI is defined. *) - -(** {5 Generic arguments} *) - -val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type -val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type - -(** {5 Helper functions} *) - -val is_constructor : qualid -> bool diff --git a/vendor/Ltac2/src/tac2expr.mli b/vendor/Ltac2/src/tac2expr.mli deleted file mode 100644 index 1069d0bfa3..0000000000 --- a/vendor/Ltac2/src/tac2expr.mli +++ /dev/null @@ -1,190 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_tacexpr_r - -and raw_tacexpr = raw_tacexpr_r CAst.t - -and raw_taccase = raw_patexpr * raw_tacexpr - -and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list - -type case_info = type_constant or_tuple - -type 'a open_match = { - opn_match : 'a; - opn_branch : (Name.t * Name.t array * 'a) KNmap.t; - (** Invariant: should not be empty *) - opn_default : Name.t * 'a; -} - -type glb_tacexpr = -| GTacAtm of atom -| GTacVar of Id.t -| GTacRef of ltac_constant -| GTacFun of Name.t list * glb_tacexpr -| GTacApp of glb_tacexpr * glb_tacexpr list -| GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr -| GTacCst of case_info * int * glb_tacexpr list -| GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array -| GTacPrj of type_constant * glb_tacexpr * int -| GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr -| GTacOpn of ltac_constructor * glb_tacexpr list -| GTacWth of glb_tacexpr open_match -| GTacExt : (_, 'a) Tac2dyn.Arg.tag * 'a -> glb_tacexpr -| GTacPrm of ml_tactic_name * glb_tacexpr list - -(** {5 Parsing & Printing} *) - -type exp_level = -| E5 -| E4 -| E3 -| E2 -| E1 -| E0 - -type sexpr = -| SexprStr of string CAst.t -| SexprInt of int CAst.t -| SexprRec of Loc.t * Id.t option CAst.t * sexpr list - -(** {5 Toplevel statements} *) - -type strexpr = -| StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list - (** Term definition *) -| StrTyp of rec_flag * (qualid * redef_flag * raw_quant_typedef) list - (** Type definition *) -| StrPrm of Names.lident * raw_typexpr * ml_tactic_name - (** External definition *) -| StrSyn of sexpr list * int option * raw_tacexpr - (** Syntactic extensions *) -| StrMut of qualid * raw_tacexpr - (** Redefinition of mutable globals *) -| StrRun of raw_tacexpr - (** Toplevel evaluation of an expression *) - -(** {5 Dynamic semantics} *) - -(** Values are represented in a way similar to OCaml, i.e. they constrast - immediate integers (integers, constructors without arguments) and structured - blocks (tuples, arrays, constructors with arguments), as well as a few other - base cases, namely closures, strings, named constructors, and dynamic type - coming from the Coq implementation. *) - -type tag = int - -type frame = -| FrLtac of ltac_constant -| FrAnon of glb_tacexpr -| FrPrim of ml_tactic_name -| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame - -type backtrace = frame list diff --git a/vendor/Ltac2/src/tac2extffi.ml b/vendor/Ltac2/src/tac2extffi.ml deleted file mode 100644 index 315c970f9e..0000000000 --- a/vendor/Ltac2/src/tac2extffi.ml +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false) f - -(** More ML representations *) - -let to_qhyp v = match Value.to_block v with -| (0, [| i |]) -> AnonHyp (Value.to_int i) -| (1, [| id |]) -> NamedHyp (Value.to_ident id) -| _ -> assert false - -let qhyp = make_to_repr to_qhyp - -let to_bindings = function -| ValInt 0 -> NoBindings -| ValBlk (0, [| vl |]) -> - ImplicitBindings (Value.to_list Value.to_constr vl) -| ValBlk (1, [| vl |]) -> - ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) -| _ -> assert false - -let bindings = make_to_repr to_bindings - -let to_constr_with_bindings v = match Value.to_tuple v with -| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) -| _ -> assert false - -let constr_with_bindings = make_to_repr to_constr_with_bindings diff --git a/vendor/Ltac2/src/tac2extffi.mli b/vendor/Ltac2/src/tac2extffi.mli deleted file mode 100644 index f5251c3d0d..0000000000 --- a/vendor/Ltac2/src/tac2extffi.mli +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a Proofview.tactic) arity0 -| AddAty : ('a, 'b) arity0 -> ('a, 'a -> 'b) arity0 - -type valexpr = -| ValInt of int - (** Immediate integers *) -| ValBlk of tag * valexpr array - (** Structured blocks *) -| ValStr of Bytes.t - (** Strings *) -| ValCls of closure - (** Closures *) -| ValOpn of KerName.t * valexpr array - (** Open constructors *) -| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr - (** Arbitrary data *) - -and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure - -let arity_one = OneAty -let arity_suc a = AddAty a - -type 'a arity = (valexpr, 'a) arity0 - -let mk_closure arity f = MLTactic (arity, f) - -module Valexpr = -struct - -type t = valexpr - -let is_int = function -| ValInt _ -> true -| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false - -let tag v = match v with -| ValBlk (n, _) -> n -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> - CErrors.anomaly (Pp.str "Unexpected value shape") - -let field v n = match v with -| ValBlk (_, v) -> v.(n) -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> - CErrors.anomaly (Pp.str "Unexpected value shape") - -let set_field v n w = match v with -| ValBlk (_, v) -> v.(n) <- w -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> - CErrors.anomaly (Pp.str "Unexpected value shape") - -let make_block tag v = ValBlk (tag, v) -let make_int n = ValInt n - -end - -type 'a repr = { - r_of : 'a -> valexpr; - r_to : valexpr -> 'a; - r_id : bool; -} - -let repr_of r x = r.r_of x -let repr_to r x = r.r_to x - -let make_repr r_of r_to = { r_of; r_to; r_id = false; } - -(** Dynamic tags *) - -let val_exn = Val.create "exn" -let val_constr = Val.create "constr" -let val_ident = Val.create "ident" -let val_pattern = Val.create "pattern" -let val_pp = Val.create "pp" -let val_sort = Val.create "sort" -let val_cast = Val.create "cast" -let val_inductive = Val.create "inductive" -let val_constant = Val.create "constant" -let val_constructor = Val.create "constructor" -let val_projection = Val.create "projection" -let val_case = Val.create "case" -let val_univ = Val.create "universe" -let val_free : Names.Id.Set.t Val.tag = Val.create "free" -let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" - -let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = -match Val.eq tag tag' with -| None -> assert false -| Some Refl -> v - -(** Exception *) - -exception LtacError of KerName.t * valexpr array - -(** Conversion functions *) - -let valexpr = { - r_of = (fun obj -> obj); - r_to = (fun obj -> obj); - r_id = true; -} - -let of_unit () = ValInt 0 - -let to_unit = function -| ValInt 0 -> () -| _ -> assert false - -let unit = { - r_of = of_unit; - r_to = to_unit; - r_id = false; -} - -let of_int n = ValInt n -let to_int = function -| ValInt n -> n -| _ -> assert false - -let int = { - r_of = of_int; - r_to = to_int; - r_id = false; -} - -let of_bool b = if b then ValInt 0 else ValInt 1 - -let to_bool = function -| ValInt 0 -> true -| ValInt 1 -> false -| _ -> assert false - -let bool = { - r_of = of_bool; - r_to = to_bool; - r_id = false; -} - -let of_char n = ValInt (Char.code n) -let to_char = function -| ValInt n -> Char.chr n -| _ -> assert false - -let char = { - r_of = of_char; - r_to = to_char; - r_id = false; -} - -let of_string s = ValStr s -let to_string = function -| ValStr s -> s -| _ -> assert false - -let string = { - r_of = of_string; - r_to = to_string; - r_id = false; -} - -let rec of_list f = function -| [] -> ValInt 0 -| x :: l -> ValBlk (0, [| f x; of_list f l |]) - -let rec to_list f = function -| ValInt 0 -> [] -| ValBlk (0, [|v; vl|]) -> f v :: to_list f vl -| _ -> assert false - -let list r = { - r_of = (fun l -> of_list r.r_of l); - r_to = (fun l -> to_list r.r_to l); - r_id = false; -} - -let of_closure cls = ValCls cls - -let to_closure = function -| ValCls cls -> cls -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false - -let closure = { - r_of = of_closure; - r_to = to_closure; - r_id = false; -} - -let of_ext tag c = - ValExt (tag, c) - -let to_ext tag = function -| ValExt (tag', e) -> extract_val tag tag' e -| _ -> assert false - -let repr_ext tag = { - r_of = (fun e -> of_ext tag e); - r_to = (fun e -> to_ext tag e); - r_id = false; -} - -let of_constr c = of_ext val_constr c -let to_constr c = to_ext val_constr c -let constr = repr_ext val_constr - -let of_ident c = of_ext val_ident c -let to_ident c = to_ext val_ident c -let ident = repr_ext val_ident - -let of_pattern c = of_ext val_pattern c -let to_pattern c = to_ext val_pattern c -let pattern = repr_ext val_pattern - -let internal_err = - let open Names in - let coq_prefix = - MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) - in - KerName.make coq_prefix (Label.of_id (Id.of_string "Internal")) - -(** FIXME: handle backtrace in Ltac2 exceptions *) -let of_exn c = match fst c with -| LtacError (kn, c) -> ValOpn (kn, c) -| _ -> ValOpn (internal_err, [|of_ext val_exn c|]) - -let to_exn c = match c with -| ValOpn (kn, c) -> - if Names.KerName.equal kn internal_err then - to_ext val_exn c.(0) - else - (LtacError (kn, c), Exninfo.null) -| _ -> assert false - -let exn = { - r_of = of_exn; - r_to = to_exn; - r_id = false; -} - -let of_option f = function -| None -> ValInt 0 -| Some c -> ValBlk (0, [|f c|]) - -let to_option f = function -| ValInt 0 -> None -| ValBlk (0, [|c|]) -> Some (f c) -| _ -> assert false - -let option r = { - r_of = (fun l -> of_option r.r_of l); - r_to = (fun l -> to_option r.r_to l); - r_id = false; -} - -let of_pp c = of_ext val_pp c -let to_pp c = to_ext val_pp c -let pp = repr_ext val_pp - -let of_tuple cl = ValBlk (0, cl) -let to_tuple = function -| ValBlk (0, cl) -> cl -| _ -> assert false - -let of_pair f g (x, y) = ValBlk (0, [|f x; g y|]) -let to_pair f g = function -| ValBlk (0, [|x; y|]) -> (f x, g y) -| _ -> assert false -let pair r0 r1 = { - r_of = (fun p -> of_pair r0.r_of r1.r_of p); - r_to = (fun p -> to_pair r0.r_to r1.r_to p); - r_id = false; -} - -let of_array f vl = ValBlk (0, Array.map f vl) -let to_array f = function -| ValBlk (0, vl) -> Array.map f vl -| _ -> assert false -let array r = { - r_of = (fun l -> of_array r.r_of l); - r_to = (fun l -> to_array r.r_to l); - r_id = false; -} - -let of_block (n, args) = ValBlk (n, args) -let to_block = function -| ValBlk (n, args) -> (n, args) -| _ -> assert false - -let block = { - r_of = of_block; - r_to = to_block; - r_id = false; -} - -let of_open (kn, args) = ValOpn (kn, args) - -let to_open = function -| ValOpn (kn, args) -> (kn, args) -| _ -> assert false - -let open_ = { - r_of = of_open; - r_to = to_open; - r_id = false; -} - -let of_constant c = of_ext val_constant c -let to_constant c = to_ext val_constant c -let constant = repr_ext val_constant - -let of_reference = function -| VarRef id -> ValBlk (0, [| of_ident id |]) -| ConstRef cst -> ValBlk (1, [| of_constant cst |]) -| IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) -| ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) - -let to_reference = function -| ValBlk (0, [| id |]) -> VarRef (to_ident id) -| ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) -| ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) -| ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) -| _ -> assert false - -let reference = { - r_of = of_reference; - r_to = to_reference; - r_id = false; -} - -type ('a, 'b) fun1 = closure - -let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure -let to_fun1 r0 r1 f = to_closure f - -let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = - fun arity f args -> match args, arity with - | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) - (* A few hardcoded cases for efficiency *) - | [a0], OneAty -> f a0 - | [a0; a1], AddAty OneAty -> f a0 a1 - | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 - | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 - (* Generic cases *) - | a :: args, OneAty -> - f a >>= fun f -> - let MLTactic (arity, f) = to_closure f in - apply arity f args - | a :: args, AddAty arity -> - apply arity (f a) args - -let apply (MLTactic (arity, f)) args = apply arity f args - -type n_closure = -| NClosure : 'a arity * (valexpr list -> 'a) -> n_closure - -let rec abstract n f = - if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) - else - let NClosure (arity, fe) = abstract (n - 1) f in - NClosure (AddAty arity, fun accu v -> fe (v :: accu)) - -let abstract n f = - let () = assert (n > 0) in - let NClosure (arity, f) = abstract n f in - MLTactic (arity, f []) - -let app_fun1 cls r0 r1 x = - apply cls [r0.r_of x] >>= fun v -> Proofview.tclUNIT (r1.r_to v) diff --git a/vendor/Ltac2/src/tac2ffi.mli b/vendor/Ltac2/src/tac2ffi.mli deleted file mode 100644 index bfc93d99e6..0000000000 --- a/vendor/Ltac2/src/tac2ffi.mli +++ /dev/null @@ -1,189 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* valexpr - (** Arbitrary data *) - -type 'a arity - -val arity_one : (valexpr -> valexpr Proofview.tactic) arity -val arity_suc : 'a arity -> (valexpr -> 'a) arity - -val mk_closure : 'v arity -> 'v -> closure - -module Valexpr : -sig - type t = valexpr - val is_int : t -> bool - val tag : t -> int - val field : t -> int -> t - val set_field : t -> int -> t -> unit - val make_block : int -> t array -> t - val make_int : int -> t -end - -(** {5 Ltac2 FFI} *) - -type 'a repr - -val repr_of : 'a repr -> 'a -> valexpr -val repr_to : 'a repr -> valexpr -> 'a - -val make_repr : ('a -> valexpr) -> (valexpr -> 'a) -> 'a repr - -(** These functions allow to convert back and forth between OCaml and Ltac2 - data representation. The [to_*] functions raise an anomaly whenever the data - has not expected shape. *) - -val of_unit : unit -> valexpr -val to_unit : valexpr -> unit -val unit : unit repr - -val of_int : int -> valexpr -val to_int : valexpr -> int -val int : int repr - -val of_bool : bool -> valexpr -val to_bool : valexpr -> bool -val bool : bool repr - -val of_char : char -> valexpr -val to_char : valexpr -> char -val char : char repr - -val of_string : Bytes.t -> valexpr -val to_string : valexpr -> Bytes.t -val string : Bytes.t repr - -val of_list : ('a -> valexpr) -> 'a list -> valexpr -val to_list : (valexpr -> 'a) -> valexpr -> 'a list -val list : 'a repr -> 'a list repr - -val of_constr : EConstr.t -> valexpr -val to_constr : valexpr -> EConstr.t -val constr : EConstr.t repr - -val of_exn : Exninfo.iexn -> valexpr -val to_exn : valexpr -> Exninfo.iexn -val exn : Exninfo.iexn repr - -val of_ident : Id.t -> valexpr -val to_ident : valexpr -> Id.t -val ident : Id.t repr - -val of_closure : closure -> valexpr -val to_closure : valexpr -> closure -val closure : closure repr - -val of_block : (int * valexpr array) -> valexpr -val to_block : valexpr -> (int * valexpr array) -val block : (int * valexpr array) repr - -val of_array : ('a -> valexpr) -> 'a array -> valexpr -val to_array : (valexpr -> 'a) -> valexpr -> 'a array -val array : 'a repr -> 'a array repr - -val of_tuple : valexpr array -> valexpr -val to_tuple : valexpr -> valexpr array - -val of_pair : ('a -> valexpr) -> ('b -> valexpr) -> 'a * 'b -> valexpr -val to_pair : (valexpr -> 'a) -> (valexpr -> 'b) -> valexpr -> 'a * 'b -val pair : 'a repr -> 'b repr -> ('a * 'b) repr - -val of_option : ('a -> valexpr) -> 'a option -> valexpr -val to_option : (valexpr -> 'a) -> valexpr -> 'a option -val option : 'a repr -> 'a option repr - -val of_pattern : Pattern.constr_pattern -> valexpr -val to_pattern : valexpr -> Pattern.constr_pattern -val pattern : Pattern.constr_pattern repr - -val of_pp : Pp.t -> valexpr -val to_pp : valexpr -> Pp.t -val pp : Pp.t repr - -val of_constant : Constant.t -> valexpr -val to_constant : valexpr -> Constant.t -val constant : Constant.t repr - -val of_reference : GlobRef.t -> valexpr -val to_reference : valexpr -> GlobRef.t -val reference : GlobRef.t repr - -val of_ext : 'a Val.tag -> 'a -> valexpr -val to_ext : 'a Val.tag -> valexpr -> 'a -val repr_ext : 'a Val.tag -> 'a repr - -val of_open : KerName.t * valexpr array -> valexpr -val to_open : valexpr -> KerName.t * valexpr array -val open_ : (KerName.t * valexpr array) repr - -type ('a, 'b) fun1 - -val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic - -val to_fun1 : 'a repr -> 'b repr -> valexpr -> ('a, 'b) fun1 -val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr - -val valexpr : valexpr repr - -(** {5 Dynamic tags} *) - -val val_constr : EConstr.t Val.tag -val val_ident : Id.t Val.tag -val val_pattern : Pattern.constr_pattern Val.tag -val val_pp : Pp.t Val.tag -val val_sort : ESorts.t Val.tag -val val_cast : Constr.cast_kind Val.tag -val val_inductive : inductive Val.tag -val val_constant : Constant.t Val.tag -val val_constructor : constructor Val.tag -val val_projection : Projection.t Val.tag -val val_case : Constr.case_info Val.tag -val val_univ : Univ.Level.t Val.tag -val val_free : Id.Set.t Val.tag -val val_ltac1 : Geninterp.Val.t Val.tag - -val val_exn : Exninfo.iexn Tac2dyn.Val.tag -(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] - should be put into a value with tag [val_exn]. *) - -(** Closures *) - -val apply : closure -> valexpr list -> valexpr Proofview.tactic -(** Given a closure, apply it to some arguments. Handling of argument mismatches - is done automatically, i.e. in case of over or under-application. *) - -val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> closure -(** Turn a fixed-arity function into a closure. The inner function is guaranteed - to be applied to a list whose size is the integer argument. *) - -(** Exception *) - -exception LtacError of KerName.t * valexpr array -(** Ltac2-defined exceptions seen from OCaml side *) diff --git a/vendor/Ltac2/src/tac2intern.ml b/vendor/Ltac2/src/tac2intern.ml deleted file mode 100644 index de99fb167f..0000000000 --- a/vendor/Ltac2/src/tac2intern.ml +++ /dev/null @@ -1,1545 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* elt -> bool -val create : unit -> 'a t -val fresh : 'a t -> elt -val find : elt -> 'a t -> (elt * 'a option) -val union : elt -> elt -> 'a t -> unit -val set : elt -> 'a -> 'a t -> unit -module Map : -sig - type key = elt - type +'a t - val empty : 'a t - val add : key -> 'a -> 'a t -> 'a t - val mem : key -> 'a t -> bool - val find : key -> 'a t -> 'a - val exists : (key -> 'a -> bool) -> 'a t -> bool -end -end -= -struct -type elt = int -let equal = Int.equal -module Map = Int.Map - -type 'a node = -| Canon of int * 'a option -| Equiv of elt - -type 'a t = { - mutable uf_data : 'a node array; - mutable uf_size : int; -} - -let resize p = - if Int.equal (Array.length p.uf_data) p.uf_size then begin - let nsize = 2 * p.uf_size + 1 in - let v = Array.make nsize (Equiv 0) in - Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); - p.uf_data <- v; - end - -let create () = { uf_data = [||]; uf_size = 0 } - -let fresh p = - resize p; - let n = p.uf_size in - p.uf_data.(n) <- (Canon (1, None)); - p.uf_size <- n + 1; - n - -let rec lookup n p = - let node = Array.get p.uf_data n in - match node with - | Canon (size, v) -> n, size, v - | Equiv y -> - let ((z, _, _) as res) = lookup y p in - if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); - res - -let find n p = - let (x, _, v) = lookup n p in (x, v) - -let union x y p = - let ((x, size1, _) as xcan) = lookup x p in - let ((y, size2, _) as ycan) = lookup y p in - let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in - let x, _, xnode = xcan in - let y, _, ynode = ycan in - assert (Option.is_empty xnode); - assert (Option.is_empty ynode); - p.uf_data.(x) <- Equiv y; - p.uf_data.(y) <- Canon (size1 + size2, None) - -let set x v p = - let (x, s, v') = lookup x p in - assert (Option.is_empty v'); - p.uf_data.(x) <- Canon (s, Some v) - -end - -type mix_var = -| GVar of UF.elt -| LVar of int - -type mix_type_scheme = int * mix_var glb_typexpr - -type environment = { - env_var : mix_type_scheme Id.Map.t; - (** Type schemes of bound variables *) - env_cst : UF.elt glb_typexpr UF.t; - (** Unification state *) - env_als : UF.elt Id.Map.t ref; - (** Map user-facing type variables to unification variables *) - env_opn : bool; - (** Accept unbound type variables *) - env_rec : (KerName.t * int) Id.Map.t; - (** Recursive type definitions *) - env_str : bool; - (** True iff in strict mode *) -} - -let empty_env () = { - env_var = Id.Map.empty; - env_cst = UF.create (); - env_als = ref Id.Map.empty; - env_opn = true; - env_rec = Id.Map.empty; - env_str = true; -} - -let env_name env = - (* Generate names according to a provided environment *) - let mk num = - let base = num mod 26 in - let rem = num / 26 in - let name = String.make 1 (Char.chr (97 + base)) in - let suff = if Int.equal rem 0 then "" else string_of_int rem in - let name = name ^ suff in - name - in - let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in - let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in - let vars = ref vars in - let rec fresh n = - let name = mk n in - if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) - else name - in - fun n -> - if UF.Map.mem n !vars then UF.Map.find n !vars - else - let ans = fresh 0 in - let () = vars := UF.Map.add n ans !vars in - ans - -let ltac2_env : environment Genintern.Store.field = - Genintern.Store.field () - -let drop_ltac2_env store = - Genintern.Store.remove store ltac2_env - -let fresh_id env = UF.fresh env.env_cst - -let get_alias {loc;v=id} env = - try Id.Map.find id env.env_als.contents - with Not_found -> - if env.env_opn then - let n = fresh_id env in - let () = env.env_als := Id.Map.add id n env.env_als.contents in - n - else user_err ?loc (str "Unbound type parameter " ++ Id.print id) - -let push_name id t env = match id with -| Anonymous -> env -| Name id -> { env with env_var = Id.Map.add id t env.env_var } - -let error_nargs_mismatch ?loc kn nargs nfound = - let cstr = Tac2env.shortest_qualid_of_constructor kn in - user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ - int nargs ++ str " arguments, but is applied to " ++ int nfound ++ - str " arguments") - -let error_nparams_mismatch ?loc nargs nfound = - user_err ?loc (str "Type expects " ++ int nargs ++ - str " arguments, but is applied to " ++ int nfound ++ - str " arguments") - -let rec subst_type subst (t : 'a glb_typexpr) = match t with -| GTypVar id -> subst id -| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) -| GTypRef (qid, args) -> - GTypRef (qid, List.map (fun t -> subst_type subst t) args) - -let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t with -| CTypVar (Name id) -> GTypVar (get_alias (CAst.make ?loc id) env) -| CTypVar Anonymous -> GTypVar (fresh_id env) -| CTypRef (rel, args) -> - let (kn, nparams) = match rel with - | RelId qid -> - let id = qualid_basename qid in - if qualid_is_ident qid && Id.Map.mem id env.env_rec then - let (kn, n) = Id.Map.find id env.env_rec in - (Other kn, n) - else - let kn = - try Tac2env.locate_type qid - with Not_found -> - user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) - in - let (nparams, _) = Tac2env.interp_type kn in - (Other kn, nparams) - | AbsKn (Other kn) -> - let (nparams, _) = Tac2env.interp_type kn in - (Other kn, nparams) - | AbsKn (Tuple n) -> - (Tuple n, n) - in - let nargs = List.length args in - let () = - if not (Int.equal nparams nargs) then - let qid = match rel with - | RelId lid -> lid - | AbsKn (Other kn) -> shortest_qualid_of_type ?loc kn - | AbsKn (Tuple _) -> assert false - in - user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ - strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ - applied to " ++ int nargs ++ strbrk "argument(s)") - in - GTypRef (kn, List.map (fun t -> intern_type env t) args) -| CTypArrow (t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) - -let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = - let (n, t) = t in - let subst = Array.init n (fun _ -> fresh_id env) in - let substf i = GTypVar subst.(i) in - subst_type substf t - -let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = - let (n, t) = t in - let subst = Array.init n (fun _ -> fresh_id env) in - let substf = function - | LVar i -> GTypVar subst.(i) - | GVar n -> GTypVar n - in - subst_type substf t - -let fresh_reftype env (kn : KerName.t or_tuple) = - let n = match kn with - | Other kn -> fst (Tac2env.interp_type kn) - | Tuple n -> n - in - let subst = Array.init n (fun _ -> fresh_id env) in - let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in - (subst, t) - -(** First-order unification algorithm *) -let is_unfoldable kn = match snd (Tac2env.interp_type kn) with -| GTydDef (Some _) -> true -| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false - -let unfold env kn args = - let (nparams, def) = Tac2env.interp_type kn in - let def = match def with - | GTydDef (Some t) -> t - | _ -> assert false - in - let args = Array.of_list args in - let subst n = args.(n) in - subst_type subst def - -(** View function, allows to ensure head normal forms *) -let rec kind env t = match t with -| GTypVar id -> - let (id, v) = UF.find id env.env_cst in - begin match v with - | None -> GTypVar id - | Some t -> kind env t - end -| GTypRef (Other kn, tl) -> - if is_unfoldable kn then kind env (unfold env kn tl) else t -| GTypArrow _ | GTypRef (Tuple _, _) -> t - -(** Normalize unification variables without unfolding type aliases *) -let rec nf env t = match t with -| GTypVar id -> - let (id, v) = UF.find id env.env_cst in - begin match v with - | None -> GTypVar id - | Some t -> nf env t - end -| GTypRef (kn, tl) -> - let tl = List.map (fun t -> nf env t) tl in - GTypRef (kn, tl) -| GTypArrow (t, u) -> - let t = nf env t in - let u = nf env u in - GTypArrow (t, u) - -let pr_glbtype env t = - let t = nf env t in - let name = env_name env in - pr_glbtype name t - -exception Occur - -let rec occur_check env id t = match kind env t with -| GTypVar id' -> if UF.equal id id' then raise Occur -| GTypArrow (t1, t2) -> - let () = occur_check env id t1 in - occur_check env id t2 -| GTypRef (kn, tl) -> - List.iter (fun t -> occur_check env id t) tl - -exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr - -let unify_var env id t = match kind env t with -| GTypVar id' -> - if not (UF.equal id id') then UF.union id id' env.env_cst -| GTypArrow _ | GTypRef _ -> - try - let () = occur_check env id t in - UF.set id t env.env_cst - with Occur -> raise (CannotUnify (GTypVar id, t)) - -let eq_or_tuple eq t1 t2 = match t1, t2 with -| Tuple n1, Tuple n2 -> Int.equal n1 n2 -| Other o1, Other o2 -> eq o1 o2 -| _ -> false - -let rec unify0 env t1 t2 = match kind env t1, kind env t2 with -| GTypVar id, t | t, GTypVar id -> - unify_var env id t -| GTypArrow (t1, u1), GTypArrow (t2, u2) -> - let () = unify0 env t1 t2 in - unify0 env u1 u2 -| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> - if eq_or_tuple KerName.equal kn1 kn2 then - List.iter2 (fun t1 t2 -> unify0 env t1 t2) tl1 tl2 - else raise (CannotUnify (t1, t2)) -| _ -> raise (CannotUnify (t1, t2)) - -let unify ?loc env t1 t2 = - try unify0 env t1 t2 - with CannotUnify (u1, u2) -> - user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env t1 ++ - spc () ++ str "but an expression was expected of type" ++ spc () ++ pr_glbtype env t2) - -let unify_arrow ?loc env ft args = - let ft0 = ft in - let rec iter ft args is_fun = match kind env ft, args with - | t, [] -> t - | GTypArrow (t1, ft), (loc, t2) :: args -> - let () = unify ?loc env t2 t1 in - iter ft args true - | GTypVar id, (_, t) :: args -> - let ft = GTypVar (fresh_id env) in - let () = unify_var env id (GTypArrow (t, ft)) in - iter ft args true - | GTypRef _, _ :: _ -> - if is_fun then - user_err ?loc (str "This function has type" ++ spc () ++ pr_glbtype env ft0 ++ - spc () ++ str "and is applied to too many arguments") - else - user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env ft0 ++ - spc () ++ str "and is not a function") - in - iter ft args false - -(** Term typing *) - -let is_pure_constructor kn = - match snd (Tac2env.interp_type kn) with - | GTydAlg _ | GTydOpn -> true - | GTydRec fields -> - let is_pure (_, mut, _) = not mut in - List.for_all is_pure fields - | GTydDef _ -> assert false (** Type definitions have no constructors *) - -let rec is_value = function -| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true -| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false -| GTacCst (Tuple _, _, el) -> List.for_all is_value el -| GTacCst (_, _, []) -> true -| GTacOpn (_, el) -> List.for_all is_value el -| GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el -| GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ -| GTacWth _ -> false - -let is_rec_rhs = function -| GTacFun _ -> true -| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ -| GTacSet _ | GTacExt _ | GTacPrm _ | GTacCst _ -| GTacCse _ | GTacOpn _ | GTacWth _ -> false - -let rec fv_type f t accu = match t with -| GTypVar id -> f id accu -| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) -| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl - -let fv_env env = - let rec f id accu = match UF.find id env.env_cst with - | id, None -> UF.Map.add id () accu - | _, Some t -> fv_type f t accu - in - let fold_var id (_, t) accu = - let fmix id accu = match id with - | LVar _ -> accu - | GVar id -> f id accu - in - fv_type fmix t accu - in - let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in - let fold_als _ id accu = f id accu in - Id.Map.fold fold_als !(env.env_als) fv_var - -let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = - let fv = fv_env env in - let count = ref 0 in - let vars = ref UF.Map.empty in - let rec subst id = - let (id, t) = UF.find id env.env_cst in - match t with - | None -> - if UF.Map.mem id fv then GTypVar (GVar id) - else - begin try UF.Map.find id !vars - with Not_found -> - let n = !count in - let var = GTypVar (LVar n) in - let () = incr count in - let () = vars := UF.Map.add id var !vars in - var - end - | Some t -> subst_type subst t - in - let t = subst_type subst t in - (!count, t) - -let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = - let subst id = GTypVar (GVar id) in - (0, subst_type subst t) - -let warn_not_unit = - CWarnings.create ~name:"not-unit" ~category:"ltac" - (fun () -> strbrk "The following expression should have type unit.") - -let warn_redundant_clause = - CWarnings.create ~name:"redundant-clause" ~category:"ltac" - (fun () -> strbrk "The following clause is redundant.") - -let check_elt_unit loc env t = - let maybe_unit = match kind env t with - | GTypVar _ -> true - | GTypArrow _ -> false - | GTypRef (Tuple 0, []) -> true - | GTypRef _ -> false - in - if not maybe_unit then warn_not_unit ?loc () - -let check_elt_empty loc env t = match kind env t with -| GTypVar _ -> - user_err ?loc (str "Cannot infer an empty type for this expression") -| GTypArrow _ | GTypRef (Tuple _, _) -> - user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") -| GTypRef (Other kn, _) -> - let def = Tac2env.interp_type kn in - match def with - | _, GTydAlg { galg_constructors = [] } -> kn - | _ -> - user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") - -let check_unit ?loc t = - let env = empty_env () in - (* Should not matter, t should be closed. *) - let t = fresh_type_scheme env t in - let maybe_unit = match kind env t with - | GTypVar _ -> true - | GTypArrow _ -> false - | GTypRef (Tuple 0, []) -> true - | GTypRef _ -> false - in - if not maybe_unit then warn_not_unit ?loc () - -let check_redundant_clause = function -| [] -> () -| (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () - -let get_variable0 mem var = match var with -| RelId qid -> - let id = qualid_basename qid in - if qualid_is_ident qid && mem id then ArgVar CAst.(make ?loc:qid.CAst.loc id) - else - let kn = - try Tac2env.locate_ltac qid - with Not_found -> - CErrors.user_err ?loc:qid.CAst.loc (str "Unbound value " ++ pr_qualid qid) - in - ArgArg kn -| AbsKn kn -> ArgArg kn - -let get_variable env var = - let mem id = Id.Map.mem id env.env_var in - get_variable0 mem var - -let get_constructor env var = match var with -| RelId qid -> - let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in - begin match c with - | Some knc -> Other knc - | None -> - CErrors.user_err ?loc:qid.CAst.loc (str "Unbound constructor " ++ pr_qualid qid) - end -| AbsKn knc -> knc - -let get_projection var = match var with -| RelId qid -> - let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") - in - Tac2env.interp_projection kn -| AbsKn kn -> - Tac2env.interp_projection kn - -let intern_atm env = function -| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (Other t_int, [])) -| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (Other t_string, [])) - -let invalid_pattern ?loc kn kn' = - let pr t = match t with - | Other kn' -> str "type " ++ pr_typref kn' - | Tuple n -> str "tuple of size " ++ int n - in - user_err ?loc (str "Invalid pattern, expected a pattern for " ++ - pr kn ++ str ", found a pattern for " ++ pr kn') (** FIXME *) - -(** Pattern view *) - -type glb_patexpr = -| GPatVar of Name.t -| GPatRef of ltac_constructor or_tuple * glb_patexpr list - -let rec intern_patexpr env {loc;v=pat} = match pat with -| CPatVar na -> GPatVar na -| CPatRef (qid, pl) -> - let kn = get_constructor env qid in - GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) -| CPatCnv (pat, ty) -> - user_err ?loc (str "Pattern not handled yet") - -type pattern_kind = -| PKind_empty -| PKind_variant of type_constant or_tuple -| PKind_open of type_constant -| PKind_any - -let get_pattern_kind env pl = match pl with -| [] -> PKind_empty -| p :: pl -> - let rec get_kind (p, _) pl = match intern_patexpr env p with - | GPatVar _ -> - begin match pl with - | [] -> PKind_any - | p :: pl -> get_kind p pl - end - | GPatRef (Other kn, pl) -> - let data = Tac2env.interp_constructor kn in - if Option.is_empty data.cdata_indx then PKind_open data.cdata_type - else PKind_variant (Other data.cdata_type) - | GPatRef (Tuple _, tp) -> PKind_variant (Tuple (List.length tp)) - in - get_kind p pl - -(** Internalization *) - -(** Used to generate a fresh tactic variable for pattern-expansion *) -let fresh_var avoid = - let bad id = - Id.Set.mem id avoid || - (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) - in - Namegen.next_ident_away_from (Id.of_string "p") bad - -let add_name accu = function -| Name id -> Id.Set.add id accu -| Anonymous -> accu - -let rec ids_of_pattern accu {v=pat} = match pat with -| CPatVar Anonymous -> accu -| CPatVar (Name id) -> Id.Set.add id accu -| CPatRef (_, pl) -> - List.fold_left ids_of_pattern accu pl -| CPatCnv (pat, _) -> ids_of_pattern accu pat - -let loc_of_relid = function -| RelId {loc} -> loc -| AbsKn _ -> None - -let extract_pattern_type ({loc;v=p} as pat) = match p with -| CPatCnv (pat, ty) -> pat, Some ty -| CPatVar _ | CPatRef _ -> pat, None - -(** Expand pattern: [p => t] becomes [x => match x with p => t end] *) -let expand_pattern avoid bnd = - let fold (avoid, bnd) (pat, t) = - let na, expand = match pat.v with - | CPatVar na -> - (* Don't expand variable patterns *) - na, None - | _ -> - let id = fresh_var avoid in - let qid = RelId (qualid_of_ident ?loc:pat.loc id) in - Name id, Some qid - in - let avoid = ids_of_pattern avoid pat in - let avoid = add_name avoid na in - (avoid, (na, pat, expand) :: bnd) - in - let (_, bnd) = List.fold_left fold (avoid, []) bnd in - let fold e (na, pat, expand) = match expand with - | None -> e - | Some qid -> - let loc = loc_of_relid qid in - CAst.make ?loc @@ CTacCse (CAst.make ?loc @@ CTacRef qid, [pat, e]) - in - let expand e = List.fold_left fold e bnd in - let nas = List.rev_map (fun (na, _, _) -> na) bnd in - (nas, expand) - -let is_alias env qid = match get_variable env qid with -| ArgArg (TacAlias _) -> true -| ArgVar _ | (ArgArg (TacConstant _)) -> false - -let rec intern_rec env {loc;v=e} = match e with -| CTacAtm atm -> intern_atm env atm -| CTacRef qid -> - begin match get_variable env qid with - | ArgVar {CAst.v=id} -> - let sch = Id.Map.find id env.env_var in - (GTacVar id, fresh_mix_type_scheme env sch) - | ArgArg (TacConstant kn) -> - let { Tac2env.gdata_type = sch } = - try Tac2env.interp_global kn - with Not_found -> - CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) - in - (GTacRef kn, fresh_type_scheme env sch) - | ArgArg (TacAlias kn) -> - let e = - try Tac2env.interp_alias kn - with Not_found -> - CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) - in - intern_rec env e - end -| CTacCst qid -> - let kn = get_constructor env qid in - intern_constructor env loc kn [] -| CTacFun (bnd, e) -> - let bnd = List.map extract_pattern_type bnd in - let map (_, t) = match t with - | None -> GTypVar (fresh_id env) - | Some t -> intern_type env t - in - let tl = List.map map bnd in - let (nas, exp) = expand_pattern (Id.Map.domain env.env_var) bnd in - let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env nas tl in - let (e, t) = intern_rec env (exp e) in - let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in - (GTacFun (nas, e), t) -| CTacApp ({loc;v=CTacCst qid}, args) -> - let kn = get_constructor env qid in - intern_constructor env loc kn args -| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> - let kn = match get_variable env qid with - | ArgArg (TacAlias kn) -> kn - | ArgVar _ | (ArgArg (TacConstant _)) -> assert false - in - let e = Tac2env.interp_alias kn in - let map arg = - (* Thunk alias arguments *) - let loc = arg.loc in - let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in - let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in - CAst.make ?loc @@ CTacFun ([var], arg) - in - let args = List.map map args in - intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) -| CTacApp (f, args) -> - let loc = f.loc in - let (f, ft) = intern_rec env f in - let fold arg (args, t) = - let loc = arg.loc in - let (arg, argt) = intern_rec env arg in - (arg :: args, (loc, argt) :: t) - in - let (args, t) = List.fold_right fold args ([], []) in - let ret = unify_arrow ?loc env ft t in - (GTacApp (f, args), ret) -| CTacLet (is_rec, el, e) -> - let map (pat, e) = - let (pat, ty) = extract_pattern_type pat in - (pat, ty, e) - in - let el = List.map map el in - let fold accu (pat, _, e) = - let ids = ids_of_pattern Id.Set.empty pat in - let common = Id.Set.inter ids accu in - if Id.Set.is_empty common then Id.Set.union ids accu - else - let id = Id.Set.choose common in - user_err ?loc:pat.loc (str "Variable " ++ Id.print id ++ str " is bound several \ - times in this matching") - in - let ids = List.fold_left fold Id.Set.empty el in - if is_rec then intern_let_rec env loc ids el e - else intern_let env loc ids el e -| CTacCnv (e, tc) -> - let (e, t) = intern_rec env e in - let tc = intern_type env tc in - let () = unify ?loc env t tc in - (e, tc) -| CTacSeq (e1, e2) -> - let loc1 = e1.loc in - let (e1, t1) = intern_rec env e1 in - let (e2, t2) = intern_rec env e2 in - let () = check_elt_unit loc1 env t1 in - (GTacLet (false, [Anonymous, e1], e2), t2) -| CTacCse (e, pl) -> - intern_case env loc e pl -| CTacRec fs -> - intern_record env loc fs -| CTacPrj (e, proj) -> - let pinfo = get_projection proj in - let loc = e.loc in - let (e, t) = intern_rec env e in - let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in - let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (Other pinfo.pdata_type, params) in - let () = unify ?loc env t exp in - let substf i = GTypVar subst.(i) in - let ret = subst_type substf pinfo.pdata_ptyp in - (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) -| CTacSet (e, proj, r) -> - let pinfo = get_projection proj in - let () = - if not pinfo.pdata_mutb then - let loc = match proj with - | RelId {CAst.loc} -> loc - | AbsKn _ -> None - in - user_err ?loc (str "Field is not mutable") - in - let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in - let params = Array.map_to_list (fun i -> GTypVar i) subst in - let exp = GTypRef (Other pinfo.pdata_type, params) in - let e = intern_rec_with_constraint env e exp in - let substf i = GTypVar subst.(i) in - let ret = subst_type substf pinfo.pdata_ptyp in - let r = intern_rec_with_constraint env r ret in - (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) -| CTacExt (tag, arg) -> - let open Genintern in - let self ist e = - let env = match Store.get ist.extra ltac2_env with - | None -> empty_env () - | Some env -> env - in - intern_rec env e - in - let obj = interp_ml_object tag in - (* External objects do not have access to the named context because this is - not stable by dynamic semantics. *) - let genv = Global.env_of_context Environ.empty_named_context_val in - let ist = empty_glob_sign genv in - let ist = { ist with extra = Store.set ist.extra ltac2_env env } in - let arg, tpe = - if env.env_str then - let arg () = obj.ml_intern self ist arg in - Flags.with_option Ltac_plugin.Tacintern.strict_check arg () - else - obj.ml_intern self ist arg - in - let e = match arg with - | GlbVal arg -> GTacExt (tag, arg) - | GlbTacexpr e -> e - in - (e, tpe) - -and intern_rec_with_constraint env e exp = - let (er, t) = intern_rec env e in - let () = unify ?loc:e.loc env t exp in - er - -and intern_let env loc ids el e = - let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in - let fold (pat, t, e) (avoid, accu) = - let nas, exp = expand_pattern avoid [pat, t] in - let na = match nas with [x] -> x | _ -> assert false in - let avoid = List.fold_left add_name avoid nas in - (avoid, (na, exp, t, e) :: accu) - in - let (_, el) = List.fold_right fold el (avoid, []) in - let fold (na, exp, tc, e) (body, el, p) = - let (e, t) = match tc with - | None -> intern_rec env e - | Some tc -> - let tc = intern_type env tc in - (intern_rec_with_constraint env e tc, tc) - in - let t = if is_value e then abstract_var env t else monomorphic t in - (exp body, (na, e) :: el, (na, t) :: p) - in - let (e, el, p) = List.fold_right fold el (e, [], []) in - let env = List.fold_left (fun accu (na, t) -> push_name na t accu) env p in - let (e, t) = intern_rec env e in - (GTacLet (false, el, e), t) - -and intern_let_rec env loc ids el e = - let map env (pat, t, e) = - let na = match pat.v with - | CPatVar na -> na - | CPatRef _ | CPatCnv _ -> - user_err ?loc:pat.loc (str "This kind of pattern is forbidden in let-rec bindings") - in - let id = fresh_id env in - let env = push_name na (monomorphic (GTypVar id)) env in - (env, (loc, na, t, e, id)) - in - let (env, el) = List.fold_left_map map env el in - let fold (loc, na, tc, e, id) (el, tl) = - let loc_e = e.loc in - let (e, t) = intern_rec env e in - let () = - if not (is_rec_rhs e) then - user_err ?loc:loc_e (str "This kind of expression is not allowed as \ - right-hand side of a recursive binding") - in - let () = unify ?loc env t (GTypVar id) in - let () = match tc with - | None -> () - | Some tc -> - let tc = intern_type env tc in - unify ?loc env t tc - in - ((na, e) :: el, t :: tl) - in - let (el, tl) = List.fold_right fold el ([], []) in - let (e, t) = intern_rec env e in - (GTacLet (true, el, e), t) - -(** For now, patterns recognized by the pattern-matching compiling are limited - to depth-one where leaves are either variables or catch-all *) -and intern_case env loc e pl = - let (e', t) = intern_rec env e in - let todo ?loc () = user_err ?loc (str "Pattern not handled yet") in - match get_pattern_kind env pl with - | PKind_any -> - let (pat, b) = List.hd pl in - let na = match intern_patexpr env pat with - | GPatVar na -> na - | _ -> assert false - in - let () = check_redundant_clause (List.tl pl) in - let env = push_name na (monomorphic t) env in - let (b, tb) = intern_rec env b in - (GTacLet (false, [na, e'], b), tb) - | PKind_empty -> - let kn = check_elt_empty loc env t in - let r = fresh_id env in - (GTacCse (e', Other kn, [||], [||]), GTypVar r) - | PKind_variant kn -> - let subst, tc = fresh_reftype env kn in - let () = unify ?loc:e.loc env t tc in - let (nconst, nnonconst, arities) = match kn with - | Tuple 0 -> 1, 0, [0] - | Tuple n -> 0, 1, [n] - | Other kn -> - let (_, def) = Tac2env.interp_type kn in - let galg = match def with | GTydAlg c -> c | _ -> assert false in - let arities = List.map (fun (_, args) -> List.length args) galg.galg_constructors in - galg.galg_nconst, galg.galg_nnonconst, arities - in - let const = Array.make nconst None in - let nonconst = Array.make nnonconst None in - let ret = GTypVar (fresh_id env) in - let rec intern_branch = function - | [] -> () - | (pat, br) :: rem -> - let tbr = match pat.v with - | CPatVar (Name _) -> - let loc = pat.loc in - todo ?loc () - | CPatVar Anonymous -> - let () = check_redundant_clause rem in - let (br', brT) = intern_rec env br in - (* Fill all remaining branches *) - let fill (ncst, narg) arity = - if Int.equal arity 0 then - let () = - if Option.is_empty const.(ncst) then const.(ncst) <- Some br' - in - (succ ncst, narg) - else - let () = - if Option.is_empty nonconst.(narg) then - let ids = Array.make arity Anonymous in - nonconst.(narg) <- Some (ids, br') - in - (ncst, succ narg) - in - let _ = List.fold_left fill (0, 0) arities in - brT - | CPatRef (qid, args) -> - let loc = pat.loc in - let knc = get_constructor env qid in - let kn', index, arity = match knc with - | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) - | Other knc -> - let data = Tac2env.interp_constructor knc in - let index = Option.get data.cdata_indx in - Other data.cdata_type, index, data.cdata_args - in - let () = - if not (eq_or_tuple KerName.equal kn kn') then - invalid_pattern ?loc kn kn' - in - let get_id pat = match pat with - | {v=CPatVar na} -> na - | {loc} -> todo ?loc () - in - let ids = List.map get_id args in - let nids = List.length ids in - let nargs = List.length arity in - let () = match knc with - | Tuple n -> assert (n == nids) - | Other knc -> - if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids - in - let fold env id tpe = - (* Instantiate all arguments *) - let subst n = GTypVar subst.(n) in - let tpe = subst_type subst tpe in - push_name id (monomorphic tpe) env - in - let nenv = List.fold_left2 fold env ids arity in - let (br', brT) = intern_rec nenv br in - let () = - if List.is_empty args then - if Option.is_empty const.(index) then const.(index) <- Some br' - else warn_redundant_clause ?loc () - else - let ids = Array.of_list ids in - if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') - else warn_redundant_clause ?loc () - in - brT - | CPatCnv _ -> - user_err ?loc (str "Pattern not handled yet") - in - let () = unify ?loc:br.loc env tbr ret in - intern_branch rem - in - let () = intern_branch pl in - let map n is_const = function - | None -> - let kn = match kn with Other kn -> kn | _ -> assert false in - let cstr = pr_internal_constructor kn n is_const in - user_err ?loc (str "Unhandled match case for constructor " ++ cstr) - | Some x -> x - in - let const = Array.mapi (fun i o -> map i true o) const in - let nonconst = Array.mapi (fun i o -> map i false o) nonconst in - let ce = GTacCse (e', kn, const, nonconst) in - (ce, ret) - | PKind_open kn -> - let subst, tc = fresh_reftype env (Other kn) in - let () = unify ?loc:e.loc env t tc in - let ret = GTypVar (fresh_id env) in - let rec intern_branch map = function - | [] -> - user_err ?loc (str "Missing default case") - | (pat, br) :: rem -> - match intern_patexpr env pat with - | GPatVar na -> - let () = check_redundant_clause rem in - let nenv = push_name na (monomorphic tc) env in - let br' = intern_rec_with_constraint nenv br ret in - let def = (na, br') in - (map, def) - | GPatRef (knc, args) -> - let get = function - | GPatVar na -> na - | GPatRef _ -> - user_err ?loc (str "TODO: Unhandled match case") (* FIXME *) - in - let loc = pat.loc in - let knc = match knc with - | Other knc -> knc - | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) - in - let ids = List.map get args in - let data = Tac2env.interp_constructor knc in - let () = - if not (KerName.equal kn data.cdata_type) then - invalid_pattern ?loc (Other kn) (Other data.cdata_type) - in - let nids = List.length ids in - let nargs = List.length data.cdata_args in - let () = - if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids - in - let fold env id tpe = - (* Instantiate all arguments *) - let subst n = GTypVar subst.(n) in - let tpe = subst_type subst tpe in - push_name id (monomorphic tpe) env - in - let nenv = List.fold_left2 fold env ids data.cdata_args in - let br' = intern_rec_with_constraint nenv br ret in - let map = - if KNmap.mem knc map then - let () = warn_redundant_clause ?loc () in - map - else - KNmap.add knc (Anonymous, Array.of_list ids, br') map - in - intern_branch map rem - in - let (map, def) = intern_branch KNmap.empty pl in - (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) - -and intern_constructor env loc kn args = match kn with -| Other kn -> - let cstr = interp_constructor kn in - let nargs = List.length cstr.cdata_args in - if Int.equal nargs (List.length args) then - let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in - let substf i = GTypVar subst.(i) in - let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in - let targs = List.init cstr.cdata_prms (fun i -> GTypVar subst.(i)) in - let ans = GTypRef (Other cstr.cdata_type, targs) in - let map arg tpe = intern_rec_with_constraint env arg tpe in - let args = List.map2 map args types in - match cstr.cdata_indx with - | Some idx -> - (GTacCst (Other cstr.cdata_type, idx, args), ans) - | None -> - (GTacOpn (kn, args), ans) - else - error_nargs_mismatch ?loc kn nargs (List.length args) -| Tuple n -> - assert (Int.equal n (List.length args)); - let types = List.init n (fun i -> GTypVar (fresh_id env)) in - let map arg tpe = intern_rec_with_constraint env arg tpe in - let args = List.map2 map args types in - let ans = GTypRef (Tuple n, types) in - GTacCst (Tuple n, 0, args), ans - -and intern_record env loc fs = - let map (proj, e) = - let loc = match proj with - | RelId {CAst.loc} -> loc - | AbsKn _ -> None - in - let proj = get_projection proj in - (loc, proj, e) - in - let fs = List.map map fs in - let kn = match fs with - | [] -> user_err ?loc (str "Cannot infer the corresponding record type") - | (_, proj, _) :: _ -> proj.pdata_type - in - let params, typdef = match Tac2env.interp_type kn with - | n, GTydRec def -> n, def - | _ -> assert false - in - let subst = Array.init params (fun _ -> fresh_id env) in - (* Set the answer [args] imperatively *) - let args = Array.make (List.length typdef) None in - let iter (loc, pinfo, e) = - if KerName.equal kn pinfo.pdata_type then - let index = pinfo.pdata_indx in - match args.(index) with - | None -> - let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in - let e = intern_rec_with_constraint env e exp in - args.(index) <- Some e - | Some _ -> - let (name, _, _) = List.nth typdef pinfo.pdata_indx in - user_err ?loc (str "Field " ++ Id.print name ++ str " is defined \ - several times") - else - user_err ?loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ - pertain to record definition " ++ pr_typref pinfo.pdata_type) - in - let () = List.iter iter fs in - let () = match Array.findi (fun _ o -> Option.is_empty o) args with - | None -> () - | Some i -> - let (field, _, _) = List.nth typdef i in - user_err ?loc (str "Field " ++ Id.print field ++ str " is undefined") - in - let args = Array.map_to_list Option.get args in - let tparam = List.init params (fun i -> GTypVar subst.(i)) in - (GTacCst (Other kn, 0, args), GTypRef (Other kn, tparam)) - -let normalize env (count, vars) (t : UF.elt glb_typexpr) = - let get_var id = - try UF.Map.find id !vars - with Not_found -> - let () = assert env.env_opn in - let n = GTypVar !count in - let () = incr count in - let () = vars := UF.Map.add id n !vars in - n - in - let rec subst id = match UF.find id env.env_cst with - | id, None -> get_var id - | _, Some t -> subst_type subst t - in - subst_type subst t - -let intern ~strict e = - let env = empty_env () in - let env = if strict then env else { env with env_str = false } in - let (e, t) = intern_rec env e in - let count = ref 0 in - let vars = ref UF.Map.empty in - let t = normalize env (count, vars) t in - (e, (!count, t)) - -let intern_typedef self (ids, t) : glb_quant_typedef = - let env = { (empty_env ()) with env_rec = self } in - (* Initialize type parameters *) - let map id = get_alias id env in - let ids = List.map map ids in - let count = ref (List.length ids) in - let vars = ref UF.Map.empty in - let iter n id = vars := UF.Map.add id (GTypVar n) !vars in - let () = List.iteri iter ids in - (* Do not accept unbound type variables *) - let env = { env with env_opn = false } in - let intern t = - let t = intern_type env t in - normalize env (count, vars) t - in - let count = !count in - match t with - | CTydDef None -> (count, GTydDef None) - | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) - | CTydAlg constrs -> - let map (c, t) = (c, List.map intern t) in - let constrs = List.map map constrs in - let getn (const, nonconst) (c, args) = match args with - | [] -> (succ const, nonconst) - | _ :: _ -> (const, succ nonconst) - in - let nconst, nnonconst = List.fold_left getn (0, 0) constrs in - let galg = { - galg_constructors = constrs; - galg_nconst = nconst; - galg_nnonconst = nnonconst; - } in - (count, GTydAlg galg) - | CTydRec fields -> - let map (c, mut, t) = (c, mut, intern t) in - let fields = List.map map fields in - (count, GTydRec fields) - | CTydOpn -> (count, GTydOpn) - -let intern_open_type t = - let env = empty_env () in - let t = intern_type env t in - let count = ref 0 in - let vars = ref UF.Map.empty in - let t = normalize env (count, vars) t in - (!count, t) - -(** Subtyping *) - -let check_subtype t1 t2 = - let env = empty_env () in - let t1 = fresh_type_scheme env t1 in - (* We build a substitution mimicking rigid variable by using dummy tuples *) - let rigid i = GTypRef (Tuple (i + 1), []) in - let (n, t2) = t2 in - let subst = Array.init n rigid in - let substf i = subst.(i) in - let t2 = subst_type substf t2 in - try unify0 env t1 t2; true with CannotUnify _ -> false - -(** Globalization *) - -let get_projection0 var = match var with -| RelId qid -> - let kn = try Tac2env.locate_projection qid with Not_found -> - user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") - in - kn -| AbsKn kn -> kn - -let rec globalize ids ({loc;v=er} as e) = match er with -| CTacAtm _ -> e -| CTacRef ref -> - let mem id = Id.Set.mem id ids in - begin match get_variable0 mem ref with - | ArgVar _ -> e - | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) - end -| CTacCst qid -> - let knc = get_constructor () qid in - CAst.make ?loc @@ CTacCst (AbsKn knc) -| CTacFun (bnd, e) -> - let fold (pats, accu) pat = - let accu = ids_of_pattern accu pat in - let pat = globalize_pattern ids pat in - (pat :: pats, accu) - in - let bnd, ids = List.fold_left fold ([], ids) bnd in - let bnd = List.rev bnd in - let e = globalize ids e in - CAst.make ?loc @@ CTacFun (bnd, e) -| CTacApp (e, el) -> - let e = globalize ids e in - let el = List.map (fun e -> globalize ids e) el in - CAst.make ?loc @@ CTacApp (e, el) -| CTacLet (isrec, bnd, e) -> - let fold accu (pat, _) = ids_of_pattern accu pat in - let ext = List.fold_left fold Id.Set.empty bnd in - let eids = Id.Set.union ext ids in - let e = globalize eids e in - let map (qid, e) = - let ids = if isrec then eids else ids in - let qid = globalize_pattern ids qid in - (qid, globalize ids e) - in - let bnd = List.map map bnd in - CAst.make ?loc @@ CTacLet (isrec, bnd, e) -| CTacCnv (e, t) -> - let e = globalize ids e in - CAst.make ?loc @@ CTacCnv (e, t) -| CTacSeq (e1, e2) -> - let e1 = globalize ids e1 in - let e2 = globalize ids e2 in - CAst.make ?loc @@ CTacSeq (e1, e2) -| CTacCse (e, bl) -> - let e = globalize ids e in - let bl = List.map (fun b -> globalize_case ids b) bl in - CAst.make ?loc @@ CTacCse (e, bl) -| CTacRec r -> - let map (p, e) = - let p = get_projection0 p in - let e = globalize ids e in - (AbsKn p, e) - in - CAst.make ?loc @@ CTacRec (List.map map r) -| CTacPrj (e, p) -> - let e = globalize ids e in - let p = get_projection0 p in - CAst.make ?loc @@ CTacPrj (e, AbsKn p) -| CTacSet (e, p, e') -> - let e = globalize ids e in - let p = get_projection0 p in - let e' = globalize ids e' in - CAst.make ?loc @@ CTacSet (e, AbsKn p, e') -| CTacExt (tag, arg) -> - let arg = str (Tac2dyn.Arg.repr tag) in - CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) - -and globalize_case ids (p, e) = - (globalize_pattern ids p, globalize ids e) - -and globalize_pattern ids ({loc;v=pr} as p) = match pr with -| CPatVar _ -> p -| CPatRef (cst, pl) -> - let knc = get_constructor () cst in - let cst = AbsKn knc in - let pl = List.map (fun p -> globalize_pattern ids p) pl in - CAst.make ?loc @@ CPatRef (cst, pl) -| CPatCnv (pat, ty) -> - let pat = globalize_pattern ids pat in - CAst.make ?loc @@ CPatCnv (pat, ty) - -(** Kernel substitution *) - -open Mod_subst - -let subst_or_tuple f subst o = match o with -| Tuple _ -> o -| Other v -> - let v' = f subst v in - if v' == v then o else Other v' - -let rec subst_type subst t = match t with -| GTypVar _ -> t -| GTypArrow (t1, t2) -> - let t1' = subst_type subst t1 in - let t2' = subst_type subst t2 in - if t1' == t1 && t2' == t2 then t - else GTypArrow (t1', t2') -| GTypRef (kn, tl) -> - let kn' = subst_or_tuple subst_kn subst kn in - let tl' = List.Smart.map (fun t -> subst_type subst t) tl in - if kn' == kn && tl' == tl then t else GTypRef (kn', tl') - -let rec subst_expr subst e = match e with -| GTacAtm _ | GTacVar _ | GTacPrm _ -> e -| GTacRef kn -> GTacRef (subst_kn subst kn) -| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) -| GTacApp (f, args) -> - GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) -| GTacLet (r, bs, e) -> - let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in - GTacLet (r, bs, subst_expr subst e) -| GTacCst (t, n, el) as e0 -> - let t' = subst_or_tuple subst_kn subst t in - let el' = List.Smart.map (fun e -> subst_expr subst e) el in - if t' == t && el' == el then e0 else GTacCst (t', n, el') -| GTacCse (e, ci, cse0, cse1) -> - let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in - let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in - let ci' = subst_or_tuple subst_kn subst ci in - GTacCse (subst_expr subst e, ci', cse0', cse1') -| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> - let e' = subst_expr subst e in - let def' = subst_expr subst def in - let fold kn (self, vars, p) accu = - let kn' = subst_kn subst kn in - let p' = subst_expr subst p in - if kn' == kn && p' == p then accu - else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) - in - let br' = KNmap.fold fold br br in - if e' == e && br' == br && def' == def then e0 - else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } -| GTacPrj (kn, e, p) as e0 -> - let kn' = subst_kn subst kn in - let e' = subst_expr subst e in - if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) -| GTacSet (kn, e, p, r) as e0 -> - let kn' = subst_kn subst kn in - let e' = subst_expr subst e in - let r' = subst_expr subst r in - if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') -| GTacExt (tag, arg) -> - let tpe = interp_ml_object tag in - let arg' = tpe.ml_subst subst arg in - if arg' == arg then e else GTacExt (tag, arg') -| GTacOpn (kn, el) as e0 -> - let kn' = subst_kn subst kn in - let el' = List.Smart.map (fun e -> subst_expr subst e) el in - if kn' == kn && el' == el then e0 else GTacOpn (kn', el') - -let subst_typedef subst e = match e with -| GTydDef t -> - let t' = Option.Smart.map (fun t -> subst_type subst t) t in - if t' == t then e else GTydDef t' -| GTydAlg galg -> - let map (c, tl as p) = - let tl' = List.Smart.map (fun t -> subst_type subst t) tl in - if tl' == tl then p else (c, tl') - in - let constrs' = List.Smart.map map galg.galg_constructors in - if constrs' == galg.galg_constructors then e - else GTydAlg { galg with galg_constructors = constrs' } -| GTydRec fields -> - let map (c, mut, t as p) = - let t' = subst_type subst t in - if t' == t then p else (c, mut, t') - in - let fields' = List.Smart.map map fields in - if fields' == fields then e else GTydRec fields' -| GTydOpn -> GTydOpn - -let subst_quant_typedef subst (prm, def as qdef) = - let def' = subst_typedef subst def in - if def' == def then qdef else (prm, def') - -let subst_type_scheme subst (prm, t as sch) = - let t' = subst_type subst t in - if t' == t then sch else (prm, t') - -let subst_or_relid subst ref = match ref with -| RelId _ -> ref -| AbsKn kn -> - let kn' = subst_or_tuple subst_kn subst kn in - if kn' == kn then ref else AbsKn kn' - -let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with -| CTypVar _ -> t -| CTypArrow (t1, t2) -> - let t1' = subst_rawtype subst t1 in - let t2' = subst_rawtype subst t2 in - if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') -| CTypRef (ref, tl) -> - let ref' = subst_or_relid subst ref in - let tl' = List.Smart.map (fun t -> subst_rawtype subst t) tl in - if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') - -let subst_tacref subst ref = match ref with -| RelId _ -> ref -| AbsKn (TacConstant kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacConstant kn') -| AbsKn (TacAlias kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ref else AbsKn (TacAlias kn') - -let subst_projection subst prj = match prj with -| RelId _ -> prj -| AbsKn kn -> - let kn' = subst_kn subst kn in - if kn' == kn then prj else AbsKn kn' - -let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with -| CPatVar _ -> p -| CPatRef (c, pl) -> - let pl' = List.Smart.map (fun p -> subst_rawpattern subst p) pl in - let c' = subst_or_relid subst c in - if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') -| CPatCnv (pat, ty) -> - let pat' = subst_rawpattern subst pat in - let ty' = subst_rawtype subst ty in - if pat' == pat && ty' == ty then p else CAst.make ?loc @@ CPatCnv (pat', ty') - -(** Used for notations *) -let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with -| CTacAtm _ -> t -| CTacRef ref -> - let ref' = subst_tacref subst ref in - if ref' == ref then t else CAst.make ?loc @@ CTacRef ref' -| CTacCst ref -> - let ref' = subst_or_relid subst ref in - if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' -| CTacFun (bnd, e) -> - let map pat = subst_rawpattern subst pat in - let bnd' = List.Smart.map map bnd in - let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') -| CTacApp (e, el) -> - let e' = subst_rawexpr subst e in - let el' = List.Smart.map (fun e -> subst_rawexpr subst e) el in - if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') -| CTacLet (isrec, bnd, e) -> - let map (na, e as p) = - let na' = subst_rawpattern subst na in - let e' = subst_rawexpr subst e in - if na' == na && e' == e then p else (na', e') - in - let bnd' = List.Smart.map map bnd in - let e' = subst_rawexpr subst e in - if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') -| CTacCnv (e, c) -> - let e' = subst_rawexpr subst e in - let c' = subst_rawtype subst c in - if c' == c && e' == e then t else CAst.make ?loc @@ CTacCnv (e', c') -| CTacSeq (e1, e2) -> - let e1' = subst_rawexpr subst e1 in - let e2' = subst_rawexpr subst e2 in - if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') -| CTacCse (e, bl) -> - let map (p, e as x) = - let p' = subst_rawpattern subst p in - let e' = subst_rawexpr subst e in - if p' == p && e' == e then x else (p', e') - in - let e' = subst_rawexpr subst e in - let bl' = List.Smart.map map bl in - if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') -| CTacRec el -> - let map (prj, e as p) = - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then p else (prj', e') - in - let el' = List.Smart.map map el in - if el' == el then t else CAst.make ?loc @@ CTacRec el' -| CTacPrj (e, prj) -> - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - if prj' == prj && e' == e then t else CAst.make ?loc @@ CTacPrj (e', prj') -| CTacSet (e, prj, r) -> - let prj' = subst_projection subst prj in - let e' = subst_rawexpr subst e in - let r' = subst_rawexpr subst r in - if prj' == prj && e' == e && r' == r then t else CAst.make ?loc @@ CTacSet (e', prj', r') -| CTacExt _ -> assert false (** Should not be generated by globalization *) - -(** Registering *) - -let () = - let open Genintern in - let intern ist tac = - let env = match Genintern.Store.get ist.extra ltac2_env with - | None -> - (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) - let env = empty_env () in - if !Ltac_plugin.Tacintern.strict_check then env - else { env with env_str = false } - | Some env -> env - in - let loc = tac.loc in - let (tac, t) = intern_rec env tac in - let () = check_elt_unit loc env t in - (ist, tac) - in - Genintern.register_intern0 wit_ltac2 intern -let () = Genintern.register_subst0 wit_ltac2 subst_expr - -let () = - let open Genintern in - let intern ist (loc, id) = - let env = match Genintern.Store.get ist.extra ltac2_env with - | None -> - (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) - let env = empty_env () in - if !Ltac_plugin.Tacintern.strict_check then env - else { env with env_str = false } - | Some env -> env - in - let t = - try Id.Map.find id env.env_var - with Not_found -> - CErrors.user_err ?loc (str "Unbound value " ++ Id.print id) - in - let t = fresh_mix_type_scheme env t in - let () = unify ?loc env t (GTypRef (Other t_constr, [])) in - (ist, id) - in - Genintern.register_intern0 wit_ltac2_quotation intern - -let () = Genintern.register_subst0 wit_ltac2_quotation (fun _ id -> id) diff --git a/vendor/Ltac2/src/tac2intern.mli b/vendor/Ltac2/src/tac2intern.mli deleted file mode 100644 index d646b5cda5..0000000000 --- a/vendor/Ltac2/src/tac2intern.mli +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_tacexpr -> glb_tacexpr * type_scheme -val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef -val intern_open_type : raw_typexpr -> type_scheme - -(** Check that a term is a value. Only values are safe to marshall between - processes. *) -val is_value : glb_tacexpr -> bool -val check_unit : ?loc:Loc.t -> type_scheme -> unit - -val check_subtype : type_scheme -> type_scheme -> bool -(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] - also have type [t2]. *) - -val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr -val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr -val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef -val subst_type_scheme : substitution -> type_scheme -> type_scheme - -val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr - -(** {5 Notations} *) - -val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr -(** Replaces all qualified identifiers by their corresponding kernel name. The - set represents bound variables in the context. *) - -(** Errors *) - -val error_nargs_mismatch : ?loc:Loc.t -> ltac_constructor -> int -> int -> 'a -val error_nparams_mismatch : ?loc:Loc.t -> int -> int -> 'a - -(** Misc *) - -val drop_ltac2_env : Genintern.Store.t -> Genintern.Store.t diff --git a/vendor/Ltac2/src/tac2interp.ml b/vendor/Ltac2/src/tac2interp.ml deleted file mode 100644 index b0f8083aeb..0000000000 --- a/vendor/Ltac2/src/tac2interp.ml +++ /dev/null @@ -1,227 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* >= fun sigma -> - match Evd.Store.get (Evd.get_extra_data sigma) backtrace with - | None -> Proofview.tclUNIT [] - | Some bt -> Proofview.tclUNIT bt - -let set_backtrace bt = - Proofview.tclEVARMAP >>= fun sigma -> - let store = Evd.get_extra_data sigma in - let store = Evd.Store.set store backtrace bt in - let sigma = Evd.set_extra_data store sigma in - Proofview.Unsafe.tclEVARS sigma - -let with_frame frame tac = - if !print_ltac2_backtrace then - get_backtrace >>= fun bt -> - set_backtrace (frame :: bt) >>= fun () -> - tac >>= fun ans -> - set_backtrace bt >>= fun () -> - Proofview.tclUNIT ans - else tac - -type environment = Tac2env.environment = { - env_ist : valexpr Id.Map.t; -} - -let empty_environment = { - env_ist = Id.Map.empty; -} - -type closure = { - mutable clos_env : valexpr Id.Map.t; - (** Mutable so that we can implement recursive functions imperatively *) - clos_var : Name.t list; - (** Bound variables *) - clos_exp : glb_tacexpr; - (** Body *) - clos_ref : ltac_constant option; - (** Global constant from which the closure originates *) -} - -let push_name ist id v = match id with -| Anonymous -> ist -| Name id -> { env_ist = Id.Map.add id v ist.env_ist } - -let get_var ist id = - try Id.Map.find id ist.env_ist with Not_found -> - anomaly (str "Unbound variable " ++ Id.print id) - -let get_ref ist kn = - try - let data = Tac2env.interp_global kn in - data.Tac2env.gdata_expr - with Not_found -> - anomaly (str "Unbound reference" ++ KerName.print kn) - -let return = Proofview.tclUNIT - -let rec interp (ist : environment) = function -| GTacAtm (AtmInt n) -> return (Tac2ffi.of_int n) -| GTacAtm (AtmStr s) -> return (Tac2ffi.of_string (Bytes.of_string s)) -| GTacVar id -> return (get_var ist id) -| GTacRef kn -> - let data = get_ref ist kn in - return (eval_pure (Some kn) data) -| GTacFun (ids, e) -> - let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - let f = interp_app cls in - return (Tac2ffi.of_closure f) -| GTacApp (f, args) -> - interp ist f >>= fun f -> - Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> - Tac2ffi.apply (Tac2ffi.to_closure f) args -| GTacLet (false, el, e) -> - let fold accu (na, e) = - interp ist e >>= fun e -> - return (push_name accu na e) - in - Proofview.Monad.List.fold_left fold ist el >>= fun ist -> - interp ist e -| GTacLet (true, el, e) -> - let map (na, e) = match e with - | GTacFun (ids, e) -> - let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in - let f = Tac2ffi.of_closure (interp_app cls) in - na, cls, f - | _ -> anomaly (str "Ill-formed recursive function") - in - let fixs = List.map map el in - let fold accu (na, _, cls) = match na with - | Anonymous -> accu - | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } - in - let ist = List.fold_left fold ist fixs in - (* Hack to make a cycle imperatively in the environment *) - let iter (_, e, _) = e.clos_env <- ist.env_ist in - let () = List.iter iter fixs in - interp ist e -| GTacCst (_, n, []) -> return (Valexpr.make_int n) -| GTacCst (_, n, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (Valexpr.make_block n (Array.of_list el)) -| GTacCse (e, _, cse0, cse1) -> - interp ist e >>= fun e -> interp_case ist e cse0 cse1 -| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> - interp ist e >>= fun e -> interp_with ist e cse def -| GTacPrj (_, e, p) -> - interp ist e >>= fun e -> interp_proj ist e p -| GTacSet (_, e, p, r) -> - interp ist e >>= fun e -> - interp ist r >>= fun r -> - interp_set ist e p r -| GTacOpn (kn, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - return (Tac2ffi.of_open (kn, Array.of_list el)) -| GTacPrm (ml, el) -> - Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> - with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) -| GTacExt (tag, e) -> - let tpe = Tac2env.interp_ml_object tag in - with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) - -and interp_app f = - let ans = fun args -> - let { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } = f in - let frame = match kn with - | None -> FrAnon e - | Some kn -> FrLtac kn - in - let ist = { env_ist = ist } in - let ist = List.fold_left2 push_name ist ids args in - with_frame frame (interp ist e) - in - Tac2ffi.abstract (List.length f.clos_var) ans - -and interp_case ist e cse0 cse1 = - if Valexpr.is_int e then - interp ist cse0.(Tac2ffi.to_int e) - else - let (n, args) = Tac2ffi.to_block e in - let (ids, e) = cse1.(n) in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist e - -and interp_with ist e cse def = - let (kn, args) = Tac2ffi.to_open e in - let br = try Some (KNmap.find kn cse) with Not_found -> None in - begin match br with - | None -> - let (self, def) = def in - let ist = push_name ist self e in - interp ist def - | Some (self, ids, p) -> - let ist = push_name ist self e in - let ist = CArray.fold_left2 push_name ist ids args in - interp ist p - end - -and interp_proj ist e p = - return (Valexpr.field e p) - -and interp_set ist e p r = - let () = Valexpr.set_field e p r in - return (Valexpr.make_int 0) - -and eval_pure kn = function -| GTacAtm (AtmInt n) -> Valexpr.make_int n -| GTacRef kn -> - let { Tac2env.gdata_expr = e } = - try Tac2env.interp_global kn - with Not_found -> assert false - in - eval_pure (Some kn) e -| GTacFun (na, e) -> - let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in - let f = interp_app cls in - Tac2ffi.of_closure f -| GTacCst (_, n, []) -> Valexpr.make_int n -| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) -| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) -| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ -| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> - anomaly (Pp.str "Term is not a syntactical value") - -and eval_unnamed e = eval_pure None e - - -(** Cross-boundary hacks. *) - -open Geninterp - -let val_env : environment Val.typ = Val.create "ltac2:env" -let env_ref = Id.of_string_soft "@@ltac2_env@@" - -let extract_env (Val.Dyn (tag, v)) : environment = -match Val.eq tag val_env with -| None -> assert false -| Some Refl -> v - -let get_env ist = - try extract_env (Id.Map.find env_ref ist) - with Not_found -> empty_environment - -let set_env env ist = - Id.Map.add env_ref (Val.Dyn (val_env, env)) ist diff --git a/vendor/Ltac2/src/tac2interp.mli b/vendor/Ltac2/src/tac2interp.mli deleted file mode 100644 index 21fdcd03af..0000000000 --- a/vendor/Ltac2/src/tac2interp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glb_tacexpr -> valexpr Proofview.tactic - -(* val interp_app : closure -> ml_tactic *) - -(** {5 Cross-boundary encodings} *) - -val get_env : Ltac_pretype.unbound_ltac_var_map -> environment -val set_env : environment -> Ltac_pretype.unbound_ltac_var_map -> Ltac_pretype.unbound_ltac_var_map - -(** {5 Exceptions} *) - -exception LtacError of KerName.t * valexpr array -(** Ltac2-defined exceptions seen from OCaml side *) - -(** {5 Backtrace} *) - -val get_backtrace : backtrace Proofview.tactic - -val with_frame : frame -> 'a Proofview.tactic -> 'a Proofview.tactic - -val print_ltac2_backtrace : bool ref diff --git a/vendor/Ltac2/src/tac2match.ml b/vendor/Ltac2/src/tac2match.ml deleted file mode 100644 index c9e549d47e..0000000000 --- a/vendor/Ltac2/src/tac2match.ml +++ /dev/null @@ -1,232 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* None - | None, Some c | Some c, None -> Some c - | Some c1, Some c2 -> - if equal_instances env sigma c1 c2 then Some c1 - else raise Not_coherent_metas - in - Id.Map.merge merge s1 s2 - -let matching_error = - CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") - -let imatching_error = (matching_error, Exninfo.null) - -(** A functor is introduced to share the environment and the - evar_map. They do not change and it would be a pity to introduce - closures everywhere just for the occasional calls to - {!equal_instances}. *) -module type StaticEnvironment = sig - val env : Environ.env - val sigma : Evd.evar_map -end -module PatternMatching (E:StaticEnvironment) = struct - - - (** {6 The pattern-matching monad } *) - - - (** To focus on the algorithmic portion of pattern-matching, the - bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) - (* spiwack: as we don't benefit from the various stream optimisations - of Haskell, it may be costly to give the monad in direct style such as - here. We may want to use some continuation passing style. *) - type 'a tac = 'a Proofview.tactic - type 'a m = { stream : 'r. ('a -> result -> 'r tac) -> result -> 'r tac } - - (** The empty substitution. *) - let empty_subst = Id.Map.empty - - (** Composes two substitutions using {!verify_metas_coherence}. It - must be a monoid with neutral element {!empty_subst}. Raises - [Not_coherent_metas] when composition cannot be achieved. *) - let subst_prod s1 s2 = - if is_empty_subst s1 then s2 - else if is_empty_subst s2 then s1 - else verify_metas_coherence E.env E.sigma s1 s2 - - (** Merge two writers (and ignore the first value component). *) - let merge m1 m2 = - try Some { - subst = subst_prod m1.subst m2.subst; - } - with Not_coherent_metas -> None - - (** Monadic [return]: returns a single success with empty substitutions. *) - let return (type a) (lhs:a) : a m = - { stream = fun k ctx -> k lhs ctx } - - (** Monadic bind: each success of [x] is replaced by the successes - of [f x]. The substitutions of [x] and [f x] are composed, - dropping the apparent successes when the substitutions are not - coherent. *) - let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = - { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } - - (** A variant of [(>>=)] when the first argument returns [unit]. *) - let (<*>) (type a) (m:unit m) (y:a m) : a m = - { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } - - (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } - - let run (m : 'a m) = - let ctx = { - subst = empty_subst ; - } in - let eval x ctx = Proofview.tclUNIT (x, ctx) in - m.stream eval ctx - - (** Chooses in a list, in the same order as the list *) - let rec pick (l:'a list) (e, info) : 'a m = match l with - | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } - | x :: l -> - { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } - - let pick l = pick l imatching_error - - let put_subst subst : unit m = - let s = { subst } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } - - (** {6 Pattern-matching} *) - - let pattern_match_term pat term = - match pat with - | MatchPattern p -> - begin - try - put_subst (Constr_matching.matches E.env E.sigma p term) <*> - return None - with Constr_matching.PatternMatchingFailure -> fail - end - | MatchContext p -> - - let rec map s (e, info) = - { stream = fun k ctx -> match IStream.peek s with - | IStream.Nil -> Proofview.tclZERO ~info e - | IStream.Cons ({ Constr_matching.m_sub = (_, subst); m_ctx }, s) -> - let nctx = { subst } in - match merge ctx nctx with - | None -> (map s (e, info)).stream k ctx - | Some nctx -> Proofview.tclOR (k (Some (Lazy.force m_ctx)) nctx) (fun e -> (map s e).stream k ctx) - } - in - map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error - - let hyp_match_type pat hyps = - pick hyps >>= fun decl -> - let id = NamedDecl.get_id decl in - pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> - return (id, ctx) - - let _hyp_match_body_and_type bodypat typepat hyps = - pick hyps >>= function - | LocalDef (id,body,hyp) -> - pattern_match_term bodypat body >>= fun ctx_body -> - pattern_match_term typepat hyp >>= fun ctx_typ -> - return (id, ctx_body, ctx_typ) - | LocalAssum (id,hyp) -> fail - - let hyp_match pat hyps = - match pat with - | typepat -> - hyp_match_type typepat hyps -(* | Def ((_,hypname),bodypat,typepat) -> *) -(* hyp_match_body_and_type hypname bodypat typepat hyps *) - - (** [hyp_pattern_list_match pats hyps lhs], matches the list of - patterns [pats] against the hypotheses in [hyps], and eventually - returns [lhs]. *) - let rec hyp_pattern_list_match pats hyps accu = - match pats with - | pat::pats -> - hyp_match pat hyps >>= fun (matched_hyp, hyp_ctx) -> - let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in - let hyps = CList.remove_first select_matched_hyp hyps in - hyp_pattern_list_match pats hyps ((matched_hyp, hyp_ctx) :: accu) - | [] -> return accu - - let rule_match_goal hyps concl = function - | (hyppats,conclpat) -> - (* the rules are applied from the topmost one (in the concrete - syntax) to the bottommost. *) - let hyppats = List.rev hyppats in - pattern_match_term conclpat concl >>= fun ctx_concl -> - hyp_pattern_list_match hyppats hyps [] >>= fun hyps -> - return (hyps, ctx_concl) - -end - -let match_goal env sigma concl ~rev rule = - let open Proofview.Notations in - let hyps = EConstr.named_context env in - let hyps = if rev then List.rev hyps else hyps in - let module E = struct - let env = env - let sigma = sigma - end in - let module M = PatternMatching(E) in - M.run (M.rule_match_goal hyps concl rule) >>= fun ((hyps, ctx_concl), subst) -> - Proofview.tclUNIT (hyps, ctx_concl, subst.subst) diff --git a/vendor/Ltac2/src/tac2match.mli b/vendor/Ltac2/src/tac2match.mli deleted file mode 100644 index c82c40d238..0000000000 --- a/vendor/Ltac2/src/tac2match.mli +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Evd.evar_map -> - constr -> - rev:bool -> - match_rule -> - ((Id.t * context option) list * (* List of hypotheses matching: name + context *) - context option * (* Context for conclusion *) - Ltac_pretype.patvar_map (* Pattern variable substitution *)) Proofview.tactic diff --git a/vendor/Ltac2/src/tac2print.ml b/vendor/Ltac2/src/tac2print.ml deleted file mode 100644 index f4cb290265..0000000000 --- a/vendor/Ltac2/src/tac2print.ml +++ /dev/null @@ -1,488 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* str "'" ++ str (pr n) - | GTypRef (Other kn, []) -> pr_typref kn - | GTypRef (Other kn, [t]) -> - let paren = match lvl with - | T5_r | T5_l | T2 | T1 -> fun x -> x - | T0 -> paren - in - paren (pr_glbtype T1 t ++ spc () ++ pr_typref kn) - | GTypRef (Other kn, tl) -> - let paren = match lvl with - | T5_r | T5_l | T2 | T1 -> fun x -> x - | T0 -> paren - in - paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) - | GTypArrow (t1, t2) -> - let paren = match lvl with - | T5_r -> fun x -> x - | T5_l | T2 | T1 | T0 -> paren - in - paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) - | GTypRef (Tuple 0, []) -> - Libnames.pr_qualid (Tac2env.shortest_qualid_of_type t_unit) - | GTypRef (Tuple _, tl) -> - let paren = match lvl with - | T5_r | T5_l -> fun x -> x - | T2 | T1 | T0 -> paren - in - paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) - in - hov 0 (pr_glbtype lvl c) - -let pr_glbtype pr c = pr_glbtype_gen pr T5_r c - -let int_name () = - let vars = ref Int.Map.empty in - fun n -> - if Int.Map.mem n !vars then Int.Map.find n !vars - else - let num = Int.Map.cardinal !vars in - let base = num mod 26 in - let rem = num / 26 in - let name = String.make 1 (Char.chr (97 + base)) in - let suff = if Int.equal rem 0 then "" else string_of_int rem in - let name = name ^ suff in - let () = vars := Int.Map.add n name !vars in - name - -(** Term printing *) - -let pr_constructor kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_constructor kn) - -let pr_projection kn = - Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) - -type exp_level = Tac2expr.exp_level = -| E5 -| E4 -| E3 -| E2 -| E1 -| E0 - -let pr_atom = function -| AtmInt n -> Pp.int n -| AtmStr s -> qstring s - -let pr_name = function -| Name id -> Id.print id -| Anonymous -> str "_" - -let find_constructor n empty def = - let rec find n = function - | [] -> assert false - | (id, []) as ans :: rem -> - if empty then - if Int.equal n 0 then ans - else find (pred n) rem - else find n rem - | (id, _ :: _) as ans :: rem -> - if not empty then - if Int.equal n 0 then ans - else find (pred n) rem - else find n rem - in - find n def - -let pr_internal_constructor tpe n is_const = - let data = match Tac2env.interp_type tpe with - | (_, GTydAlg data) -> data - | _ -> assert false - in - let (id, _) = find_constructor n is_const data.galg_constructors in - let kn = change_kn_label tpe id in - pr_constructor kn - -let order_branches cbr nbr def = - let rec order cidx nidx def = match def with - | [] -> [] - | (id, []) :: rem -> - let ans = order (succ cidx) nidx rem in - (id, [], cbr.(cidx)) :: ans - | (id, _ :: _) :: rem -> - let ans = order cidx (succ nidx) rem in - let (vars, e) = nbr.(nidx) in - (id, Array.to_list vars, e) :: ans - in - order 0 0 def - -let pr_glbexpr_gen lvl c = - let rec pr_glbexpr lvl = function - | GTacAtm atm -> pr_atom atm - | GTacVar id -> Id.print id - | GTacRef gr -> - let qid = shortest_qualid_of_ltac (TacConstant gr) in - Libnames.pr_qualid qid - | GTacFun (nas, c) -> - let nas = pr_sequence pr_name nas in - let paren = match lvl with - | E0 | E1 | E2 | E3 | E4 -> paren - | E5 -> fun x -> x - in - paren (hov 0 (hov 2 (str "fun" ++ spc () ++ nas) ++ spc () ++ str "=>" ++ spc () ++ - pr_glbexpr E5 c)) - | GTacApp (c, cl) -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - paren (hov 2 (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) - | GTacLet (mut, bnd, e) -> - let paren = match lvl with - | E0 | E1 | E2 | E3 | E4 -> paren - | E5 -> fun x -> x - in - let mut = if mut then str "rec" ++ spc () else mt () in - let pr_bnd (na, e) = - pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () - in - let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in - paren (hv 0 (hov 2 (str "let" ++ spc () ++ mut ++ bnd ++ str "in") ++ spc () ++ pr_glbexpr E5 e)) - | GTacCst (Tuple 0, _, _) -> str "()" - | GTacCst (Tuple _, _, cl) -> - let paren = match lvl with - | E0 | E1 -> paren - | E2 | E3 | E4 | E5 -> fun x -> x - in - paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) - | GTacCst (Other tpe, n, cl) -> - pr_applied_constructor lvl tpe n cl - | GTacCse (e, info, cst_br, ncst_br) -> - let e = pr_glbexpr E5 e in - let br = match info with - | Other kn -> - let def = match Tac2env.interp_type kn with - | _, GTydAlg { galg_constructors = def } -> def - | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false - in - let br = order_branches cst_br ncst_br def in - let pr_branch (cstr, vars, p) = - let cstr = change_kn_label kn cstr in - let cstr = pr_constructor cstr in - let vars = match vars with - | [] -> mt () - | _ -> spc () ++ pr_sequence pr_name vars - in - hov 4 (str "|" ++ spc () ++ hov 0 (cstr ++ vars ++ spc () ++ str "=>") ++ spc () ++ - hov 2 (pr_glbexpr E5 p)) ++ spc () - in - prlist pr_branch br - | Tuple n -> - let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in - let p = pr_glbexpr E5 p in - let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in - hov 4 (str "|" ++ spc () ++ hov 0 (paren vars ++ spc () ++ str "=>") ++ spc () ++ p) - in - v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ spc () ++ str "end") - | GTacWth wth -> - let e = pr_glbexpr E5 wth.opn_match in - let pr_pattern c self vars p = - let self = match self with - | Anonymous -> mt () - | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id - in - hov 4 (str "|" ++ spc () ++ hov 0 (c ++ vars ++ self ++ spc () ++ str "=>") ++ spc () ++ - hov 2 (pr_glbexpr E5 p)) ++ spc () - in - let pr_branch (cstr, (self, vars, p)) = - let cstr = pr_constructor cstr in - let vars = match Array.to_list vars with - | [] -> mt () - | vars -> spc () ++ pr_sequence pr_name vars - in - pr_pattern cstr self vars p - in - let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in - let (def_as, def_p) = wth.opn_default in - let def = pr_pattern (str "_") def_as (mt ()) def_p in - let br = br ++ def in - v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ str "end") - | GTacPrj (kn, e, n) -> - let def = match Tac2env.interp_type kn with - | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false - in - let (proj, _, _) = List.nth def n in - let proj = change_kn_label kn proj in - let proj = pr_projection proj in - let e = pr_glbexpr E0 e in - hov 0 (e ++ str "." ++ paren proj) - | GTacSet (kn, e, n, r) -> - let def = match Tac2env.interp_type kn with - | _, GTydRec def -> def - | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false - in - let (proj, _, _) = List.nth def n in - let proj = change_kn_label kn proj in - let proj = pr_projection proj in - let e = pr_glbexpr E0 e in - let r = pr_glbexpr E1 r in - hov 0 (e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r) - | GTacOpn (kn, cl) -> - let paren = match lvl with - | E0 -> paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let c = pr_constructor kn in - paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) - | GTacExt (tag, arg) -> - let tpe = interp_ml_object tag in - hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) - | GTacPrm (prm, args) -> - let args = match args with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args - in - hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ - qstring prm.mltac_tactic ++ args) - and pr_applied_constructor lvl tpe n cl = - let _, data = Tac2env.interp_type tpe in - if KerName.equal tpe t_list then - let rec factorize accu = function - | GTacCst (_, 0, []) -> accu, None - | GTacCst (_, 0, [e; l]) -> factorize (e :: accu) l - | e -> accu, Some e - in - let l, e = factorize [] (GTacCst (Other tpe, n, cl)) in - match e with - | None -> - let pr e = pr_glbexpr E4 e in - hov 2 (str "[" ++ prlist_with_sep pr_semicolon pr (List.rev l) ++ str "]") - | Some e -> - let paren = match lvl with - | E0 | E1 | E2 -> paren - | E3 | E4 | E5 -> fun x -> x - in - let pr e = pr_glbexpr E1 e in - let pr_cons () = spc () ++ str "::" ++ spc () in - paren (hov 2 (prlist_with_sep pr_cons pr (List.rev (e :: l)))) - else match data with - | GTydAlg def -> - let paren = match lvl with - | E0 -> - if List.is_empty cl then fun x -> x else paren - | E1 | E2 | E3 | E4 | E5 -> fun x -> x - in - let cstr = pr_internal_constructor tpe n (List.is_empty cl) in - let cl = match cl with - | [] -> mt () - | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl - in - paren (hov 2 (cstr ++ cl)) - | GTydRec def -> - let args = List.combine def cl in - let pr_arg ((id, _, _), arg) = - let kn = change_kn_label tpe id in - pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg - in - let args = prlist_with_sep pr_semicolon pr_arg args in - hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") - | (GTydDef _ | GTydOpn) -> assert false - in - hov 0 (pr_glbexpr lvl c) - - - -let pr_glbexpr c = - pr_glbexpr_gen E5 c - -(** Toplevel printers *) - -let rec subst_type subst (t : 'a glb_typexpr) = match t with -| GTypVar id -> subst.(id) -| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) -| GTypRef (qid, args) -> - GTypRef (qid, List.map (fun t -> subst_type subst t) args) - -let unfold kn args = - let (nparams, def) = Tac2env.interp_type kn in - match def with - | GTydDef (Some def) -> - let args = Array.of_list args in - Some (subst_type args def) - | _ -> None - -let rec kind t = match t with -| GTypVar id -> GTypVar id -| GTypRef (Other kn, tl) -> - begin match unfold kn tl with - | None -> t - | Some t -> kind t - end -| GTypArrow _ | GTypRef (Tuple _, _) -> t - -type val_printer = - { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } - -let printers = ref KNmap.empty - -let register_val_printer kn pr = - printers := KNmap.add kn pr !printers - -open Tac2ffi - -let rec pr_valexpr env sigma v t = match kind t with -| GTypVar _ -> str "" -| GTypRef (Other kn, params) -> - let pr = try Some (KNmap.find kn !printers) with Not_found -> None in - begin match pr with - | Some pr -> pr.val_printer env sigma v params - | None -> - let n, repr = Tac2env.interp_type kn in - if KerName.equal kn t_list then - pr_val_list env sigma (to_list (fun v -> repr_to valexpr v) v) (List.hd params) - else match repr with - | GTydDef None -> str "" - | GTydDef (Some _) -> - (* Shouldn't happen thanks to kind *) - assert false - | GTydAlg alg -> - if Valexpr.is_int v then - pr_internal_constructor kn (Tac2ffi.to_int v) true - else - let (n, args) = Tac2ffi.to_block v in - let (id, tpe) = find_constructor n false alg.galg_constructors in - let knc = change_kn_label kn id in - let args = pr_constrargs env sigma params args tpe in - hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - | GTydRec rcd -> - let (_, args) = Tac2ffi.to_block v in - pr_record env sigma params args rcd - | GTydOpn -> - begin match Tac2ffi.to_open v with - | (knc, [||]) -> pr_constructor knc - | (knc, args) -> - let data = Tac2env.interp_constructor knc in - let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in - hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") - end - end -| GTypArrow _ -> str "" -| GTypRef (Tuple 0, []) -> str "()" -| GTypRef (Tuple _, tl) -> - let blk = Array.to_list (snd (to_block v)) in - if List.length blk == List.length tl then - let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in - hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") - else - str "" - -and pr_constrargs env sigma params args tpe = - let subst = Array.of_list params in - let tpe = List.map (fun t -> subst_type subst t) tpe in - let args = Array.to_list args in - let args = List.combine args tpe in - prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args - -and pr_record env sigma params args rcd = - let subst = Array.of_list params in - let map (id, _, tpe) = (id, subst_type subst tpe) in - let rcd = List.map map rcd in - let args = Array.to_list args in - let fields = List.combine rcd args in - let pr_field ((id, t), arg) = - Id.print id ++ spc () ++ str ":=" ++ spc () ++ pr_valexpr env sigma arg t - in - str "{" ++ spc () ++ prlist_with_sep pr_semicolon pr_field fields ++ spc () ++ str "}" - -and pr_val_list env sigma args tpe = - let pr v = pr_valexpr env sigma v tpe in - str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" - -let register_init n f = - let kn = KerName.make Tac2env.coq_prefix (Label.make n) in - register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } - -let () = register_init "int" begin fun _ _ n -> - let n = to_int n in - Pp.int n -end - -let () = register_init "string" begin fun _ _ s -> - let s = to_string s in - Pp.quote (str (Bytes.to_string s)) -end - -let () = register_init "ident" begin fun _ _ id -> - let id = to_ident id in - str "@" ++ Id.print id -end - -let () = register_init "constr" begin fun env sigma c -> - let c = to_constr c in - let c = try Printer.pr_leconstr_env env sigma c with _ -> str "..." in - str "constr:(" ++ c ++ str ")" -end - -let () = register_init "pattern" begin fun env sigma c -> - let c = to_pattern c in - let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in - str "pattern:(" ++ c ++ str ")" -end - -let () = register_init "message" begin fun _ _ pp -> - str "message:(" ++ to_pp pp ++ str ")" -end - -let () = register_init "err" begin fun _ _ e -> - let e = to_ext val_exn e in - let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in - str "err:(" ++ CErrors.print_no_report e ++ str ")" -end - -let () = - let kn = KerName.make Tac2env.coq_prefix (Label.make "array") in - let val_printer env sigma v arg = match arg with - | [arg] -> - let (_, v) = to_block v in - str "[|" ++ spc () ++ - prvect_with_sep pr_semicolon (fun a -> pr_valexpr env sigma a arg) v ++ - spc () ++ str "|]" - | _ -> assert false - in - register_val_printer kn { val_printer } diff --git a/vendor/Ltac2/src/tac2print.mli b/vendor/Ltac2/src/tac2print.mli deleted file mode 100644 index 9b9db2937d..0000000000 --- a/vendor/Ltac2/src/tac2print.mli +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.t -val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> Pp.t -val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t - -(** {5 Printing expressions} *) - -val pr_constructor : ltac_constructor -> Pp.t -val pr_internal_constructor : type_constant -> int -> bool -> Pp.t -val pr_projection : ltac_projection -> Pp.t -val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t -val pr_glbexpr : glb_tacexpr -> Pp.t - -(** {5 Printing values}*) - -type val_printer = - { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } - -val register_val_printer : type_constant -> val_printer -> unit - -val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp.t - -(** {5 Utilities} *) - -val int_name : unit -> (int -> string) -(** Create a function that give names to integers. The names are generated on - the fly, in the order they are encountered. *) diff --git a/vendor/Ltac2/src/tac2qexpr.mli b/vendor/Ltac2/src/tac2qexpr.mli deleted file mode 100644 index 400ab1a092..0000000000 --- a/vendor/Ltac2/src/tac2qexpr.mli +++ /dev/null @@ -1,173 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0)) -| [e] -> e -| el -> - let len = List.length el in - CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) - -let of_int {loc;v=n} = - CAst.make ?loc @@ CTacAtm (AtmInt n) - -let of_option ?loc f opt = match opt with -| None -> constructor ?loc (coq_core "None") [] -| Some e -> constructor ?loc (coq_core "Some") [f e] - -let inj_wit ?loc wit x = - CAst.make ?loc @@ CTacExt (wit, x) - -let of_variable {loc;v=id} = - let qid = Libnames.qualid_of_ident ?loc id in - if Tac2env.is_constructor qid then - CErrors.user_err ?loc (str "Invalid identifier") - else CAst.make ?loc @@ CTacRef (RelId qid) - -let of_anti f = function -| QExpr x -> f x -| QAnti id -> of_variable id - -let of_ident {loc;v=id} = inj_wit ?loc wit_ident id - -let of_constr c = - let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc wit_constr c - -let of_open_constr c = - let loc = Constrexpr_ops.constr_loc c in - inj_wit ?loc wit_open_constr c - -let of_bool ?loc b = - let c = if b then coq_core "true" else coq_core "false" in - constructor ?loc c [] - -let rec of_list ?loc f = function -| [] -> constructor (coq_core "[]") [] -| e :: l -> - constructor ?loc (coq_core "::") [f e; of_list ?loc f l] - -let of_qhyp {loc;v=h} = match h with -| QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] -| QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] - -let of_bindings {loc;v=b} = match b with -| QNoBindings -> - std_constructor ?loc "NoBindings" [] -| QImplicitBindings tl -> - std_constructor ?loc "ImplicitBindings" [of_list ?loc of_open_constr tl] -| QExplicitBindings tl -> - let map e = of_pair (fun q -> of_anti of_qhyp q) of_open_constr e in - std_constructor ?loc "ExplicitBindings" [of_list ?loc map tl] - -let of_constr_with_bindings c = of_pair of_open_constr of_bindings c - -let rec of_intro_pattern {loc;v=pat} = match pat with -| QIntroForthcoming b -> - std_constructor ?loc "IntroForthcoming" [of_bool b] -| QIntroNaming iname -> - std_constructor ?loc "IntroNaming" [of_intro_pattern_naming iname] -| QIntroAction iact -> - std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] - -and of_intro_pattern_naming {loc;v=pat} = match pat with -| QIntroIdentifier id -> - std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] -| QIntroFresh id -> - std_constructor ?loc "IntroFresh" [of_anti of_ident id] -| QIntroAnonymous -> - std_constructor ?loc "IntroAnonymous" [] - -and of_intro_pattern_action {loc;v=pat} = match pat with -| QIntroWildcard -> - std_constructor ?loc "IntroWildcard" [] -| QIntroOrAndPattern pat -> - std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern pat] -| QIntroInjection il -> - std_constructor ?loc "IntroInjection" [of_intro_patterns il] -| QIntroRewrite b -> - std_constructor ?loc "IntroRewrite" [of_bool ?loc b] - -and of_or_and_intro_pattern {loc;v=pat} = match pat with -| QIntroOrPattern ill -> - std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] -| QIntroAndPattern il -> - std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] - -and of_intro_patterns {loc;v=l} = - of_list ?loc of_intro_pattern l - -let of_hyp_location_flag ?loc = function -| Locus.InHyp -> std_constructor ?loc "InHyp" [] -| Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] -| Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] - -let of_occurrences {loc;v=occ} = match occ with -| QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] -| QAllOccurrencesBut occs -> - let map occ = of_anti of_int occ in - let occs = of_list ?loc map occs in - std_constructor ?loc "AllOccurrencesBut" [occs] -| QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] -| QOnlyOccurrences occs -> - let map occ = of_anti of_int occ in - let occs = of_list ?loc map occs in - std_constructor ?loc "OnlyOccurrences" [occs] - -let of_hyp_location ?loc ((occs, id), flag) = - of_tuple ?loc [ - of_anti of_ident id; - of_occurrences occs; - of_hyp_location_flag ?loc flag; - ] - -let of_clause {loc;v=cl} = - let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in - let concl = of_occurrences cl.q_concl_occs in - CAst.make ?loc @@ CTacRec ([ - std_proj "on_hyps", hyps; - std_proj "on_concl", concl; - ]) - -let of_destruction_arg {loc;v=arg} = match arg with -| QElimOnConstr c -> - let arg = thunk (of_constr_with_bindings c) in - std_constructor ?loc "ElimOnConstr" [arg] -| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] -| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] - -let of_induction_clause {loc;v=cl} = - let arg = of_destruction_arg cl.indcl_arg in - let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in - let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in - let in_ = of_option ?loc of_clause cl.indcl_in in - CAst.make ?loc @@ CTacRec ([ - std_proj "indcl_arg", arg; - std_proj "indcl_eqn", eqn; - std_proj "indcl_as", as_; - std_proj "indcl_in", in_; - ]) - -let check_pattern_id ?loc id = - if Tac2env.is_constructor (Libnames.qualid_of_ident id) then - CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) - -let pattern_vars pat = - let rec aux () accu pat = match pat.CAst.v with - | Constrexpr.CPatVar id - | Constrexpr.CEvar (id, []) -> - let () = check_pattern_id ?loc:pat.CAst.loc id in - Id.Set.add id accu - | _ -> - Constrexpr_ops.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat - in - aux () Id.Set.empty pat - -let abstract_vars loc vars tac = - let get_name = function Name id -> Some id | Anonymous -> None in - let def = try Some (List.find_map get_name vars) with Not_found -> None in - let na, tac = match def with - | None -> (Anonymous, tac) - | Some id0 -> - (* Trick: in order not to shadow a variable nor to choose an arbitrary - name, we reuse one which is going to be shadowed by the matched - variables anyways. *) - let build_bindings (n, accu) na = match na with - | Anonymous -> (n + 1, accu) - | Name _ -> - let get = global_ref ?loc (kername array_prefix "get") in - let args = [of_variable CAst.(make ?loc id0); of_int CAst.(make ?loc n)] in - let e = CAst.make ?loc @@ CTacApp (get, args) in - let accu = (CAst.make ?loc @@ CPatVar na, e) :: accu in - (n + 1, accu) - in - let (_, bnd) = List.fold_left build_bindings (0, []) vars in - let tac = CAst.make ?loc @@ CTacLet (false, bnd, tac) in - (Name id0, tac) - in - CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], tac) - -let of_pattern p = - inj_wit ?loc:p.CAst.loc wit_pattern p - -let of_conversion {loc;v=c} = match c with -| QConvert c -> - let pat = of_option ?loc of_pattern None in - let c = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar Anonymous], of_constr c) in - of_tuple ?loc [pat; c] -| QConvertWith (pat, c) -> - let vars = pattern_vars pat in - let pat = of_option ?loc of_pattern (Some pat) in - let c = of_constr c in - (* Order is critical here *) - let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in - let c = abstract_vars loc vars c in - of_tuple [pat; c] - -let of_repeat {loc;v=r} = match r with -| QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] -| QUpTo n -> std_constructor ?loc "UpTo" [of_int n] -| QRepeatStar -> std_constructor ?loc "RepeatStar" [] -| QRepeatPlus -> std_constructor ?loc "RepeatPlus" [] - -let of_orient loc b = - if b then std_constructor ?loc "LTR" [] - else std_constructor ?loc "RTL" [] - -let of_rewriting {loc;v=rew} = - let orient = - let {loc;v=orient} = rew.rew_orient in - of_option ?loc (fun b -> of_orient loc b) orient - in - let repeat = of_repeat rew.rew_repeat in - let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in - CAst.make ?loc @@ CTacRec ([ - std_proj "rew_orient", orient; - std_proj "rew_repeat", repeat; - std_proj "rew_equatn", equatn; - ]) - -let of_hyp ?loc id = - let hyp = global_ref ?loc (control_core "hyp") in - CAst.make ?loc @@ CTacApp (hyp, [of_ident id]) - -let of_exact_hyp ?loc id = - let refine = global_ref ?loc (control_core "refine") in - CAst.make ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) - -let of_exact_var ?loc id = - let refine = global_ref ?loc (control_core "refine") in - CAst.make ?loc @@ CTacApp (refine, [thunk (of_variable id)]) - -let of_dispatch tacs = - let loc = tacs.loc in - let default = function - | Some e -> thunk e - | None -> thunk (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0))) - in - let map e = of_pair default (fun l -> of_list ?loc default l) (CAst.make ?loc e) in - of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs - -let make_red_flag l = - let open Genredexpr in - let rec add_flag red = function - | [] -> red - | {v=flag} :: lf -> - let red = match flag with - | QBeta -> { red with rBeta = true } - | QMatch -> { red with rMatch = true } - | QFix -> { red with rFix = true } - | QCofix -> { red with rCofix = true } - | QZeta -> { red with rZeta = true } - | QConst {loc;v=l} -> - if red.rDelta then - CErrors.user_err ?loc Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); - { red with rConst = red.rConst @ l } - | QDeltaBut {loc;v=l} -> - if red.rConst <> [] && not red.rDelta then - CErrors.user_err ?loc Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); - { red with rConst = red.rConst @ l; rDelta = true } - | QIota -> - { red with rMatch = true; rFix = true; rCofix = true } - in - add_flag red lf - in - add_flag - {rBeta = false; rMatch = false; rFix = false; rCofix = false; - rZeta = false; rDelta = false; rConst = []} - l - -let of_reference r = - let of_ref ref = - inj_wit ?loc:ref.loc wit_reference ref - in - of_anti of_ref r - -let of_strategy_flag {loc;v=flag} = - let open Genredexpr in - let flag = make_red_flag flag in - CAst.make ?loc @@ CTacRec ([ - std_proj "rBeta", of_bool ?loc flag.rBeta; - std_proj "rMatch", of_bool ?loc flag.rMatch; - std_proj "rFix", of_bool ?loc flag.rFix; - std_proj "rCofix", of_bool ?loc flag.rCofix; - std_proj "rZeta", of_bool ?loc flag.rZeta; - std_proj "rDelta", of_bool ?loc flag.rDelta; - std_proj "rConst", of_list ?loc of_reference flag.rConst; - ]) - -let of_hintdb {loc;v=hdb} = match hdb with -| QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None -| QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) - -let extract_name ?loc oid = match oid with -| None -> Anonymous -| Some id -> - let () = check_pattern_id ?loc id in - Name id - -(** For every branch in the matching, generate a corresponding term of type - [(match_kind * pattern * (context -> constr array -> 'a))] - where the function binds the names from the pattern to the contents of the - constr array. *) -let of_constr_matching {loc;v=m} = - let map {loc;v=({loc=ploc;v=pat}, tac)} = - let (knd, pat, na) = match pat with - | QConstrMatchPattern pat -> - let knd = constructor ?loc (pattern_core "MatchPattern") [] in - (knd, pat, Anonymous) - | QConstrMatchContext (id, pat) -> - let na = extract_name ?loc id in - let knd = constructor ?loc (pattern_core "MatchContext") [] in - (knd, pat, na) - in - let vars = pattern_vars pat in - (* Order of elements is crucial here! *) - let vars = Id.Set.elements vars in - let vars = List.map (fun id -> Name id) vars in - let e = abstract_vars loc vars tac in - let e = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], e) in - let pat = inj_wit ?loc:ploc wit_pattern pat in - of_tuple [knd; pat; e] - in - of_list ?loc map m - -(** From the patterns and the body of the branch, generate: - - a goal pattern: (constr_match list * constr_match) - - a branch function (ident array -> context array -> constr array -> context -> 'a) -*) -let of_goal_matching {loc;v=gm} = - let mk_pat {loc;v=p} = match p with - | QConstrMatchPattern pat -> - let knd = constructor ?loc (pattern_core "MatchPattern") [] in - (Anonymous, pat, knd) - | QConstrMatchContext (id, pat) -> - let na = extract_name ?loc id in - let knd = constructor ?loc (pattern_core "MatchContext") [] in - (na, pat, knd) - in - let mk_gpat {loc;v=p} = - let concl_pat = p.q_goal_match_concl in - let hyps_pats = p.q_goal_match_hyps in - let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in - let vars = pattern_vars concl_pat in - let map accu (na, pat) = - let (ctx, pat, knd) = mk_pat pat in - let vars = pattern_vars pat in - (Id.Set.union vars accu, (na, ctx, pat, knd)) - in - let (vars, hyps_pats) = List.fold_left_map map vars hyps_pats in - let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in - let concl = of_tuple [concl_knd; of_pattern concl_pat] in - let r = of_tuple [of_list ?loc map hyps_pats; concl] in - let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in - let map (_, na, _, _) = na in - let hctx = List.map map hyps_pats in - (* Order of elements is crucial here! *) - let vars = Id.Set.elements vars in - let subst = List.map (fun id -> Name id) vars in - (r, hyps, hctx, subst, concl_ctx) - in - let map {loc;v=(pat, tac)} = - let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in - let tac = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar cctx], tac) in - let tac = abstract_vars loc subst tac in - let tac = abstract_vars loc hctx tac in - let tac = abstract_vars loc hyps tac in - of_tuple ?loc [pat; tac] - in - of_list ?loc map gm - -let of_move_location {loc;v=mv} = match mv with -| QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] -| QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] -| QMoveFirst -> std_constructor ?loc "MoveFirst" [] -| QMoveLast -> std_constructor ?loc "MoveLast" [] - -let of_pose p = - of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p - -let of_assertion {loc;v=ast} = match ast with -| QAssertType (ipat, c, tac) -> - let ipat = of_option of_intro_pattern ipat in - let c = of_constr c in - let tac = of_option thunk tac in - std_constructor ?loc "AssertType" [ipat; c; tac] -| QAssertValue (id, c) -> - let id = of_anti of_ident id in - let c = of_constr c in - std_constructor ?loc "AssertValue" [id; c] diff --git a/vendor/Ltac2/src/tac2quote.mli b/vendor/Ltac2/src/tac2quote.mli deleted file mode 100644 index 1b03dad8ec..0000000000 --- a/vendor/Ltac2/src/tac2quote.mli +++ /dev/null @@ -1,102 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ltac_constructor -> raw_tacexpr list -> raw_tacexpr - -val thunk : raw_tacexpr -> raw_tacexpr - -val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr - -val of_int : int CAst.t -> raw_tacexpr - -val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) CAst.t -> raw_tacexpr - -val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr - -val of_variable : Id.t CAst.t -> raw_tacexpr - -val of_ident : Id.t CAst.t -> raw_tacexpr - -val of_constr : Constrexpr.constr_expr -> raw_tacexpr - -val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr - -val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr - -val of_bindings : bindings -> raw_tacexpr - -val of_intro_pattern : intro_pattern -> raw_tacexpr - -val of_intro_patterns : intro_pattern list CAst.t -> raw_tacexpr - -val of_clause : clause -> raw_tacexpr - -val of_destruction_arg : destruction_arg -> raw_tacexpr - -val of_induction_clause : induction_clause -> raw_tacexpr - -val of_conversion : conversion -> raw_tacexpr - -val of_rewriting : rewriting -> raw_tacexpr - -val of_occurrences : occurrences -> raw_tacexpr - -val of_hintdb : hintdb -> raw_tacexpr - -val of_move_location : move_location -> raw_tacexpr - -val of_reference : reference or_anti -> raw_tacexpr - -val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr -(** id ↦ 'Control.hyp @id' *) - -val of_exact_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr -(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) - -val of_exact_var : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr -(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) - -val of_dispatch : dispatch -> raw_tacexpr - -val of_strategy_flag : strategy_flag -> raw_tacexpr - -val of_pose : pose -> raw_tacexpr - -val of_assertion : assertion -> raw_tacexpr - -val of_constr_matching : constr_matching -> raw_tacexpr - -val of_goal_matching : goal_matching -> raw_tacexpr - -(** {5 Generic arguments} *) - -val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag - -val wit_ident : (Id.t, Id.t) Arg.tag - -val wit_reference : (reference, GlobRef.t) Arg.tag - -val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag - -val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag - -val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag -(** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) - -val wit_ltac1val : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag -(** Ltac1 AST quotation, seen as a value-returning expression, with type Ltac1.t. *) diff --git a/vendor/Ltac2/src/tac2stdlib.ml b/vendor/Ltac2/src/tac2stdlib.ml deleted file mode 100644 index ffef2c05fd..0000000000 --- a/vendor/Ltac2/src/tac2stdlib.ml +++ /dev/null @@ -1,578 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false) f - -let return x = Proofview.tclUNIT x -let v_unit = Value.of_unit () -let thaw r f = Tac2ffi.app_fun1 f unit r () -let uthaw r f = Tac2ffi.app_fun1 (to_fun1 unit r f) unit r () -let thunk r = fun1 unit r - -let to_name c = match Value.to_option Value.to_ident c with -| None -> Anonymous -| Some id -> Name id - -let name = make_to_repr to_name - -let to_occurrences = function -| ValInt 0 -> AllOccurrences -| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list Value.to_int vl) -| ValInt 1 -> NoOccurrences -| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) -| _ -> assert false - -let occurrences = make_to_repr to_occurrences - -let to_hyp_location_flag v = match Value.to_int v with -| 0 -> InHyp -| 1 -> InHypTypeOnly -| 2 -> InHypValueOnly -| _ -> assert false - -let to_clause v = match Value.to_tuple v with -| [| hyps; concl |] -> - let cast v = match Value.to_tuple v with - | [| hyp; occ; flag |] -> - (Value.to_ident hyp, to_occurrences occ, to_hyp_location_flag flag) - | _ -> assert false - in - let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in - { onhyps = hyps; concl_occs = to_occurrences concl; } -| _ -> assert false - -let clause = make_to_repr to_clause - -let to_red_flag v = match Value.to_tuple v with -| [| beta; iota; fix; cofix; zeta; delta; const |] -> - { - rBeta = Value.to_bool beta; - rMatch = Value.to_bool iota; - rFix = Value.to_bool fix; - rCofix = Value.to_bool cofix; - rZeta = Value.to_bool zeta; - rDelta = Value.to_bool delta; - rConst = Value.to_list Value.to_reference const; - } -| _ -> assert false - -let red_flags = make_to_repr to_red_flag - -let pattern_with_occs = pair pattern occurrences - -let constr_with_occs = pair constr occurrences - -let reference_with_occs = pair reference occurrences - -let rec to_intro_pattern v = match Value.to_block v with -| (0, [| b |]) -> IntroForthcoming (Value.to_bool b) -| (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) -| (2, [| act |]) -> IntroAction (to_intro_pattern_action act) -| _ -> assert false - -and to_intro_pattern_naming = function -| ValBlk (0, [| id |]) -> IntroIdentifier (Value.to_ident id) -| ValBlk (1, [| id |]) -> IntroFresh (Value.to_ident id) -| ValInt 0 -> IntroAnonymous -| _ -> assert false - -and to_intro_pattern_action = function -| ValInt 0 -> IntroWildcard -| ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) -| ValBlk (1, [| inj |]) -> - let map ipat = to_intro_pattern ipat in - IntroInjection (Value.to_list map inj) -| ValBlk (2, [| c; ipat |]) -> - let c = Value.to_fun1 Value.unit Value.constr c in - IntroApplyOn (c, to_intro_pattern ipat) -| ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) -| _ -> assert false - -and to_or_and_intro_pattern v = match Value.to_block v with -| (0, [| ill |]) -> - IntroOrPattern (Value.to_list to_intro_patterns ill) -| (1, [| il |]) -> - IntroAndPattern (to_intro_patterns il) -| _ -> assert false - -and to_intro_patterns il = - Value.to_list to_intro_pattern il - -let intro_pattern = make_to_repr to_intro_pattern - -let intro_patterns = make_to_repr to_intro_patterns - -let to_destruction_arg v = match Value.to_block v with -| (0, [| c |]) -> - let c = uthaw constr_with_bindings c in - ElimOnConstr c -| (1, [| id |]) -> ElimOnIdent (Value.to_ident id) -| (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) -| _ -> assert false - -let destruction_arg = make_to_repr to_destruction_arg - -let to_induction_clause v = match Value.to_tuple v with -| [| arg; eqn; as_; in_ |] -> - let arg = to_destruction_arg arg in - let eqn = Value.to_option to_intro_pattern_naming eqn in - let as_ = Value.to_option to_or_and_intro_pattern as_ in - let in_ = Value.to_option to_clause in_ in - (arg, eqn, as_, in_) -| _ -> - assert false - -let induction_clause = make_to_repr to_induction_clause - -let to_assertion v = match Value.to_block v with -| (0, [| ipat; t; tac |]) -> - let to_tac t = Value.to_fun1 Value.unit Value.unit t in - let ipat = Value.to_option to_intro_pattern ipat in - let t = Value.to_constr t in - let tac = Value.to_option to_tac tac in - AssertType (ipat, t, tac) -| (1, [| id; c |]) -> - AssertValue (Value.to_ident id, Value.to_constr c) -| _ -> assert false - -let assertion = make_to_repr to_assertion - -let to_multi = function -| ValBlk (0, [| n |]) -> Precisely (Value.to_int n) -| ValBlk (1, [| n |]) -> UpTo (Value.to_int n) -| ValInt 0 -> RepeatStar -| ValInt 1 -> RepeatPlus -| _ -> assert false - -let to_rewriting v = match Value.to_tuple v with -| [| orient; repeat; c |] -> - let orient = Value.to_option Value.to_bool orient in - let repeat = to_multi repeat in - let c = uthaw constr_with_bindings c in - (orient, repeat, c) -| _ -> assert false - -let rewriting = make_to_repr to_rewriting - -let to_debug v = match Value.to_int v with -| 0 -> Hints.Off -| 1 -> Hints.Info -| 2 -> Hints.Debug -| _ -> assert false - -let debug = make_to_repr to_debug - -let to_strategy v = match Value.to_int v with -| 0 -> Class_tactics.Bfs -| 1 -> Class_tactics.Dfs -| _ -> assert false - -let strategy = make_to_repr to_strategy - -let to_inversion_kind v = match Value.to_int v with -| 0 -> Inv.SimpleInversion -| 1 -> Inv.FullInversion -| 2 -> Inv.FullInversionClear -| _ -> assert false - -let inversion_kind = make_to_repr to_inversion_kind - -let to_move_location = function -| ValInt 0 -> Logic.MoveFirst -| ValInt 1 -> Logic.MoveLast -| ValBlk (0, [|id|]) -> Logic.MoveAfter (Value.to_ident id) -| ValBlk (1, [|id|]) -> Logic.MoveBefore (Value.to_ident id) -| _ -> assert false - -let move_location = make_to_repr to_move_location - -let to_generalize_arg v = match Value.to_tuple v with -| [| c; occs; na |] -> - (Value.to_constr c, to_occurrences occs, to_name na) -| _ -> assert false - -let generalize_arg = make_to_repr to_generalize_arg - -(** Standard tactics sharing their implementation with Ltac1 *) - -let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } - -let lift tac = tac <*> return v_unit - -let define_prim0 name tac = - let tac _ = lift tac in - Tac2env.define_primitive (pname name) (mk_closure arity_one tac) - -let define_prim1 name r0 f = - let tac x = lift (f (Value.repr_to r0 x)) in - Tac2env.define_primitive (pname name) (mk_closure arity_one tac) - -let define_prim2 name r0 r1 f = - let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) - -let define_prim3 name r0 r1 r2 f = - let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) - -let define_prim4 name r0 r1 r2 r3 f = - let tac x y z u = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) - -let define_prim5 name r0 r1 r2 r3 r4 f = - let tac x y z u v = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u) (Value.repr_to r4 v)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) - -(** Tactics from Tacexpr *) - -let () = define_prim2 "tac_intros" bool intro_patterns begin fun ev ipat -> - Tac2tactics.intros_patterns ev ipat -end - -let () = define_prim4 "tac_apply" bool bool (list (thunk constr_with_bindings)) (option (pair ident (option intro_pattern))) begin fun adv ev cb ipat -> - Tac2tactics.apply adv ev cb ipat -end - -let () = define_prim3 "tac_elim" bool constr_with_bindings (option constr_with_bindings) begin fun ev c copt -> - Tac2tactics.elim ev c copt -end - -let () = define_prim2 "tac_case" bool constr_with_bindings begin fun ev c -> - Tac2tactics.general_case_analysis ev c -end - -let () = define_prim1 "tac_generalize" (list generalize_arg) begin fun cl -> - Tac2tactics.generalize cl -end - -let () = define_prim1 "tac_assert" assertion begin fun ast -> - Tac2tactics.assert_ ast -end - -let () = define_prim3 "tac_enough" constr (option (option (thunk unit))) (option intro_pattern) begin fun c tac ipat -> - let tac = Option.map (fun o -> Option.map (fun f -> thaw unit f) o) tac in - Tac2tactics.forward false tac ipat c -end - -let () = define_prim2 "tac_pose" name constr begin fun na c -> - Tactics.letin_tac None na c None Locusops.nowhere -end - -let () = define_prim3 "tac_set" bool (thunk (pair name constr)) clause begin fun ev p cl -> - Proofview.tclEVARMAP >>= fun sigma -> - thaw (pair name constr) p >>= fun (na, c) -> - Tac2tactics.letin_pat_tac ev None na (sigma, c) cl -end - -let () = define_prim5 "tac_remember" bool name (thunk constr) (option intro_pattern) clause begin fun ev na c eqpat cl -> - let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in - match eqpat with - | IntroNaming eqpat -> - Proofview.tclEVARMAP >>= fun sigma -> - thaw constr c >>= fun c -> - Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl - | _ -> - Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") -end - -let () = define_prim3 "tac_destruct" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> - Tac2tactics.induction_destruct false ev ic using -end - -let () = define_prim3 "tac_induction" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> - Tac2tactics.induction_destruct true ev ic using -end - -let () = define_prim1 "tac_red" clause begin fun cl -> - Tac2tactics.reduce (Red false) cl -end - -let () = define_prim1 "tac_hnf" clause begin fun cl -> - Tac2tactics.reduce Hnf cl -end - -let () = define_prim3 "tac_simpl" red_flags (option pattern_with_occs) clause begin fun flags where cl -> - Tac2tactics.simpl flags where cl -end - -let () = define_prim2 "tac_cbv" red_flags clause begin fun flags cl -> - Tac2tactics.cbv flags cl -end - -let () = define_prim2 "tac_cbn" red_flags clause begin fun flags cl -> - Tac2tactics.cbn flags cl -end - -let () = define_prim2 "tac_lazy" red_flags clause begin fun flags cl -> - Tac2tactics.lazy_ flags cl -end - -let () = define_prim2 "tac_unfold" (list reference_with_occs) clause begin fun refs cl -> - Tac2tactics.unfold refs cl -end - -let () = define_prim2 "tac_fold" (list constr) clause begin fun args cl -> - Tac2tactics.reduce (Fold args) cl -end - -let () = define_prim2 "tac_pattern" (list constr_with_occs) clause begin fun where cl -> - Tac2tactics.pattern where cl -end - -let () = define_prim2 "tac_vm" (option pattern_with_occs) clause begin fun where cl -> - Tac2tactics.vm where cl -end - -let () = define_prim2 "tac_native" (option pattern_with_occs) clause begin fun where cl -> - Tac2tactics.native where cl -end - -(** Reduction functions *) - -let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) - -let define_red1 name r0 f = - let tac x = lift (f (Value.repr_to r0 x)) in - Tac2env.define_primitive (pname name) (mk_closure arity_one tac) - -let define_red2 name r0 r1 f = - let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) - -let define_red3 name r0 r1 r2 f = - let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in - Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) - -let () = define_red1 "eval_red" constr begin fun c -> - Tac2tactics.eval_red c -end - -let () = define_red1 "eval_hnf" constr begin fun c -> - Tac2tactics.eval_hnf c -end - -let () = define_red3 "eval_simpl" red_flags (option pattern_with_occs) constr begin fun flags where c -> - Tac2tactics.eval_simpl flags where c -end - -let () = define_red2 "eval_cbv" red_flags constr begin fun flags c -> - Tac2tactics.eval_cbv flags c -end - -let () = define_red2 "eval_cbn" red_flags constr begin fun flags c -> - Tac2tactics.eval_cbn flags c -end - -let () = define_red2 "eval_lazy" red_flags constr begin fun flags c -> - Tac2tactics.eval_lazy flags c -end - -let () = define_red2 "eval_unfold" (list reference_with_occs) constr begin fun refs c -> - Tac2tactics.eval_unfold refs c -end - -let () = define_red2 "eval_fold" (list constr) constr begin fun args c -> - Tac2tactics.eval_fold args c -end - -let () = define_red2 "eval_pattern" (list constr_with_occs) constr begin fun where c -> - Tac2tactics.eval_pattern where c -end - -let () = define_red2 "eval_vm" (option pattern_with_occs) constr begin fun where c -> - Tac2tactics.eval_vm where c -end - -let () = define_red2 "eval_native" (option pattern_with_occs) constr begin fun where c -> - Tac2tactics.eval_native where c -end - -let () = define_prim3 "tac_change" (option pattern) (fun1 (array constr) constr) clause begin fun pat c cl -> - Tac2tactics.change pat c cl -end - -let () = define_prim4 "tac_rewrite" bool (list rewriting) clause (option (thunk unit)) begin fun ev rw cl by -> - Tac2tactics.rewrite ev rw cl by -end - -let () = define_prim4 "tac_inversion" inversion_kind destruction_arg (option intro_pattern) (option (list ident)) begin fun knd arg pat ids -> - Tac2tactics.inversion knd arg pat ids -end - -(** Tactics from coretactics *) - -let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity - -let () = define_prim2 "tac_move" ident move_location begin fun id mv -> - Tactics.move_hyp id mv -end - -let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> - let mv = Option.default Logic.MoveLast mv in - Tactics.intro_move id mv -end - -(* - -TACTIC EXTEND exact - [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] -END - -*) - -let () = define_prim0 "tac_assumption" Tactics.assumption - -let () = define_prim1 "tac_transitivity" constr begin fun c -> - Tactics.intros_transitivity (Some c) -end - -let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) - -let () = define_prim1 "tac_cut" constr begin fun c -> - Tactics.cut c -end - -let () = define_prim2 "tac_left" bool bindings begin fun ev bnd -> - Tac2tactics.left_with_bindings ev bnd -end -let () = define_prim2 "tac_right" bool bindings begin fun ev bnd -> - Tac2tactics.right_with_bindings ev bnd -end - -let () = define_prim1 "tac_introsuntil" qhyp begin fun h -> - Tactics.intros_until h -end - -let () = define_prim1 "tac_exactnocheck" constr begin fun c -> - Tactics.exact_no_check c -end - -let () = define_prim1 "tac_vmcastnocheck" constr begin fun c -> - Tactics.vm_cast_no_check c -end - -let () = define_prim1 "tac_nativecastnocheck" constr begin fun c -> - Tactics.native_cast_no_check c -end - -let () = define_prim1 "tac_constructor" bool begin fun ev -> - Tactics.any_constructor ev None -end - -let () = define_prim3 "tac_constructorn" bool int bindings begin fun ev n bnd -> - Tac2tactics.constructor_tac ev None n bnd -end - -let () = define_prim2 "tac_specialize" constr_with_bindings (option intro_pattern) begin fun c ipat -> - Tac2tactics.specialize c ipat -end - -let () = define_prim1 "tac_symmetry" clause begin fun cl -> - Tac2tactics.symmetry cl -end - -let () = define_prim2 "tac_split" bool bindings begin fun ev bnd -> - Tac2tactics.split_with_bindings ev bnd -end - -let () = define_prim1 "tac_rename" (list (pair ident ident)) begin fun ids -> - Tactics.rename_hyp ids -end - -let () = define_prim1 "tac_revert" (list ident) begin fun ids -> - Tactics.revert ids -end - -let () = define_prim0 "tac_admit" Proofview.give_up - -let () = define_prim2 "tac_fix" ident int begin fun ident n -> - Tactics.fix ident n -end - -let () = define_prim1 "tac_cofix" ident begin fun ident -> - Tactics.cofix ident -end - -let () = define_prim1 "tac_clear" (list ident) begin fun ids -> - Tactics.clear ids -end - -let () = define_prim1 "tac_keep" (list ident) begin fun ids -> - Tactics.keep ids -end - -let () = define_prim1 "tac_clearbody" (list ident) begin fun ids -> - Tactics.clear_body ids -end - -(** Tactics from extratactics *) - -let () = define_prim2 "tac_discriminate" bool (option destruction_arg) begin fun ev arg -> - Tac2tactics.discriminate ev arg -end - -let () = define_prim3 "tac_injection" bool (option intro_patterns) (option destruction_arg) begin fun ev ipat arg -> - Tac2tactics.injection ev ipat arg -end - -let () = define_prim1 "tac_absurd" constr begin fun c -> - Contradiction.absurd c -end - -let () = define_prim1 "tac_contradiction" (option constr_with_bindings) begin fun c -> - Tac2tactics.contradiction c -end - -let () = define_prim4 "tac_autorewrite" bool (option (thunk unit)) (list ident) clause begin fun all by ids cl -> - Tac2tactics.autorewrite ~all by ids cl -end - -let () = define_prim1 "tac_subst" (list ident) begin fun ids -> - Equality.subst ids -end - -let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) - -(** Auto *) - -let () = define_prim3 "tac_trivial" debug (list (thunk constr)) (option (list ident)) begin fun dbg lems dbs -> - Tac2tactics.trivial dbg lems dbs -end - -let () = define_prim5 "tac_eauto" debug (option int) (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n p lems dbs -> - Tac2tactics.eauto dbg n p lems dbs -end - -let () = define_prim4 "tac_auto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> - Tac2tactics.auto dbg n lems dbs -end - -let () = define_prim4 "tac_newauto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> - Tac2tactics.new_auto dbg n lems dbs -end - -let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> - Tac2tactics.typeclasses_eauto str n dbs -end - -(** Firstorder *) - -let () = define_prim3 "tac_firstorder" (option (thunk unit)) (list reference) (list ident) begin fun tac refs ids -> - Tac2tactics.firstorder tac refs ids -end diff --git a/vendor/Ltac2/src/tac2stdlib.mli b/vendor/Ltac2/src/tac2stdlib.mli deleted file mode 100644 index 927b57074d..0000000000 --- a/vendor/Ltac2/src/tac2stdlib.mli +++ /dev/null @@ -1,9 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tactypes.ImplicitBindings l -| ExplicitBindings l -> - let l = List.map CAst.make l in - Tactypes.ExplicitBindings l -| NoBindings -> Tactypes.NoBindings - -let mk_with_bindings (x, b) = (x, mk_bindings b) - -let rec mk_intro_pattern = function -| IntroForthcoming b -> CAst.make @@ Tactypes.IntroForthcoming b -| IntroNaming ipat -> CAst.make @@ Tactypes.IntroNaming (mk_intro_pattern_naming ipat) -| IntroAction ipat -> CAst.make @@ Tactypes.IntroAction (mk_intro_pattern_action ipat) - -and mk_intro_pattern_naming = function -| IntroIdentifier id -> Namegen.IntroIdentifier id -| IntroFresh id -> Namegen.IntroFresh id -| IntroAnonymous -> Namegen.IntroAnonymous - -and mk_intro_pattern_action = function -| IntroWildcard -> Tactypes.IntroWildcard -| IntroOrAndPattern ipat -> Tactypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) -| IntroInjection ipats -> Tactypes.IntroInjection (List.map mk_intro_pattern ipats) -| IntroApplyOn (c, ipat) -> - let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in - Tactypes.IntroApplyOn (c, mk_intro_pattern ipat) -| IntroRewrite b -> Tactypes.IntroRewrite b - -and mk_or_and_intro_pattern = function -| IntroOrPattern ipatss -> - Tactypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) -| IntroAndPattern ipats -> - Tactypes.IntroAndPattern (List.map mk_intro_pattern ipats) - -let mk_intro_patterns ipat = List.map mk_intro_pattern ipat - -let mk_occurrences f = function -| AllOccurrences -> Locus.AllOccurrences -| AllOccurrencesBut l -> Locus.AllOccurrencesBut (List.map f l) -| NoOccurrences -> Locus.NoOccurrences -| OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) - -let mk_occurrences_expr occ = - mk_occurrences (fun i -> Locus.ArgArg i) occ - -let mk_hyp_location (id, occs, h) = - ((mk_occurrences_expr occs, id), h) - -let mk_clause cl = { - Locus.onhyps = Option.map (fun l -> List.map mk_hyp_location l) cl.onhyps; - Locus.concl_occs = mk_occurrences_expr cl.concl_occs; -} - -let intros_patterns ev ipat = - let ipat = mk_intro_patterns ipat in - Tactics.intros_patterns ev ipat - -let apply adv ev cb cl = - let map c = - let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in - None, CAst.make (delayed_of_tactic c) - in - let cb = List.map map cb in - match cl with - | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb - | Some (id, cl) -> - let cl = Option.map mk_intro_pattern cl in - Tactics.apply_delayed_in adv ev id cb cl - -let mk_destruction_arg = function -| ElimOnConstr c -> - let c = c >>= fun c -> return (mk_with_bindings c) in - Tactics.ElimOnConstr (delayed_of_tactic c) -| ElimOnIdent id -> Tactics.ElimOnIdent CAst.(make id) -| ElimOnAnonHyp n -> Tactics.ElimOnAnonHyp n - -let mk_induction_clause (arg, eqn, as_, occ) = - let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in - let as_ = Option.map (fun ipat -> CAst.make @@ mk_or_and_intro_pattern ipat) as_ in - let occ = Option.map mk_clause occ in - ((None, mk_destruction_arg arg), (eqn, as_), occ) - -let induction_destruct isrec ev (ic : induction_clause list) using = - let ic = List.map mk_induction_clause ic in - let using = Option.map mk_with_bindings using in - Tactics.induction_destruct isrec ev (ic, using) - -let elim ev c copt = - let c = mk_with_bindings c in - let copt = Option.map mk_with_bindings copt in - Tactics.elim ev None c copt - -let generalize pl = - let mk_occ occs = mk_occurrences (fun i -> i) occs in - let pl = List.map (fun (c, occs, na) -> (mk_occ occs, c), na) pl in - Tactics.new_generalize_gen pl - -let general_case_analysis ev c = - let c = mk_with_bindings c in - Tactics.general_case_analysis ev None c - -let constructor_tac ev n i bnd = - let bnd = mk_bindings bnd in - Tactics.constructor_tac ev n i bnd - -let left_with_bindings ev bnd = - let bnd = mk_bindings bnd in - Tactics.left_with_bindings ev bnd - -let right_with_bindings ev bnd = - let bnd = mk_bindings bnd in - Tactics.right_with_bindings ev bnd - -let split_with_bindings ev bnd = - let bnd = mk_bindings bnd in - Tactics.split_with_bindings ev [bnd] - -let specialize c pat = - let c = mk_with_bindings c in - let pat = Option.map mk_intro_pattern pat in - Tactics.specialize c pat - -let change pat c cl = - let open Tac2ffi in - Proofview.Goal.enter begin fun gl -> - let c subst env sigma = - let subst = Array.map_of_list snd (Id.Map.bindings subst) in - delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma - in - let cl = mk_clause cl in - Tactics.change pat c cl - end - -let rewrite ev rw cl by = - let map_rw (orient, repeat, c) = - let c = c >>= fun c -> return (mk_with_bindings c) in - (Option.default true orient, repeat, None, delayed_of_tactic c) - in - let rw = List.map map_rw rw in - let cl = mk_clause cl in - let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE (thaw Tac2ffi.unit tac), Equality.Naive) by in - Equality.general_multi_rewrite ev rw cl by - -let symmetry cl = - let cl = mk_clause cl in - Tactics.intros_symmetry cl - -let forward fst tac ipat c = - let ipat = Option.map mk_intro_pattern ipat in - Tactics.forward fst tac ipat c - -let assert_ = function -| AssertValue (id, c) -> - let ipat = CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id) in - Tactics.forward true None (Some ipat) c -| AssertType (ipat, c, tac) -> - let ipat = Option.map mk_intro_pattern ipat in - let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in - Tactics.forward true (Some tac) ipat c - -let letin_pat_tac ev ipat na c cl = - let ipat = Option.map (fun (b, ipat) -> (b, CAst.make @@ mk_intro_pattern_naming ipat)) ipat in - let cl = mk_clause cl in - Tactics.letin_pat_tac ev ipat na c cl - -(** Ltac interface treats differently global references than other term - arguments in reduction expressions. In Ltac1, this is done at parsing time. - Instead, we parse indifferently any pattern and dispatch when the tactic is - called. *) -let map_pattern_with_occs (pat, occ) = match pat with -| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) -| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) -| _ -> (mk_occurrences_expr occ, Inr pat) - -let get_evaluable_reference = function -| VarRef id -> Proofview.tclUNIT (EvalVarRef id) -| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) -| r -> - Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ - Nametab.pr_global_env Id.Set.empty r ++ spc () ++ - str "to an evaluable reference.") - -let reduce r cl = - let cl = mk_clause cl in - Tactics.reduce r cl - -let simpl flags where cl = - let where = Option.map map_pattern_with_occs where in - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Simpl (flags, where)) cl - -let cbv flags cl = - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Cbv flags) cl - -let cbn flags cl = - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Cbn flags) cl - -let lazy_ flags cl = - let cl = mk_clause cl in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - Tactics.reduce (Lazy flags) cl - -let unfold occs cl = - let cl = mk_clause cl in - let map (gr, occ) = - let occ = mk_occurrences_expr occ in - get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) - in - Proofview.Monad.List.map map occs >>= fun occs -> - Tactics.reduce (Unfold occs) cl - -let pattern where cl = - let where = List.map (fun (c, occ) -> (mk_occurrences_expr occ, c)) where in - let cl = mk_clause cl in - Tactics.reduce (Pattern where) cl - -let vm where cl = - let where = Option.map map_pattern_with_occs where in - let cl = mk_clause cl in - Tactics.reduce (CbvVm where) cl - -let native where cl = - let where = Option.map map_pattern_with_occs where in - let cl = mk_clause cl in - Tactics.reduce (CbvNative where) cl - -let eval_fun red c = - Tac2core.pf_apply begin fun env sigma -> - let (redfun, _) = Redexpr.reduction_of_red_expr env red in - let (sigma, ans) = redfun env sigma c in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT ans - end - -let eval_red c = - eval_fun (Red false) c - -let eval_hnf c = - eval_fun Hnf c - -let eval_simpl flags where c = - let where = Option.map map_pattern_with_occs where in - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Simpl (flags, where)) c - -let eval_cbv flags c = - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Cbv flags) c - -let eval_cbn flags c = - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Cbn flags) c - -let eval_lazy flags c = - Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> - let flags = { flags with rConst } in - eval_fun (Lazy flags) c - -let eval_unfold occs c = - let map (gr, occ) = - let occ = mk_occurrences_expr occ in - get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) - in - Proofview.Monad.List.map map occs >>= fun occs -> - eval_fun (Unfold occs) c - -let eval_fold cl c = - eval_fun (Fold cl) c - -let eval_pattern where c = - let where = List.map (fun (pat, occ) -> (mk_occurrences_expr occ, pat)) where in - eval_fun (Pattern where) c - -let eval_vm where c = - let where = Option.map map_pattern_with_occs where in - eval_fun (CbvVm where) c - -let eval_native where c = - let where = Option.map map_pattern_with_occs where in - eval_fun (CbvNative where) c - -let on_destruction_arg tac ev arg = - Proofview.Goal.enter begin fun gl -> - match arg with - | None -> tac ev None - | Some (clear, arg) -> - let arg = match arg with - | ElimOnConstr c -> - let env = Proofview.Goal.env gl in - Proofview.tclEVARMAP >>= fun sigma -> - c >>= fun (c, lbind) -> - let lbind = mk_bindings lbind in - Proofview.tclEVARMAP >>= fun sigma' -> - let flags = tactic_infer_flags ev in - let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in - Proofview.tclUNIT (Some sigma', Tactics.ElimOnConstr (c, lbind)) - | ElimOnIdent id -> Proofview.tclUNIT (None, Tactics.ElimOnIdent CAst.(make id)) - | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Tactics.ElimOnAnonHyp n) - in - arg >>= fun (sigma', arg) -> - let arg = Some (clear, arg) in - match sigma' with - | None -> tac ev arg - | Some sigma' -> - Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' - end - -let discriminate ev arg = - let arg = Option.map (fun arg -> None, arg) arg in - on_destruction_arg Equality.discr_tac ev arg - -let injection ev ipat arg = - let arg = Option.map (fun arg -> None, arg) arg in - let ipat = Option.map mk_intro_patterns ipat in - let tac ev arg = Equality.injClause None ipat ev arg in - on_destruction_arg tac ev arg - -let autorewrite ~all by ids cl = - let conds = if all then Some Equality.AllMatches else None in - let ids = List.map Id.to_string ids in - let cl = mk_clause cl in - match by with - | None -> Autorewrite.auto_multi_rewrite ?conds ids cl - | Some by -> - let by = thaw Tac2ffi.unit by in - Autorewrite.auto_multi_rewrite_with ?conds by ids cl - -(** Auto *) - -let trivial debug lems dbs = - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in - Auto.h_trivial ~debug lems dbs - -let auto debug n lems dbs = - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in - Auto.h_auto ~debug n lems dbs - -let new_auto debug n lems dbs = - let make_depth n = snd (Eauto.make_dimension n None) in - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - match dbs with - | None -> Auto.new_full_auto ~debug (make_depth n) lems - | Some dbs -> - let dbs = List.map Id.to_string dbs in - Auto.new_auto ~debug (make_depth n) lems dbs - -let eauto debug n p lems dbs = - let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in - let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in - Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs - -let typeclasses_eauto strategy depth dbs = - let only_classes, dbs = match dbs with - | None -> - true, [Class_tactics.typeclasses_db] - | Some dbs -> - let dbs = List.map Id.to_string dbs in - false, dbs - in - Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs - -(** Inversion *) - -let inversion knd arg pat ids = - let ids = match ids with - | None -> [] - | Some l -> l - in - begin match pat with - | None -> Proofview.tclUNIT None - | Some (IntroAction (IntroOrAndPattern p)) -> - Proofview.tclUNIT (Some (CAst.make @@ mk_or_and_intro_pattern p)) - | Some _ -> - Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") - end >>= fun pat -> - let inversion _ arg = - begin match arg with - | None -> assert false - | Some (_, Tactics.ElimOnAnonHyp n) -> - Inv.inv_clause knd pat ids (AnonHyp n) - | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> - Inv.inv_clause knd pat ids (NamedHyp id) - | Some (_, Tactics.ElimOnConstr c) -> - let open Tactypes in - let anon = CAst.make @@ IntroNaming Namegen.IntroAnonymous in - Tactics.specialize c (Some anon) >>= fun () -> - Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) - end - in - on_destruction_arg inversion true (Some (None, arg)) - -let contradiction c = - let c = Option.map mk_with_bindings c in - Contradiction.contradiction c - -(** Firstorder *) - -let firstorder tac refs ids = - let open Ground_plugin in - let ids = List.map Id.to_string ids in - let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in - G_ground.gen_ground_tac true tac refs ids diff --git a/vendor/Ltac2/src/tac2tactics.mli b/vendor/Ltac2/src/tac2tactics.mli deleted file mode 100644 index 026673acbf..0000000000 --- a/vendor/Ltac2/src/tac2tactics.mli +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* intro_pattern list -> unit tactic - -val apply : advanced_flag -> evars_flag -> - constr_with_bindings thunk list -> - (Id.t * intro_pattern option) option -> unit tactic - -val induction_destruct : rec_flag -> evars_flag -> - induction_clause list -> constr_with_bindings option -> unit tactic - -val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> - unit tactic - -val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic - -val generalize : (constr * occurrences * Name.t) list -> unit tactic - -val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic - -val left_with_bindings : evars_flag -> bindings -> unit tactic -val right_with_bindings : evars_flag -> bindings -> unit tactic -val split_with_bindings : evars_flag -> bindings -> unit tactic - -val specialize : constr_with_bindings -> intro_pattern option -> unit tactic - -val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic - -val rewrite : - evars_flag -> rewriting list -> clause -> unit thunk option -> unit tactic - -val symmetry : clause -> unit tactic - -val forward : bool -> unit tactic option option -> - intro_pattern option -> constr -> unit tactic - -val assert_ : assertion -> unit tactic - -val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> - Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic - -val reduce : Redexpr.red_expr -> clause -> unit tactic - -val simpl : GlobRef.t glob_red_flag -> - (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic - -val cbv : GlobRef.t glob_red_flag -> clause -> unit tactic - -val cbn : GlobRef.t glob_red_flag -> clause -> unit tactic - -val lazy_ : GlobRef.t glob_red_flag -> clause -> unit tactic - -val unfold : (GlobRef.t * occurrences) list -> clause -> unit tactic - -val pattern : (constr * occurrences) list -> clause -> unit tactic - -val vm : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic - -val native : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic - -val eval_red : constr -> constr tactic - -val eval_hnf : constr -> constr tactic - -val eval_simpl : GlobRef.t glob_red_flag -> - (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic - -val eval_cbv : GlobRef.t glob_red_flag -> constr -> constr tactic - -val eval_cbn : GlobRef.t glob_red_flag -> constr -> constr tactic - -val eval_lazy : GlobRef.t glob_red_flag -> constr -> constr tactic - -val eval_unfold : (GlobRef.t * occurrences) list -> constr -> constr tactic - -val eval_fold : constr list -> constr -> constr tactic - -val eval_pattern : (EConstr.t * occurrences) list -> constr -> constr tactic - -val eval_vm : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic - -val eval_native : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic - -val discriminate : evars_flag -> destruction_arg option -> unit tactic - -val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic - -val autorewrite : all:bool -> unit thunk option -> Id.t list -> clause -> unit tactic - -val trivial : Hints.debug -> constr thunk list -> Id.t list option -> - unit Proofview.tactic - -val auto : Hints.debug -> int option -> constr thunk list -> - Id.t list option -> unit Proofview.tactic - -val new_auto : Hints.debug -> int option -> constr thunk list -> - Id.t list option -> unit Proofview.tactic - -val eauto : Hints.debug -> int option -> int option -> constr thunk list -> - Id.t list option -> unit Proofview.tactic - -val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> - Id.t list option -> unit Proofview.tactic - -val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic - -val contradiction : constr_with_bindings option -> unit tactic - -val firstorder : unit thunk option -> GlobRef.t list -> Id.t list -> unit tactic diff --git a/vendor/Ltac2/src/tac2types.mli b/vendor/Ltac2/src/tac2types.mli deleted file mode 100644 index fa31153a27..0000000000 --- a/vendor/Ltac2/src/tac2types.mli +++ /dev/null @@ -1,92 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* $@ - if [ $$? = 0 ]; then \ - echo " $<... OK"; \ - else \ - echo " $<... FAIL!"; \ - fi; \ - -clean: - rm -f *.log diff --git a/vendor/Ltac2/tests/compat.v b/vendor/Ltac2/tests/compat.v deleted file mode 100644 index 489fa638e4..0000000000 --- a/vendor/Ltac2/tests/compat.v +++ /dev/null @@ -1,58 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Notations. - -(** Test calls to Ltac1 from Ltac2 *) - -Ltac2 foo () := ltac1:(discriminate). - -Goal true = false -> False. -Proof. -foo (). -Qed. - -Goal true = false -> false = true. -Proof. -intros H; ltac1:(match goal with [ H : ?P |- _ ] => rewrite H end); reflexivity. -Qed. - -Goal true = false -> false = true. -Proof. -intros H; ltac1:(rewrite H); reflexivity. -Abort. - -(** Variables do not cross the compatibility layer boundary. *) -Fail Ltac2 bar nay := ltac1:(discriminate nay). - -Fail Ltac2 pose1 (v : constr) := - ltac1:(pose $v). - -(** Test calls to Ltac2 from Ltac1 *) - -Set Default Proof Mode "Classic". - -Ltac foo := ltac2:(foo ()). - -Goal true = false -> False. -Proof. -ltac2:(foo ()). -Qed. - -Goal true = false -> False. -Proof. -foo. -Qed. - -(** Variables do not cross the compatibility layer boundary. *) -Fail Ltac bar x := ltac2:(foo x). - -Ltac mytac tac := idtac "wow". - -Goal True. -Proof. -(** Fails because quotation is evaluated eagerly *) -Fail mytac ltac2:(fail). -(** One has to thunk thanks to the idtac trick *) -let t := idtac; ltac2:(fail) in mytac t. -constructor. -Qed. diff --git a/vendor/Ltac2/tests/errors.v b/vendor/Ltac2/tests/errors.v deleted file mode 100644 index c677f6af5d..0000000000 --- a/vendor/Ltac2/tests/errors.v +++ /dev/null @@ -1,12 +0,0 @@ -Require Import Ltac2.Ltac2. - -Goal True. -Proof. -let x := Control.plus - (fun () => let _ := constr:(nat -> 0) in 0) - (fun e => match e with Not_found => 1 | _ => 2 end) in -match Int.equal x 2 with -| true => () -| false => Control.throw (Tactic_failure None) -end. -Abort. diff --git a/vendor/Ltac2/tests/example1.v b/vendor/Ltac2/tests/example1.v deleted file mode 100644 index 023791050f..0000000000 --- a/vendor/Ltac2/tests/example1.v +++ /dev/null @@ -1,27 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Control. - -(** Alternative implementation of the hyp primitive *) -Ltac2 get_hyp_by_name x := - let h := hyps () in - let rec find x l := match l with - | [] => zero Not_found - | p :: l => - match p with - | (id, _, t) => - match Ident.equal x id with - | true => t - | false => find x l - end - end - end in - find x h. - -Print Ltac2 get_hyp_by_name. - -Goal forall n m, n + m = 0 -> n = 0. -Proof. -refine (fun () => '(fun n m H => _)). -let t := get_hyp_by_name @H in Message.print (Message.of_constr t). -Abort. diff --git a/vendor/Ltac2/tests/example2.v b/vendor/Ltac2/tests/example2.v deleted file mode 100644 index c953d25061..0000000000 --- a/vendor/Ltac2/tests/example2.v +++ /dev/null @@ -1,281 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Notations. - -Set Default Goal Selector "all". - -Goal exists n, n = 0. -Proof. -split with (x := 0). -reflexivity. -Qed. - -Goal exists n, n = 0. -Proof. -split with 0. -split. -Qed. - -Goal exists n, n = 0. -Proof. -let myvar := Std.NamedHyp @x in split with ($myvar := 0). -split. -Qed. - -Goal (forall n : nat, n = 0 -> False) -> True. -Proof. -intros H. -eelim &H. -split. -Qed. - -Goal (forall n : nat, n = 0 -> False) -> True. -Proof. -intros H. -elim &H with 0. -split. -Qed. - -Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. -Proof. -intros P H. -Fail apply &H. -apply &H with (m := 0). -split. -Qed. - -Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> (0 = 1) -> P 0. -Proof. -intros P H e. -apply &H with (m := 1) in e. -exact e. -Qed. - -Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. -Proof. -intros P H. -eapply &H. -split. -Qed. - -Goal exists n, n = 0. -Proof. -Fail constructor 1. -constructor 1 with (x := 0). -split. -Qed. - -Goal exists n, n = 0. -Proof. -econstructor 1. -split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -induction &n as [|n] using nat_rect; split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -let n := @X in -let q := Std.NamedHyp @P in -induction &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -destruct &n as [|n] using nat_rect; split. -Qed. - -Goal forall n, 0 + n = n. -Proof. -intros n. -let n := @X in -let q := Std.NamedHyp @P in -destruct &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. -Qed. - -Goal forall b1 b2, andb b1 b2 = andb b2 b1. -Proof. -intros b1 b2. -destruct &b1 as [|], &b2 as [|]; split. -Qed. - -Goal forall n m, n = 0 -> n + m = m. -Proof. -intros n m Hn. -rewrite &Hn; split. -Qed. - -Goal forall n m p, n = m -> p = m -> 0 = n -> p = 0. -Proof. -intros n m p He He' Hn. -rewrite &He, <- &He' in Hn. -rewrite &Hn. -split. -Qed. - -Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. -Proof. -intros n m He He' He''. -rewrite <- &He by assumption. -Control.refine (fun () => &He''). -Qed. - -Goal forall n (r := if true then n else 0), r = n. -Proof. -intros n r. -hnf in r. -split. -Qed. - -Goal 1 = 0 -> 0 = 0. -Proof. -intros H. -pattern 0 at 1. -let occ := 2 in pattern 1 at 1, 0 at $occ in H. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -vm_compute. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -native_compute. -reflexivity. -Qed. - -Goal 1 + 1 = 2 - 0 -> True. -Proof. -intros H. -vm_compute plus in H. -reflexivity. -Qed. - -Goal 1 = 0 -> True /\ True. -Proof. -intros H. -split; fold (1 + 0) (1 + 0) in H. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -cbv [ Nat.add ]. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -let x := reference:(Nat.add) in -cbn beta iota delta [ $x ]. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -simpl beta. -reflexivity. -Qed. - -Goal 1 + 1 = 2. -Proof. -lazy. -reflexivity. -Qed. - -Goal let x := 1 + 1 - 1 in x = x. -Proof. -intros x. -unfold &x at 1. -let x := reference:(Nat.sub) in unfold Nat.add, $x in x. -reflexivity. -Qed. - -Goal exists x y : nat, x = y. -Proof. -exists 0, 0; reflexivity. -Qed. - -Goal exists x y : nat, x = y. -Proof. -eexists _, 0; reflexivity. -Qed. - -Goal exists x y : nat, x = y. -Proof. -refine '(let x := 0 in _). -eexists; exists &x; reflexivity. -Qed. - -Goal True. -Proof. -pose (X := True). -constructor. -Qed. - -Goal True. -Proof. -pose True as X. -constructor. -Qed. - -Goal True. -Proof. -let x := @foo in -set ($x := True) in * |-. -constructor. -Qed. - -Goal 0 = 0. -Proof. -remember 0 as n eqn: foo at 1. -rewrite foo. -reflexivity. -Qed. - -Goal True. -Proof. -assert (H := 0 + 0). -constructor. -Qed. - -Goal True. -Proof. -assert (exists n, n = 0) as [n Hn]. -+ exists 0; reflexivity. -+ exact I. -Qed. - -Goal True -> True. -Proof. -assert (H : 0 + 0 = 0) by reflexivity. -intros x; exact x. -Qed. - -Goal 1 + 1 = 2. -Proof. -change (?a + 1 = 2) with (2 = $a + 1). -reflexivity. -Qed. - -Goal (forall n, n = 0 -> False) -> False. -Proof. -intros H. -specialize (H 0 eq_refl). -destruct H. -Qed. - -Goal (forall n, n = 0 -> False) -> False. -Proof. -intros H. -specialize (H 0 eq_refl) as []. -Qed. diff --git a/vendor/Ltac2/tests/matching.v b/vendor/Ltac2/tests/matching.v deleted file mode 100644 index 4338cbd32f..0000000000 --- a/vendor/Ltac2/tests/matching.v +++ /dev/null @@ -1,71 +0,0 @@ -Require Import Ltac2.Ltac2 Ltac2.Notations. - -Ltac2 Type exn ::= [ Nope ]. - -Ltac2 check_id id id' := match Ident.equal id id' with -| true => () -| false => Control.throw Nope -end. - -Goal True -> False. -Proof. -Fail -let b := { contents := true } in -let f c := - match b.(contents) with - | true => Message.print (Message.of_constr c); b.(contents) := false; fail - | false => () - end -in -(** This fails because the matching is not allowed to backtrack once - it commits to a branch*) -lazy_match! '(nat -> bool) with context [?a] => f a end. -lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. - -(** This one works by taking the second match context, i.e. ?a := nat *) -let b := { contents := true } in -let f c := - match b.(contents) with - | true => b.(contents) := false; fail - | false => Message.print (Message.of_constr c) - end -in -match! '(nat -> bool) with context [?a] => f a end. -Abort. - -Goal forall (i j : unit) (x y : nat) (b : bool), True. -Proof. -Fail match! goal with -| [ h : ?t, h' : ?t |- _ ] => () -end. -intros i j x y b. -match! goal with -| [ h : ?t, h' : ?t |- _ ] => - check_id h @x; - check_id h' @y -end. -match! reverse goal with -| [ h : ?t, h' : ?t |- _ ] => - check_id h @j; - check_id h' @i -end. -Abort. - -(* Check #79 *) -Goal 2 = 3. - Control.plus - (fun () - => lazy_match! goal with - | [ |- 2 = 3 ] => Control.zero (Tactic_failure None) - | [ |- 2 = _ ] => Control.zero (Tactic_failure (Some (Message.of_string "should not be printed"))) - end) - (fun e - => match e with - | Tactic_failure c - => match c with - | None => () - | _ => Control.zero e - end - | e => Control.zero e - end). -Abort. diff --git a/vendor/Ltac2/tests/quot.v b/vendor/Ltac2/tests/quot.v deleted file mode 100644 index 624c4ad0c1..0000000000 --- a/vendor/Ltac2/tests/quot.v +++ /dev/null @@ -1,26 +0,0 @@ -Require Import Ltac2.Ltac2. - -(** Test for quotations *) - -Ltac2 ref0 () := reference:(&x). -Ltac2 ref1 () := reference:(nat). -Ltac2 ref2 () := reference:(Datatypes.nat). -Fail Ltac2 ref () := reference:(i_certainly_dont_exist). -Fail Ltac2 ref () := reference:(And.Me.neither). - -Goal True. -Proof. -let x := constr:(I) in -let y := constr:((fun z => z) $x) in -Control.refine (fun _ => y). -Qed. - -Goal True. -Proof. -(** Here, Ltac2 should not put its variables in the same environment as - Ltac1 otherwise the second binding fails as x is bound but not an - ident. *) -let x := constr:(I) in -let y := constr:((fun x => x) $x) in -Control.refine (fun _ => y). -Qed. diff --git a/vendor/Ltac2/tests/rebind.v b/vendor/Ltac2/tests/rebind.v deleted file mode 100644 index e1c20a2059..0000000000 --- a/vendor/Ltac2/tests/rebind.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Import Ltac2.Ltac2 Ltac2.Notations. - -Ltac2 mutable foo () := constructor. - -Goal True. -Proof. -foo (). -Qed. - -Ltac2 Set foo := fun _ => fail. - -Goal True. -Proof. -Fail foo (). -constructor. -Qed. - -(** Not the right type *) -Fail Ltac2 Set foo := 0. - -Ltac2 bar () := (). - -(** Cannot redefine non-mutable tactics *) -Fail Ltac2 Set bar := fun _ => (). - -(** Subtype check *) - -Ltac2 mutable rec f x := f x. - -Fail Ltac2 Set f := fun x => x. - -Ltac2 mutable g x := x. - -Ltac2 Set g := f. diff --git a/vendor/Ltac2/tests/stuff/ltac2.v b/vendor/Ltac2/tests/stuff/ltac2.v deleted file mode 100644 index 370bc70d15..0000000000 --- a/vendor/Ltac2/tests/stuff/ltac2.v +++ /dev/null @@ -1,143 +0,0 @@ -Require Import Ltac2.Ltac2. - -Ltac2 foo (_ : int) := - let f (x : int) := x in - let _ := f 0 in - f 1. - -Print Ltac2 foo. - -Import Control. - -Ltac2 exact x := refine (fun () => x). - -Print Ltac2 refine. -Print Ltac2 exact. - -Ltac2 foo' () := ident:(bla). - -Print Ltac2 foo'. - -Ltac2 bar x h := match x with -| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) -| Some x => x -end. - -Print Ltac2 bar. - -Ltac2 qux := Some 0. - -Print Ltac2 qux. - -Ltac2 Type foo := [ Foo (int) ]. - -Fail Ltac2 qux0 := Foo None. - -Ltac2 Type 'a ref := { mutable contents : 'a }. - -Fail Ltac2 qux0 := { contents := None }. -Ltac2 foo0 () := { contents := None }. - -Print Ltac2 foo0. - -Ltac2 qux0 x := x.(contents). -Ltac2 qux1 x := x.(contents) := x.(contents). - -Ltac2 qux2 := ([1;2], true). - -Print Ltac2 qux0. -Print Ltac2 qux1. -Print Ltac2 qux2. - -Import Control. - -Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). - -Print Ltac2 qux3. - -Ltac2 Type rec nat := [ O | S (nat) ]. - -Ltac2 message_of_nat n := -let rec aux n := -match n with -| O => Message.of_string "O" -| S n => Message.concat (Message.of_string "S") (aux n) -end in aux n. - -Print Ltac2 message_of_nat. - -Ltac2 numgoals () := - let r := { contents := O } in - enter (fun () => r.(contents) := S (r.(contents))); - r.(contents). - -Print Ltac2 numgoals. - -Goal True /\ False. -Proof. -let n := numgoals () in Message.print (message_of_nat n). -refine (fun () => open_constr:((fun x => conj _ _) 0)); (). -let n := numgoals () in Message.print (message_of_nat n). - -Fail (hyp ident:(x)). -Fail (enter (fun () => hyp ident:(There_is_no_spoon); ())). - -enter (fun () => Message.print (Message.of_string "foo")). - -enter (fun () => Message.print (Message.of_constr (goal ()))). -Fail enter (fun () => Message.print (Message.of_constr (qux3 ident:(x)))). -enter (fun () => plus (fun () => constr:(_); ()) (fun _ => ())). -plus - (fun () => enter (fun () => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). -let x := { contents := 0 } in -let x := x.(contents) := x.(contents) in x. -Abort. - -Ltac2 Type exn ::= [ Foo ]. - -Goal True. -Proof. -plus (fun () => zero Foo) (fun _ => ()). -Abort. - -Ltac2 Type exn ::= [ Bar (string) ]. - -Goal True. -Proof. -Fail zero (Bar "lol"). -Abort. - -Ltac2 Notation "refine!" c(thunk(constr)) := refine c. - -Goal True. -Proof. -refine! I. -Abort. - -Goal True. -Proof. -let x () := plus (fun () => 0) (fun _ => 1) in -match case x with -| Val x => - match x with - | (x, k) => Message.print (Message.of_int (k Not_found)) - end -| Err x => Message.print (Message.of_string "Err") -end. -Abort. - -Goal (forall n : nat, n = 0 -> False) -> True. -Proof. -refine (fun () => '(fun H => _)). -Std.case true (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). -refine (fun () => 'eq_refl). -Qed. - -Goal forall x, 1 + x = x + 1. -Proof. -refine (fun () => '(fun x => _)). -Std.cbv { - Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; - Std.rZeta := true; Std.rDelta := true; Std.rConst := []; -} { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. -Abort. diff --git a/vendor/Ltac2/tests/tacticals.v b/vendor/Ltac2/tests/tacticals.v deleted file mode 100644 index 1a2fbcbb37..0000000000 --- a/vendor/Ltac2/tests/tacticals.v +++ /dev/null @@ -1,34 +0,0 @@ -Require Import Ltac2.Ltac2. - -Import Ltac2.Notations. - -Goal True. -Proof. -Fail fail. -Fail solve [ () ]. -try fail. -repeat fail. -repeat (). -solve [ constructor ]. -Qed. - -Goal True. -Proof. -first [ - Message.print (Message.of_string "Yay"); fail -| constructor -| Message.print (Message.of_string "I won't be printed") -]. -Qed. - -Goal True /\ True. -Proof. -Fail split > [ split | |]. -split > [split | split]. -Qed. - -Goal True /\ (True -> True) /\ True. -Proof. -split > [ | split] > [split | .. | split]. -intros H; refine &H. -Qed. diff --git a/vendor/Ltac2/tests/typing.v b/vendor/Ltac2/tests/typing.v deleted file mode 100644 index 9f18292716..0000000000 --- a/vendor/Ltac2/tests/typing.v +++ /dev/null @@ -1,72 +0,0 @@ -Require Import Ltac2.Ltac2. - -(** Ltac2 is typed à la ML. *) - -Ltac2 test0 n := Int.add n 1. - -Print Ltac2 test0. - -Ltac2 test1 () := test0 0. - -Print Ltac2 test1. - -Fail Ltac2 test2 () := test0 true. - -Fail Ltac2 test2 () := test0 0 0. - -Ltac2 test3 f x := x, (f x, x). - -Print Ltac2 test3. - -(** Polymorphism *) - -Ltac2 rec list_length l := -match l with -| [] => 0 -| x :: l => Int.add 1 (list_length l) -end. - -Print Ltac2 list_length. - -(** Pattern-matching *) - -Ltac2 ifb b f g := match b with -| true => f () -| false => g () -end. - -Print Ltac2 ifb. - -Ltac2 if_not_found e f g := match e with -| Not_found => f () -| _ => g () -end. - -Fail Ltac2 ifb' b f g := match b with -| true => f () -end. - -Fail Ltac2 if_not_found' e f g := match e with -| Not_found => f () -end. - -(** Reimplementing 'do'. Return value of the function useless. *) - -Ltac2 rec do n tac := match Int.equal n 0 with -| true => () -| false => tac (); do (Int.sub n 1) tac -end. - -Print Ltac2 do. - -(** Non-function pure values are OK. *) - -Ltac2 tuple0 := ([1; 2], true, (fun () => "yay")). - -Print Ltac2 tuple0. - -(** Impure values are not. *) - -Fail Ltac2 not_a_value := { contents := 0 }. -Fail Ltac2 not_a_value := "nope". -Fail Ltac2 not_a_value := list_length []. diff --git a/vendor/Ltac2/theories/Array.v b/vendor/Ltac2/theories/Array.v deleted file mode 100644 index 11b64e3515..0000000000 --- a/vendor/Ltac2/theories/Array.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> 'a array := "ltac2" "array_make". -Ltac2 @external length : 'a array -> int := "ltac2" "array_length". -Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". -Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/vendor/Ltac2/theories/Char.v b/vendor/Ltac2/theories/Char.v deleted file mode 100644 index 29fef60f2c..0000000000 --- a/vendor/Ltac2/theories/Char.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* char := "ltac2" "char_of_int". -Ltac2 @external to_int : char -> int := "ltac2" "char_to_int". diff --git a/vendor/Ltac2/theories/Constr.v b/vendor/Ltac2/theories/Constr.v deleted file mode 100644 index d8d222730e..0000000000 --- a/vendor/Ltac2/theories/Constr.v +++ /dev/null @@ -1,72 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr := "ltac2" "constr_type". -(** Return the type of a term *) - -Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". -(** Strict syntactic equality: only up to α-conversion and evar expansion *) - -Module Unsafe. - -(** Low-level access to kernel terms. Use with care! *) - -Ltac2 Type case. - -Ltac2 Type kind := [ -| Rel (int) -| Var (ident) -| Meta (meta) -| Evar (evar, constr array) -| Sort (sort) -| Cast (constr, cast, constr) -| Prod (ident option, constr, constr) -| Lambda (ident option, constr, constr) -| LetIn (ident option, constr, constr, constr) -| App (constr, constr array) -| Constant (constant, instance) -| Ind (inductive, instance) -| Constructor (constructor, instance) -| Case (case, constr, constr, constr array) -| Fix (int array, int, ident option array, constr array, constr array) -| CoFix (int, ident option array, constr array, constr array) -| Proj (projection, constr) -]. - -Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". - -Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". - -Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". -(** Checks that a constr generated by unsafe means is indeed safe in the - current environment, and returns it, or the error otherwise. Panics if - not focussed. *) - -Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". -(** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with - [r₁;...;rₙ] in [c]. *) - -Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "constr_closenl". -(** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with - [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) - -Ltac2 @ external case : inductive -> case := "ltac2" "constr_case". -(** Generate the case information for a given inductive type. *) - -Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "constr_constructor". -(** Generate the i-th constructor for a given inductive type. Indexing starts - at 0. Panics if there is no such constructor. *) - -End Unsafe. - -Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". -(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a - focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is - the proof built by the tactic. *) diff --git a/vendor/Ltac2/theories/Control.v b/vendor/Ltac2/theories/Control.v deleted file mode 100644 index 071c2ea8ce..0000000000 --- a/vendor/Ltac2/theories/Control.v +++ /dev/null @@ -1,76 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a := "ltac2" "throw". -(** Fatal exception throwing. This does not induce backtracking. *) - -(** Generic backtracking control *) - -Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". -Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". -Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". -Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". -Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". -Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". -Ltac2 @ external case : (unit -> 'a) -> ('a * (exn -> 'a)) result := "ltac2" "case". - -(** Proof state manipulation *) - -Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". -Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". -Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". - -Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". -(** Adds the given evar to the list of goals as the last one. If it is - already defined in the current state, don't do anything. Panics if the - evar is not in the current state. *) - -Ltac2 @ external progress : (unit -> 'a) -> 'a := "ltac2" "progress". - -(** Goal inspection *) - -Ltac2 @ external goal : unit -> constr := "ltac2" "goal". -(** Panics if there is not exactly one goal under focus. Otherwise returns - the conclusion of this goal. *) - -Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". -(** Panics if there is more than one goal under focus. If there is no - goal under focus, looks for the section variable with the given name. - If there is one, looks for the hypothesis with the given name. *) - -Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" "hyps". -(** Panics if there is more than one goal under focus. If there is no - goal under focus, returns the list of section variables. - If there is one, returns the list of hypotheses. In both cases, the - list is ordered with rightmost values being last introduced. *) - -(** Refinement *) - -Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". - -(** Evars *) - -Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_holes". -(** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if - all evars generated by the call to [x] have not been solved when [f] - returns. *) - -(** Misc *) - -Ltac2 @ external time : string option -> (unit -> 'a) -> 'a := "ltac2" "time". -(** Displays the time taken by a tactic to evaluate. *) - -Ltac2 @ external abstract : ident option -> (unit -> unit) -> unit := "ltac2" "abstract". -(** Abstract a subgoal. *) - -Ltac2 @ external check_interrupt : unit -> unit := "ltac2" "check_interrupt". -(** For internal use. *) diff --git a/vendor/Ltac2/theories/Env.v b/vendor/Ltac2/theories/Env.v deleted file mode 100644 index c9b250f4ba..0000000000 --- a/vendor/Ltac2/theories/Env.v +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Std.reference option := "ltac2" "env_get". -(** Returns the global reference corresponding to the absolute name given as - argument if it exists. *) - -Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". -(** Returns the list of all global references whose absolute name contains - the argument list as a prefix. *) - -Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". -(** Returns the absolute name of the given reference. Panics if the reference - does not exist. *) - -Ltac2 @ external instantiate : Std.reference -> constr := "ltac2" "env_instantiate". -(** Returns a fresh instance of the corresponding reference, in particular - generating fresh universe variables and constraints when this reference is - universe-polymorphic. *) diff --git a/vendor/Ltac2/theories/Fresh.v b/vendor/Ltac2/theories/Fresh.v deleted file mode 100644 index 5e876bb077..0000000000 --- a/vendor/Ltac2/theories/Fresh.v +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> t := "ltac2" "fresh_free_union". - -Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". - -Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". - -End Free. - -Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". -(** Generate a fresh identifier with the given base name which is not a - member of the provided set of free variables. *) diff --git a/vendor/Ltac2/theories/Ident.v b/vendor/Ltac2/theories/Ident.v deleted file mode 100644 index 55456afbe2..0000000000 --- a/vendor/Ltac2/theories/Ident.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> bool := "ltac2" "ident_equal". - -Ltac2 @ external of_string : string -> t option := "ltac2" "ident_of_string". - -Ltac2 @ external to_string : t -> string := "ltac2" "ident_to_string". diff --git a/vendor/Ltac2/theories/Init.v b/vendor/Ltac2/theories/Init.v deleted file mode 100644 index 16e7d7a6f9..0000000000 --- a/vendor/Ltac2/theories/Init.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* int -> bool := "ltac2" "int_equal". -Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". -Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". -Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". -Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". -Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/vendor/Ltac2/theories/Ltac1.v b/vendor/Ltac2/theories/Ltac1.v deleted file mode 100644 index c4e0b606d0..0000000000 --- a/vendor/Ltac2/theories/Ltac1.v +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t := "ltac2" "ltac1_ref". -(** Returns the Ltac1 definition with the given absolute name. *) - -Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". -(** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning - anything. *) - -Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". -(** Applies an Ltac1 value to a list of arguments, and provides the result in - CPS style. It does **not** run the returned value. *) - -(** Conversion functions *) - -Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". -Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". - -Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". -Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/vendor/Ltac2/theories/Ltac2.v b/vendor/Ltac2/theories/Ltac2.v deleted file mode 100644 index ac90f63560..0000000000 --- a/vendor/Ltac2/theories/Ltac2.v +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit := "ltac2" "print". - -Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". - -Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". - -Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". - -Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". -(** Panics if there is more than one goal under focus. *) - -Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". -(** Panics if there is more than one goal under focus. *) - -Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/vendor/Ltac2/theories/Notations.v b/vendor/Ltac2/theories/Notations.v deleted file mode 100644 index f4621656d6..0000000000 --- a/vendor/Ltac2/theories/Notations.v +++ /dev/null @@ -1,568 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* f e -| Val ans => - let (x, k) := ans in - Control.plus (fun _ => x) k -end. - -Ltac2 ifcatch t s f := -match Control.case t with -| Err e => f e -| Val ans => - let (x, k) := ans in - Control.plus (fun _ => s x) (fun e => s (k e)) -end. - -Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero (Tactic_failure None)). - -Ltac2 Notation fail := fail0 (). - -Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). - -Ltac2 Notation try := try0. - -Ltac2 rec repeat0 (t : unit -> unit) := - Control.enter (fun () => - ifcatch (fun _ => Control.progress t) - (fun _ => Control.check_interrupt (); repeat0 t) (fun _ => ())). - -Ltac2 Notation repeat := repeat0. - -Ltac2 dispatch0 t (head, tail) := - match tail with - | None => Control.enter (fun _ => t (); Control.dispatch head) - | Some tacs => - let (def, rem) := tacs in - Control.enter (fun _ => t (); Control.extend head def rem) - end. - -Ltac2 Notation t(thunk(self)) ">" "[" l(dispatch) "]" : 4 := dispatch0 t l. - -Ltac2 do0 n t := - let rec aux n t := match Int.equal n 0 with - | true => () - | false => t (); aux (Int.sub n 1) t - end in - aux (n ()) t. - -Ltac2 Notation do := do0. - -Ltac2 Notation once := Control.once. - -Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). - -Ltac2 Notation progress := progress0. - -Ltac2 rec first0 tacs := -match tacs with -| [] => Control.zero (Tactic_failure None) -| tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) -end. - -Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs. - -Ltac2 complete tac := - let ans := tac () in - Control.enter (fun () => Control.zero (Tactic_failure None)); - ans. - -Ltac2 rec solve0 tacs := -match tacs with -| [] => Control.zero (Tactic_failure None) -| tac :: tacs => - Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) -end. - -Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. - -Ltac2 time0 tac := Control.time None tac. - -Ltac2 Notation time := time0. - -Ltac2 abstract0 tac := Control.abstract None tac. - -Ltac2 Notation abstract := abstract0. - -(** Base tactics *) - -(** Note that we redeclare notations that can be parsed as mere identifiers - as abbreviations, so that it allows to parse them as function arguments - without having to write them within parentheses. *) - -(** Enter and check evar resolution *) -Ltac2 enter_h ev f arg := -match ev with -| true => Control.enter (fun () => f ev (arg ())) -| false => - Control.enter (fun () => - Control.with_holes arg (fun x => f ev x)) -end. - -Ltac2 intros0 ev p := - Control.enter (fun () => Std.intros false p). - -Ltac2 Notation "intros" p(intropatterns) := intros0 false p. -Ltac2 Notation intros := intros. - -Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. -Ltac2 Notation eintros := eintros. - -Ltac2 split0 ev bnd := - enter_h ev Std.split bnd. - -Ltac2 Notation "split" bnd(thunk(with_bindings)) := split0 false bnd. -Ltac2 Notation split := split. - -Ltac2 Notation "esplit" bnd(thunk(with_bindings)) := split0 true bnd. -Ltac2 Notation esplit := esplit. - -Ltac2 exists0 ev bnds := match bnds with -| [] => split0 ev (fun () => Std.NoBindings) -| _ => - let rec aux bnds := match bnds with - | [] => () - | bnd :: bnds => split0 ev bnd; aux bnds - end in - aux bnds -end. - -Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. -(* Ltac2 Notation exists := exists. *) - -Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. -Ltac2 Notation eexists := eexists. - -Ltac2 left0 ev bnd := enter_h ev Std.left bnd. - -Ltac2 Notation "left" bnd(thunk(with_bindings)) := left0 false bnd. -Ltac2 Notation left := left. - -Ltac2 Notation "eleft" bnd(thunk(with_bindings)) := left0 true bnd. -Ltac2 Notation eleft := eleft. - -Ltac2 right0 ev bnd := enter_h ev Std.right bnd. - -Ltac2 Notation "right" bnd(thunk(with_bindings)) := right0 false bnd. -Ltac2 Notation right := right. - -Ltac2 Notation "eright" bnd(thunk(with_bindings)) := right0 true bnd. -Ltac2 Notation eright := eright. - -Ltac2 constructor0 ev n bnd := - enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. - -Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). -Ltac2 Notation constructor := constructor. -Ltac2 Notation "constructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 false n bnd. - -Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). -Ltac2 Notation econstructor := econstructor. -Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. - -Ltac2 specialize0 c pat := - enter_h false (fun _ c => Std.specialize c pat) c. - -Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("as", intropattern))) := - specialize0 c ipat. - -Ltac2 elim0 ev c bnd use := - let f ev (c, bnd, use) := Std.elim ev (c, bnd) use in - enter_h ev f (fun () => c (), bnd (), use ()). - -Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) - use(thunk(opt(seq("using", constr, with_bindings)))) := - elim0 false c bnd use. - -Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) - use(thunk(opt(seq("using", constr, with_bindings)))) := - elim0 true c bnd use. - -Ltac2 apply0 adv ev cb cl := - Std.apply adv ev cb cl. - -Ltac2 Notation "eapply" - cb(list1(thunk(seq(constr, with_bindings)), ",")) - cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := - apply0 true true cb cl. - -Ltac2 Notation "apply" - cb(list1(thunk(seq(constr, with_bindings)), ",")) - cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := - apply0 true false cb cl. - -Ltac2 default_on_concl cl := -match cl with -| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } -| Some cl => cl -end. - -Ltac2 pose0 ev p := - enter_h ev (fun ev (na, p) => Std.pose na p) p. - -Ltac2 Notation "pose" p(thunk(pose)) := - pose0 false p. - -Ltac2 Notation "epose" p(thunk(pose)) := - pose0 true p. - -Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := - Std.set false p (default_on_concl cl). - -Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := - Std.set true p (default_on_concl cl). - -Ltac2 assert0 ev ast := - enter_h ev (fun _ ast => Std.assert ast) ast. - -Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. - -Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. - -Ltac2 default_everywhere cl := -match cl with -| None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } -| Some cl => cl -end. - -Ltac2 Notation "remember" - c(thunk(open_constr)) - na(opt(seq("as", ident))) - pat(opt(seq("eqn", ":", intropattern))) - cl(opt(clause)) := - Std.remember false na c pat (default_everywhere cl). - -Ltac2 Notation "eremember" - c(thunk(open_constr)) - na(opt(seq("as", ident))) - pat(opt(seq("eqn", ":", intropattern))) - cl(opt(clause)) := - Std.remember true na c pat (default_everywhere cl). - -Ltac2 induction0 ev ic use := - let f ev use := Std.induction ev ic use in - enter_h ev f use. - -Ltac2 Notation "induction" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - induction0 false ic use. - -Ltac2 Notation "einduction" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - induction0 true ic use. - -Ltac2 generalize0 gen := - enter_h false (fun _ gen => Std.generalize gen) gen. - -Ltac2 Notation "generalize" - gen(thunk(list1(seq (open_constr, occurrences, opt(seq("as", ident))), ","))) := - generalize0 gen. - -Ltac2 destruct0 ev ic use := - let f ev use := Std.destruct ev ic use in - enter_h ev f use. - -Ltac2 Notation "destruct" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - destruct0 false ic use. - -Ltac2 Notation "edestruct" - ic(list1(induction_clause, ",")) - use(thunk(opt(seq("using", constr, with_bindings)))) := - destruct0 true ic use. - -Ltac2 Notation "simple" "inversion" - arg(destruction_arg) - pat(opt(seq("as", intropattern))) - ids(opt(seq("in", list1(ident)))) := - Std.inversion Std.SimpleInversion arg pat ids. - -Ltac2 Notation "inversion" - arg(destruction_arg) - pat(opt(seq("as", intropattern))) - ids(opt(seq("in", list1(ident)))) := - Std.inversion Std.FullInversion arg pat ids. - -Ltac2 Notation "inversion_clear" - arg(destruction_arg) - pat(opt(seq("as", intropattern))) - ids(opt(seq("in", list1(ident)))) := - Std.inversion Std.FullInversionClear arg pat ids. - -Ltac2 Notation "red" cl(opt(clause)) := - Std.red (default_on_concl cl). -Ltac2 Notation red := red. - -Ltac2 Notation "hnf" cl(opt(clause)) := - Std.hnf (default_on_concl cl). -Ltac2 Notation hnf := hnf. - -Ltac2 Notation "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.simpl s pl (default_on_concl cl). -Ltac2 Notation simpl := simpl. - -Ltac2 Notation "cbv" s(strategy) cl(opt(clause)) := - Std.cbv s (default_on_concl cl). -Ltac2 Notation cbv := cbv. - -Ltac2 Notation "cbn" s(strategy) cl(opt(clause)) := - Std.cbn s (default_on_concl cl). -Ltac2 Notation cbn := cbn. - -Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := - Std.lazy s (default_on_concl cl). -Ltac2 Notation lazy := lazy. - -Ltac2 Notation "unfold" pl(list1(seq(reference, occurrences), ",")) cl(opt(clause)) := - Std.unfold pl (default_on_concl cl). - -Ltac2 fold0 pl cl := - let cl := default_on_concl cl in - Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). - -Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := - fold0 pl cl. - -Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := - Std.pattern pl (default_on_concl cl). - -Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.vm pl (default_on_concl cl). -Ltac2 Notation vm_compute := vm_compute. - -Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := - Std.native pl (default_on_concl cl). -Ltac2 Notation native_compute := native_compute. - -Ltac2 change0 p cl := - let (pat, c) := p in - Std.change pat c (default_on_concl cl). - -Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. - -Ltac2 rewrite0 ev rw cl tac := - let cl := default_on_concl cl in - Std.rewrite ev rw cl tac. - -Ltac2 Notation "rewrite" - rw(list1(rewriting, ",")) - cl(opt(clause)) - tac(opt(seq("by", thunk(tactic)))) := - rewrite0 false rw cl tac. - -Ltac2 Notation "erewrite" - rw(list1(rewriting, ",")) - cl(opt(clause)) - tac(opt(seq("by", thunk(tactic)))) := - rewrite0 true rw cl tac. - -(** coretactics *) - -Ltac2 exact0 ev c := - Control.enter (fun _ => - match ev with - | true => - let c := c () in - Control.refine (fun _ => c) - | false => - Control.with_holes c (fun c => Control.refine (fun _ => c)) - end - ). - -Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. -Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. - -Ltac2 Notation "intro" id(opt(ident)) mv(opt(move_location)) := Std.intro id mv. -Ltac2 Notation intro := intro. - -Ltac2 Notation "move" id(ident) mv(move_location) := Std.move id mv. - -Ltac2 Notation reflexivity := Std.reflexivity (). - -Ltac2 symmetry0 cl := - Std.symmetry (default_on_concl cl). - -Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. -Ltac2 Notation symmetry := symmetry. - -Ltac2 Notation "revert" ids(list1(ident)) := Std.revert ids. - -Ltac2 Notation assumption := Std.assumption (). - -Ltac2 Notation etransitivity := Std.etransitivity (). - -Ltac2 Notation admit := Std.admit (). - -Ltac2 clear0 ids := match ids with -| [] => Std.keep [] -| _ => Std.clear ids -end. - -Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. -Ltac2 Notation "clear" "-" ids(list1(ident)) := Std.keep ids. -Ltac2 Notation clear := clear. - -Ltac2 Notation refine := Control.refine. - -(** extratactics *) - -Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). - -Ltac2 Notation "absurd" c(thunk(open_constr)) := absurd0 c. - -Ltac2 subst0 ids := match ids with -| [] => Std.subst_all () -| _ => Std.subst ids -end. - -Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. -Ltac2 Notation subst := subst. - -Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := - Std.discriminate false arg. -Ltac2 Notation discriminate := discriminate. - -Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := - Std.discriminate true arg. -Ltac2 Notation ediscriminate := ediscriminate. - -Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= - Std.injection false ipat arg. - -Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= - Std.injection true ipat arg. - -(** Auto *) - -Ltac2 default_db dbs := match dbs with -| None => Some [] -| Some dbs => - match dbs with - | None => None - | Some l => Some l - end -end. - -Ltac2 default_list use := match use with -| None => [] -| Some use => use -end. - -Ltac2 trivial0 use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.trivial Std.Off use dbs. - -Ltac2 Notation "trivial" - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := trivial0 use dbs. - -Ltac2 Notation trivial := trivial. - -Ltac2 auto0 n use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.auto Std.Off n use dbs. - -Ltac2 Notation "auto" n(opt(tactic(0))) - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := auto0 n use dbs. - -Ltac2 Notation auto := auto. - -Ltac2 new_eauto0 n use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.new_auto Std.Off n use dbs. - -Ltac2 Notation "new" "auto" n(opt(tactic(0))) - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := new_eauto0 n use dbs. - -Ltac2 eauto0 n p use dbs := - let dbs := default_db dbs in - let use := default_list use in - Std.eauto Std.Off n p use dbs. - -Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) - use(opt(seq("using", list1(thunk(constr), ",")))) - dbs(opt(seq("with", hintdb))) := eauto0 n p use dbs. - -Ltac2 Notation eauto := eauto. - -Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) - dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto None n dbs. - -Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) - dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto (Some Std.BFS) n dbs. - -Ltac2 Notation typeclasses_eauto := typeclasses_eauto. - -(** Congruence *) - -Ltac2 f_equal0 () := ltac1:(f_equal). -Ltac2 Notation f_equal := f_equal0 (). - -(** Firstorder *) - -Ltac2 firstorder0 tac refs ids := - let refs := default_list refs in - let ids := default_list ids in - Std.firstorder tac refs ids. - -Ltac2 Notation "firstorder" - tac(opt(thunk(tactic))) - refs(opt(seq("using", list1(reference, ",")))) - ids(opt(seq("with", list1(ident)))) := firstorder0 tac refs ids. - -(** now *) - -Ltac2 now0 t := t (); ltac1:(easy). -Ltac2 Notation "now" t(thunk(self)) := now0 t. diff --git a/vendor/Ltac2/theories/Pattern.v b/vendor/Ltac2/theories/Pattern.v deleted file mode 100644 index 8d1fb0cd8a..0000000000 --- a/vendor/Ltac2/theories/Pattern.v +++ /dev/null @@ -1,145 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* context := - "ltac2" "pattern_empty_context". -(** A trivial context only made of the hole. *) - -Ltac2 @ external matches : t -> constr -> (ident * constr) list := - "ltac2" "pattern_matches". -(** If the term matches the pattern, returns the bound variables. If it doesn't, - fail with [Match_failure]. Panics if not focussed. *) - -Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := - "ltac2" "pattern_matches_subterm". -(** Returns a stream of results corresponding to all of the subterms of the term - that matches the pattern as in [matches]. The stream is encoded as a - backtracking value whose last exception is [Match_failure]. The additional - value compared to [matches] is the context of the match, to be filled with - the instantiate function. *) - -Ltac2 @ external matches_vect : t -> constr -> constr array := - "ltac2" "pattern_matches_vect". -(** Internal version of [matches] that does not return the identifiers. *) - -Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := - "ltac2" "pattern_matches_subterm_vect". -(** Internal version of [matches_subterms] that does not return the identifiers. *) - -Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t) -> - ident array * context array * constr array * context := - "ltac2" "pattern_matches_goal". -(** Given a list of patterns [hpats] for hypotheses and one pattern [cpat] for the - conclusion, [matches_goal rev hpats cpat] produces (a stream of) tuples of: - - An array of idents, whose size is the length of [hpats], corresponding to the - name of matched hypotheses. - - An array of contexts, whose size is the length of [hpats], corresponding to - the contexts matched for every hypothesis pattern. In case the match kind of - a hypothesis was [MatchPattern], the corresponding context is ensured to be empty. - - An array of terms, whose size is the total number of pattern variables without - duplicates. Terms are ordered by identifier order, e.g. ?a comes before ?b. - - A context corresponding to the conclusion, which is ensured to be empty if - the kind of [cpat] was [MatchPattern]. - This produces a backtracking stream of results containing all the possible - result combinations. The order of considered hypotheses is reversed if [rev] - is true. -*) - -Ltac2 @ external instantiate : context -> constr -> constr := - "ltac2" "pattern_instantiate". -(** Fill the hole of a context with the given term. *) - -(** Implementation of Ltac matching over terms and goals *) - -Ltac2 lazy_match0 t pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (knd, pat, f) := p in - let p := match knd with - | MatchPattern => - (fun _ => - let context := empty_context () in - let bind := matches_vect pat t in - fun _ => f context bind) - | MatchContext => - (fun _ => - let (context, bind) := matches_subterm_vect pat t in - fun _ => f context bind) - end in - Control.plus p next - end in - Control.once (fun () => interp pats) (). - -Ltac2 multi_match0 t pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (knd, pat, f) := p in - let p := match knd with - | MatchPattern => - (fun _ => - let context := empty_context () in - let bind := matches_vect pat t in - f context bind) - | MatchContext => - (fun _ => - let (context, bind) := matches_subterm_vect pat t in - f context bind) - end in - Control.plus p next - end in - interp pats. - -Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). - -Ltac2 lazy_goal_match0 rev pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (pat, f) := p in - let (phyps, pconcl) := pat in - let cur _ := - let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in - fun _ => f hids hctx subst cctx - in - Control.plus cur next - end in - Control.once (fun () => interp pats) (). - -Ltac2 multi_goal_match0 rev pats := - let rec interp m := match m with - | [] => Control.zero Match_failure - | p :: m => - let next _ := interp m in - let (pat, f) := p in - let (phyps, pconcl) := pat in - let cur _ := - let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in - f hids hctx subst cctx - in - Control.plus cur next - end in - interp pats. - -Ltac2 one_goal_match0 rev pats := Control.once (fun _ => multi_goal_match0 rev pats). diff --git a/vendor/Ltac2/theories/Std.v b/vendor/Ltac2/theories/Std.v deleted file mode 100644 index 73b2ba02c4..0000000000 --- a/vendor/Ltac2/theories/Std.v +++ /dev/null @@ -1,263 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr), intro_pattern) -| IntroRewrite (bool) -] -with or_and_intro_pattern := [ -| IntroOrPattern (intro_pattern list list) -| IntroAndPattern (intro_pattern list) -]. - -Ltac2 Type destruction_arg := [ -| ElimOnConstr (unit -> constr_with_bindings) -| ElimOnIdent (ident) -| ElimOnAnonHyp (int) -]. - -Ltac2 Type induction_clause := { - indcl_arg : destruction_arg; - indcl_eqn : intro_pattern_naming option; - indcl_as : or_and_intro_pattern option; - indcl_in : clause option; -}. - -Ltac2 Type assertion := [ -| AssertType (intro_pattern option, constr, (unit -> unit) option) -| AssertValue (ident, constr) -]. - -Ltac2 Type repeat := [ -| Precisely (int) -| UpTo (int) -| RepeatStar -| RepeatPlus -]. - -Ltac2 Type orientation := [ LTR | RTL ]. - -Ltac2 Type rewriting := { - rew_orient : orientation option; - rew_repeat : repeat; - rew_equatn : (unit -> constr_with_bindings); -}. - -Ltac2 Type evar_flag := bool. -Ltac2 Type advanced_flag := bool. - -Ltac2 Type move_location := [ -| MoveAfter (ident) -| MoveBefore (ident) -| MoveFirst -| MoveLast -]. - -Ltac2 Type inversion_kind := [ -| SimpleInversion -| FullInversion -| FullInversionClear -]. - -(** Standard, built-in tactics. See Ltac1 for documentation. *) - -Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". - -Ltac2 @ external apply : advanced_flag -> evar_flag -> - (unit -> constr_with_bindings) list -> (ident * (intro_pattern option)) option -> unit := "ltac2" "tac_apply". - -Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". -Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". - -Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". - -Ltac2 @ external assert : assertion -> unit := "ltac2" "tac_assert". -Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". - -Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". -Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". - -Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". - -Ltac2 @ external destruct : evar_flag -> induction_clause list -> - constr_with_bindings option -> unit := "ltac2" "tac_induction". - -Ltac2 @ external induction : evar_flag -> induction_clause list -> - constr_with_bindings option -> unit := "ltac2" "tac_induction". - -Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". -Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". -Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_simpl". -Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". -Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". -Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". -Ltac2 @ external unfold : (reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". -Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". -Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". -Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". -Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". - -Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". -Ltac2 @ external eval_hnf : constr -> constr := "ltac2" "eval_hnf". -Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". -Ltac2 @ external eval_simpl : red_flags -> (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_simpl". -Ltac2 @ external eval_cbv : red_flags -> constr -> constr := "ltac2" "eval_cbv". -Ltac2 @ external eval_cbn : red_flags -> constr -> constr := "ltac2" "eval_cbn". -Ltac2 @ external eval_lazy : red_flags -> constr -> constr := "ltac2" "eval_lazy". -Ltac2 @ external eval_unfold : (reference * occurrences) list -> constr -> constr := "ltac2" "eval_unfold". -Ltac2 @ external eval_fold : constr list -> constr -> constr := "ltac2" "eval_fold". -Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr := "ltac2" "eval_pattern". -Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". -Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". - -Ltac2 @ external change : pattern option -> (constr array -> constr) -> clause -> unit := "ltac2" "tac_change". - -Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". - -Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". - -Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". - -Ltac2 @ external transitivity : constr -> unit := "ltac2" "tac_transitivity". - -Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". - -Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". - -Ltac2 @ external left : evar_flag -> bindings -> unit := "ltac2" "tac_left". -Ltac2 @ external right : evar_flag -> bindings -> unit := "ltac2" "tac_right". - -Ltac2 @ external constructor : evar_flag -> unit := "ltac2" "tac_constructor". -Ltac2 @ external split : evar_flag -> bindings -> unit := "ltac2" "tac_split". - -Ltac2 @ external constructor_n : evar_flag -> int -> bindings -> unit := "ltac2" "tac_constructorn". - -Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". - -Ltac2 @ external symmetry : clause -> unit := "ltac2" "tac_symmetry". - -Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". - -Ltac2 @ external revert : ident list -> unit := "ltac2" "tac_revert". - -Ltac2 @ external admit : unit -> unit := "ltac2" "tac_admit". - -Ltac2 @ external fix_ : ident option -> int -> unit := "ltac2" "tac_fix". -Ltac2 @ external cofix_ : ident option -> unit := "ltac2" "tac_cofix". - -Ltac2 @ external clear : ident list -> unit := "ltac2" "tac_clear". -Ltac2 @ external keep : ident list -> unit := "ltac2" "tac_keep". - -Ltac2 @ external clearbody : ident list -> unit := "ltac2" "tac_clearbody". - -Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". -Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". -Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". - -Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern option -> ident list option -> unit := "ltac2" "tac_inversion". - -(** coretactics *) - -Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". - -Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". - -Ltac2 @ external specialize : constr_with_bindings -> intro_pattern option -> unit := "ltac2" "tac_specialize". - -(** extratactics *) - -Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". -Ltac2 @ external injection : evar_flag -> intro_pattern list option -> destruction_arg option -> unit := "ltac2" "tac_injection". - -Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". -Ltac2 @ external contradiction : constr_with_bindings option -> unit := "ltac2" "tac_contradiction". - -Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> clause -> unit := "ltac2" "tac_autorewrite". - -Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". -Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". - -(** auto *) - -Ltac2 Type debug := [ Off | Info | Debug ]. - -Ltac2 Type strategy := [ BFS | DFS ]. - -Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". - -Ltac2 @ external auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_auto". - -Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_newauto". - -Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". - -Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". - -(** firstorder *) - -Ltac2 @ external firstorder : (unit -> unit) option -> reference list -> ident list -> unit := "ltac2" "tac_firstorder". diff --git a/vendor/Ltac2/theories/String.v b/vendor/Ltac2/theories/String.v deleted file mode 100644 index 99e1dab76b..0000000000 --- a/vendor/Ltac2/theories/String.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* char -> string := "ltac2" "string_make". -Ltac2 @external length : string -> int := "ltac2" "string_length". -Ltac2 @external get : string -> int -> char := "ltac2" "string_get". -Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/vendor/Ltac2/theories/dune b/vendor/Ltac2/theories/dune deleted file mode 100644 index 1fe3ba28fe..0000000000 --- a/vendor/Ltac2/theories/dune +++ /dev/null @@ -1,6 +0,0 @@ -(coqlib - (name Ltac2) ; This determines the -R flag - (public_name ltac2.Ltac2) - (synopsis "Ltac 2 Plugin") - (libraries ltac2.plugin)) - -- cgit v1.2.3 From 09bf8665bea5e9633609edd2d094155c82db3f9e Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 7 May 2019 08:07:22 +0000 Subject: [Canonical structures] Deforestation --- pretyping/recordops.ml | 44 ++++++++++++++++++-------------------------- 1 file changed, 18 insertions(+), 26 deletions(-) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 1feb8acd5f..d69824a256 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -191,41 +191,33 @@ let warn_projection_no_head_constant = (* Intended to always succeed *) let compute_canonical_projections env ~warn (con,ind) = - let ctx = Environ.constant_context env con in - let u = Univ.make_abstract_instance ctx in - let v = (mkConstU (con,u)) in + let o_CTX = Environ.constant_context env con in + let u = Univ.make_abstract_instance o_CTX in + let o_DEF = mkConstU (con, u) in let c = Environ.constant_value_in env (con,u) in let sign,t = Reductionops.splay_lam env (Evd.from_env env) (EConstr.of_constr c) in let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in - let lt = List.rev_map snd sign in + let o_TABS = List.rev_map snd sign in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in - let params, projs = List.chop p args in + let o_TPARAMS, projs = List.chop p args in + let o_NPARAMS = List.length o_TPARAMS in let lpj = keep_true_projections lpj kl in - let lps = List.combine lpj projs in let nenv = Termops.push_rels_assum sign env in - let comp = - List.fold_left - (fun l (spopt,t) -> (* comp=components *) - match spopt with - | Some proji_sp -> - begin - try - let patt, n , args = cs_pattern_of_constr nenv t in - ((ConstRef proji_sp, patt, t, n, args) :: l) - with Not_found -> - if warn then warn_projection_no_head_constant (sign,env,t,con,proji_sp); - l - end - | _ -> l) - [] lps in - List.map (fun (refi,c,t,inj,argj) -> - (refi,(c,t)), - {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; - o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) - comp + List.fold_left2 (fun acc spopt t -> + Option.cata (fun proji_sp -> + match cs_pattern_of_constr nenv t with + | patt, o_INJ, o_TCOMPS -> + ((ConstRef proji_sp, (patt, t)), + { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) + :: acc + | exception Not_found -> + if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); + acc + ) acc spopt + ) [] lpj projs let pr_cs_pattern = function Const_cs c -> Nametab.pr_global_env Id.Set.empty c -- cgit v1.2.3 From e6383e516036a15bccdbc2b125019a40181c6028 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 7 May 2019 08:07:28 +0000 Subject: [Record] Deforestation --- vernac/record.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/vernac/record.ml b/vernac/record.ml index 74e5a03659..d246c161a0 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -699,8 +699,7 @@ let definition_structure udecl kind ~template cum poly finite records = let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = - let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in - let coe = List.map (fun coe -> not (Option.is_empty coe)) coers in + let coe = List.map (fun (((coe, _), _), _) -> not (Option.is_empty coe)) cfs in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in -- cgit v1.2.3 From a7f678c2209bbe56b18ed3cdf1306fed161d7b07 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 7 May 2019 08:07:34 +0000 Subject: [Record] Une a record to gather field declaration attributes --- stm/vernac_classifier.ml | 2 +- vernac/g_vernac.mlg | 6 ++++-- vernac/ppvernac.ml | 6 +++--- vernac/record.ml | 14 +++++++------- vernac/record.mli | 2 +- vernac/vernacentries.ml | 5 +++-- vernac/vernacexpr.ml | 11 +++++++---- 7 files changed, 26 insertions(+), 20 deletions(-) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 674b4285d2..4a4c5c94e9 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -137,7 +137,7 @@ let classify_vernac e = | Constructors l -> List.map (fun (_,({v=id},_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some {v=x} -> [x] | _ -> []) @ CList.map_filter (function - | ((_,AssumExpr({v=Names.Name n},_)),_),_ -> Some n + | AssumExpr({v=Names.Name n},_), _ -> Some n | _ -> None) l) l in VtSideff (List.flatten ids), VtLater | VernacScheme l -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index d97fb523f7..59d2a66259 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -447,8 +447,10 @@ GRAMMAR EXTEND Gram *) (* ... with coercions *) record_field: - [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> { n } ]; - ntn = decl_notation -> { (bd,pri),ntn } ] ] + [ [ bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; + rf_notation = decl_notation -> { + let rf_subclass, rf_decl = bd in + rf_decl, { rf_subclass ; rf_priority ; rf_notation } } ] ] ; record_fields: [ [ f = record_field; ";"; fs = record_fields -> { f :: fs } diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 327efcda2b..889dbafabd 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -446,15 +446,15 @@ open Pputils | Some true -> str" :>" | Some false -> str" :>>" - let pr_record_field ((x, pri), ntn) = + let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = let env = Global.env () in let sigma = Evd.from_env env in let prx = match x with - | (oc,AssumExpr (id,t)) -> + | AssumExpr (id,t) -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ pr_lconstr_expr env sigma t) - | (oc,DefExpr(id,b,opt)) -> (match opt with + | DefExpr(id,b,opt) -> (match opt with | Some t -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ diff --git a/vernac/record.ml b/vernac/record.ml index d246c161a0..f489707eb3 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -634,7 +634,7 @@ let declare_existing_class g = open Vernacexpr let check_unique_names records = - let extract_name acc (((_, bnd), _), _) = match bnd with + let extract_name acc (rf_decl, _) = match rf_decl with Vernacexpr.AssumExpr({CAst.v=Name id},_) -> id::acc | Vernacexpr.DefExpr ({CAst.v=Name id},_,_) -> id::acc | _ -> acc in @@ -649,15 +649,15 @@ let check_unique_names records = let check_priorities kind records = let isnot_class = match kind with Class false -> false | _ -> true in let has_priority (_, _, _, cfs, _, _) = - List.exists (fun ((_, pri), _) -> not (Option.is_empty pri)) cfs + List.exists (fun (_, { rf_priority }) -> not (Option.is_empty rf_priority)) cfs in if isnot_class && List.exists has_priority records then user_err Pp.(str "Priorities only allowed for type class substructures") let extract_record_data records = let map (is_coe, id, _, cfs, idbuild, s) = - let fs = List.map (fun (((_, f), _), _) -> f) cfs in - id.CAst.v, s, List.map snd cfs, fs + let fs = List.map fst cfs in + id.CAst.v, s, List.map (fun (_, { rf_notation }) -> rf_notation) cfs, fs in let data = List.map map records in let pss = List.map (fun (_, _, ps, _, _, _) -> ps) records in @@ -691,15 +691,15 @@ let definition_structure udecl kind ~template cum poly finite records = | [r], [d] -> r, d | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") in - let priorities = List.map (fun ((_, id), _) -> {hint_priority = id; hint_pattern = None}) cfs in - let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in + let priorities = List.map (fun (_, { rf_priority }) -> {hint_priority = rf_priority ; hint_pattern = None}) cfs in + let coers = List.map (fun (_, { rf_subclass }) -> rf_subclass) cfs in declare_class def cum ubinders univs id.CAst.v idbuild implpars params arity template implfs fields coers priorities | _ -> let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = - let coe = List.map (fun (((coe, _), _), _) -> not (Option.is_empty coe)) cfs in + let coe = List.map (fun (_, { rf_subclass }) -> not (Option.is_empty rf_subclass)) cfs in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in diff --git a/vernac/record.mli b/vernac/record.mli index 12a2a765b5..d6e63901cd 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -33,7 +33,7 @@ val definition_structure : (coercion_flag * Names.lident * local_binder_expr list * - (local_decl_expr with_instance with_priority with_notation) list * + (local_decl_expr * record_field_attr) list * Id.t * constr_expr option) list -> GlobRef.t list diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 0f6374c506..388f6957cf 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -684,7 +684,7 @@ let vernac_record ~template udecl cum k poly finite records = let () = if Dumpglob.dump () then let () = Dumpglob.dump_definition id false "rec" in - let iter (((_, x), _), _) = match x with + let iter (x, _) = match x with | Vernacexpr.AssumExpr ({loc;v=Name id}, _) -> Dumpglob.dump_definition (make ?loc id) false "proj" | _ -> () @@ -743,7 +743,8 @@ let vernac_inductive ~atts cum lo finite indl = let (id, bl, c, l) = Option.get is_defclass in let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in - let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in + let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), + { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] } in vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 99b457effe..34a9b9394a 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -143,13 +143,16 @@ type decl_notation = lstring * constr_expr * scope_name option type simple_binder = lident list * constr_expr type class_binder = lident * constr_expr list type 'a with_coercion = coercion_flag * 'a -type 'a with_instance = instance_flag * 'a -type 'a with_notation = 'a * decl_notation list -type 'a with_priority = 'a * int option +(* Attributes of a record field declaration *) +type record_field_attr = { + rf_subclass: instance_flag; (* the projection is an implicit coercion or an instance *) + rf_priority: int option; (* priority of the instance, if relevant *) + rf_notation: decl_notation list; + } type constructor_expr = (lident * constr_expr) with_coercion type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list - | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list + | RecordDecl of lident option * (local_decl_expr * record_field_attr) list type inductive_expr = ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr -- cgit v1.2.3 From 781c31d2ce057e44506f1a16022e769869d2dbf6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 6 May 2019 12:28:32 +0200 Subject: Do not use the constant stack in whd_betaiota_deltazeta_for_iota_state. There is no point, it is always called with refolding turned off. --- pretyping/evarconv.ml | 74 +++++++++++++++++++++++----------------------- pretyping/evarconv.mli | 2 +- pretyping/reductionops.ml | 5 ++-- pretyping/reductionops.mli | 3 +- pretyping/unification.ml | 8 ++--- 5 files changed, 46 insertions(+), 46 deletions(-) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 0ccc4fd9f9..99013a19c9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -146,8 +146,8 @@ let flex_kind_of_term flags env evd c sk = let apprec_nohdbeta flags env evd c = let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in if flags.modulo_betaiota && Stack.not_purely_applicative sk - then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env evd Cst_stack.empty appr)) + then Stack.zip evd (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env evd appr) else c let position_problem l2r = function @@ -496,8 +496,8 @@ let rec evar_conv_x flags env evd pbty term1 term2 = let term2 = apprec_nohdbeta flags env evd term2 in let default () = evar_eqappr_x flags env evd pbty - (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) - (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (term1,Stack.empty)) + (whd_nored_state evd (term2,Stack.empty)) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> @@ -525,7 +525,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = end and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty - ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = + (term1, sk1 as appr1) (term2, sk2 as appr2) = let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in @@ -555,8 +555,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - flags.open_ts env' evd Cst_stack.empty (c'1, Stack.empty) in - let out2 = whd_nored_state evd + flags.open_ts env' evd (c'1, Stack.empty) in + let out2, _ = whd_nored_state evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x flags env' evd CONV out1 out2 @@ -636,11 +636,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else quick_fail i) ev lF tM i in - let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let flex_maybeflex on_left ev (termF,skF as apprF) (termM, skM as apprM) vM = let switch f a b = if on_left then f a b else f b a in let delta i = - switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) - (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i cstsM (vM,skM)) + switch (evar_eqappr_x flags env i pbty) apprF + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (vM,skM)) in let default i = ise_try i [miller on_left ev apprF apprM; consume on_left apprF apprM; @@ -658,11 +658,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f = try let termM' = Retyping.expand_projection env evd p c [] in - let apprM', cstsM' = - whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd cstsM (termM',skM) + let apprM' = + whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd (termM',skM) in let delta' i = - switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) (apprM',cstsM') + switch (evar_eqappr_x flags env i pbty) apprF apprM' in fun i -> ise_try i [miller on_left ev apprF apprM'; consume on_left apprF apprM'; delta'] @@ -718,7 +718,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (position_problem true pbty,destEvar i' ev1',term2) else evar_eqappr_x flags env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + (ev1', sk1) (term2, sk2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) @@ -728,7 +728,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) else evar_eqappr_x flags env evd pbty - ((ev2', sk1), csts1) ((term2, sk2), csts2) + (ev2', sk1) (term2, sk2) | Some ([],r), Success i' -> (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) @@ -738,7 +738,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) else evar_eqappr_x flags env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + (ev1', sk1) (term2, sk2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) if Stack.not_purely_applicative sk2 then @@ -808,10 +808,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ise_try evd [f1; f2; f3; f4; f5] | Flexible ev1, MaybeFlexible v2 -> - flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + flex_maybeflex true ev1 appr1 appr2 v2 | MaybeFlexible v1, Flexible ev2 -> - flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + flex_maybeflex false ev2 appr2 appr1 v1 | MaybeFlexible v1, MaybeFlexible v2 -> begin match EConstr.kind evd term1, EConstr.kind evd term2 with @@ -829,8 +829,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -841,8 +841,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty [(fun i -> evar_conv_x flags env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -855,8 +855,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in (match res with | Some (f1,args1) -> - evar_eqappr_x flags env evd pbty ((f1,Stack.append_app args1 sk1),csts1) - (appr2,csts2) + evar_eqappr_x flags env evd pbty (f1,Stack.append_app args1 sk1) + appr2 | None -> UnifFailure (evd,NotSameHead)) | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> @@ -866,7 +866,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in (match res with | Some (f2,args2) -> - evar_eqappr_x flags env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) + evar_eqappr_x flags env evd pbty appr1 (f2,Stack.append_app args2 sk2) | None -> UnifFailure (evd,NotSameHead)) | _, _ -> @@ -906,16 +906,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i Cst_stack.empty (subst1 b c, args))) + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (subst1 b c, args)) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i Cst_stack.empty (v2, applicative_stack))) in + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (v2, applicative_stack)) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in @@ -923,12 +923,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck flags env i pbty (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) - (appr2,csts2) + flags.open_ts env i(v1,sk1)) + appr2 else - evar_eqappr_x flags env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (v2,sk2)) in ise_try evd [f1; f2; f3] end @@ -957,8 +957,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty and f4 i = evar_eqappr_x flags env i pbty (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) - (appr2,csts2) + flags.open_ts env i (v1,sk1)) + appr2 in ise_try evd [f3; f4] @@ -969,9 +969,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else conv_record flags env i (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x flags env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (v2,sk2)) in ise_try evd [f3; f4] diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 0fe47c2a48..bf83f5e88f 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -144,7 +144,7 @@ val evar_unify : Evarsolve.unifier (* For debugging *) val evar_eqappr_x : ?rhs_is_already_stuck:bool -> unify_flags -> env -> evar_map -> - conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> + conv_pb -> state -> state -> Evarsolve.unification_result val occur_rigidly : Evarsolve.unify_flags -> diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1871609e18..120b4e6f00 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1675,7 +1675,7 @@ let is_sort env sigma t = (* reduction to head-normal-form allowing delta/zeta only in argument of case/fix (heuristic used by evar_conv) *) -let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = +let whd_betaiota_deltazeta_for_iota_state ts env sigma s = let refold = false in let tactic_mode = false in let rec whrec csts s = @@ -1696,7 +1696,8 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') else s,csts' |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' - in whrec csts s + in + fst (whrec Cst_stack.empty s) let find_conclusion env sigma = let rec decrec env c = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5938d9b367..b5d3ff7627 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -312,8 +312,7 @@ val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : - TransparentState.t -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> - state * Cst_stack.t + TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 9ba51dcfa9..d134c7319f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -489,8 +489,8 @@ let unfold_projection env p stk = let expand_key ts env sigma = function | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) | Some (IsProj (p, c)) -> - let red = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma - Cst_stack.empty (c, unfold_projection env p []))) + let red = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma + (c, unfold_projection env p [])) in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red | None -> None @@ -597,8 +597,8 @@ let constr_cmp pb env sigma flags t u = None let do_reduce ts (env, nb) sigma c = - Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state - ts env sigma Cst_stack.empty (c, Stack.empty))) + Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state + ts env sigma (c, Stack.empty)) let isAllowedEvar sigma flags c = match EConstr.kind sigma c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) -- cgit v1.2.3 From b0a6838ebe51760a6020145a0051137f6a4fcef0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 7 May 2019 11:31:15 +0200 Subject: Add overlays. --- dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh diff --git a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh new file mode 100644 index 0000000000..0e1449f36c --- /dev/null +++ b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10069" ] || [ "$CI_BRANCH" = "whd-for-evar-conv-no-stack" ]; then + + unicoq_CI_REF=whd-for-evar-conv-no-stack + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +fi -- cgit v1.2.3 From 7b1feee5963633bbbfcfeefd6eca0d344e1c1b8d Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 7 May 2019 13:11:42 +0200 Subject: [refman] Add a note reminding about the typeclass_instances database. Closes #10072. --- doc/sphinx/proof-engine/tactics.rst | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 1f339e7761..7d884fd929 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3863,9 +3863,9 @@ The general command to add a hint to some databases :n:`{+ @ident}` is terms and input heads *must not* contain existential variables or be existential variables respectively, while outputs can be any term. Multiple modes can be declared for a single identifier, in that case only one mode - needs to match the arguments for the hints to be applied.The head of a term + needs to match the arguments for the hints to be applied. The head of a term is understood here as the applicative head, or the match or projection - scrutinee’s head, recursively, casts being ignored. ``Hint Mode`` is + scrutinee’s head, recursively, casts being ignored. :cmd:`Hint Mode` is especially useful for typeclasses, when one does not want to support default instances and avoid ambiguity in general. Setting a parameter of a class as an input forces proof-search to be driven by that index of the class, with ``!`` @@ -3874,8 +3874,14 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. note:: - One can use an ``Extern`` hint with no pattern to do pattern matching on - hypotheses using ``match goal with`` inside the tactic. + + One can use a :cmd:`Hint Extern` with no pattern to do + pattern matching on hypotheses using ``match goal with`` + inside the tactic. + + + If you want to add hints such as :cmd:`Hint Transparent`, + :cmd:`Hint Cut`, or :cmd:`Hint Mode`, for typeclass + resolution, do not forget to put them in the + ``typeclass_instances`` hint database. Hint databases defined in the Coq standard library -- cgit v1.2.3 From e9d6aef75963126d7a856f5b88db8fd1e550f596 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 7 May 2019 14:40:02 +0200 Subject: Define minimum Sphinx version in conf.py. We set the minimum Sphinx version in conf.py to the one that we test in our CI and the one that is documented in doc/README.md. Hopefully, it will allow users with lower Sphinx verisons get better error messages. --- doc/sphinx/conf.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 48ad60c6dd..972a53ae36 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -47,7 +47,7 @@ with open("refman-preamble.rst") as s: # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. -#needs_sphinx = '1.0' +needs_sphinx = '1.7.8' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom -- cgit v1.2.3 From 928bced545407a2043fe2acaa5b31b1aa07988d5 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 7 May 2019 14:43:55 +0200 Subject: Remove ppedrot/ltac2 from CI after integration in main repo --- .gitlab-ci.yml | 3 --- Makefile.ci | 1 - dev/ci/ci-basic-overlay.sh | 7 ------- dev/ci/ci-ltac2.sh | 8 -------- 4 files changed, 19 deletions(-) delete mode 100755 dev/ci/ci-ltac2.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2bfb91f27f..e4815920ce 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -638,9 +638,6 @@ plugin:ci-equations: plugin:ci-fiat_parsers: extends: .ci-template -plugin:ci-ltac2: - extends: .ci-template - plugin:ci-mtac2: extends: .ci-template diff --git a/Makefile.ci b/Makefile.ci index a244c17ef3..95ebd64ba1 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -32,7 +32,6 @@ CI_TARGETS= \ ci-coqhammer \ ci-hott \ ci-iris-lambda-rust \ - ci-ltac2 \ ci-math-classes \ ci-math-comp \ ci-mtac2 \ diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4f5988c59c..f97e781832 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -80,13 +80,6 @@ : "${coqhammer_CI_GITURL:=https://github.com/lukaszcz/coqhammer}" : "${coqhammer_CI_ARCHIVEURL:=${coqhammer_CI_GITURL}/archive}" -######################################################################## -# Ltac2 -######################################################################## -: "${ltac2_CI_REF:=master}" -: "${ltac2_CI_GITURL:=https://github.com/ppedrot/ltac2}" -: "${ltac2_CI_ARCHIVEURL:=${ltac2_CI_GITURL}/archive}" - ######################################################################## # GeoCoq ######################################################################## diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh deleted file mode 100755 index 4df22bf249..0000000000 --- a/dev/ci/ci-ltac2.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download ltac2 - -( cd "${CI_BUILD_DIR}/ltac2" && make && make tests && make install ) -- cgit v1.2.3 From 86fa401ceaa17bdf1d297808eff3f8c3792d2778 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 7 May 2019 14:56:51 +0200 Subject: Fix PLUGINSVO computation after ltac2 integration Avoid looking at random installed packages in -local mode. --- Makefile.vofiles | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.vofiles b/Makefile.vofiles index e05822c889..5296ed43ff 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -13,7 +13,7 @@ endif ########################################################################### THEORIESVO := $(patsubst %.v,%.$(VO),$(shell find theories -type f -name "*.v")) -PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins user-contrib -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins $(addprefix user-contrib/, $(USERCONTRIBDIRS)) -type f -name "*.v")) ALLVO := $(THEORIESVO) $(PLUGINSVO) VFILES := $(ALLVO:.$(VO)=.v) -- cgit v1.2.3 From 8bb85530fbf5b6de1cb268004611c6f76fb5871e Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 7 May 2019 15:09:26 +0200 Subject: Avoid trivial (u=u) constraints in AcyclicGraph.constraints_for Not sure how often this happens in practice but it seems it could. --- lib/acyclicGraph.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml index 7d04c8f5a1..e1dcfcc6ce 100644 --- a/lib/acyclicGraph.ml +++ b/lib/acyclicGraph.ml @@ -721,7 +721,10 @@ module Make (Point:Point) = struct let rmap, csts = PSet.fold (fun u (rmap,csts) -> let arcu = repr g u in if PSet.mem arcu.canon kept then - PMap.add arcu.canon arcu.canon rmap, Constraint.add (u,Eq,arcu.canon) csts + let csts = if Point.equal u arcu.canon then csts + else Constraint.add (u,Eq,arcu.canon) csts + in + PMap.add arcu.canon arcu.canon rmap, csts else match PMap.find arcu.canon rmap with | v -> rmap, Constraint.add (u,Eq,v) csts -- cgit v1.2.3 From 94f3caa81cf2f681b66da9f3f69a9d8b881303e1 Mon Sep 17 00:00:00 2001 From: thery Date: Thu, 28 Mar 2019 15:19:09 +0100 Subject: Improve field_simplify on fractions with constant denominator Before this patch, `x` was "simplified" to `x / 1`. --- plugins/setoid_ring/Field_theory.v | 41 ++++++++++++++++++++++++++++++++------ theories/Reals/Ratan.v | 3 --- 2 files changed, 35 insertions(+), 9 deletions(-) diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 813c521ab0..ad2ee821b3 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1235,12 +1235,19 @@ Notation ring_correct := (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). (* simplify a field expression into a fraction *) -(* TODO: simplify when den is constant... *) Definition display_linear l num den := - NPphi_dev l num / NPphi_dev l den. + let lnum := NPphi_dev l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_dev l den + | _ => lnum / NPphi_dev l den + end. Definition display_pow_linear l num den := - NPphi_pow l num / NPphi_pow l den. + let lnum := NPphi_pow l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_pow l den + | _ => lnum / NPphi_pow l den + end. Theorem Field_rw_correct n lpe l : Ninterp_PElist l lpe -> @@ -1252,7 +1259,18 @@ Theorem Field_rw_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_linear; apply rdiv_ext; + unfold display_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_dev _ _). + apply eq_trans with (nnum / NPphi_dev l (Pc c)). + apply rdiv_ext; + eapply ring_rw_correct; eauto. + rewrite Pphi_dev_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; eapply ring_rw_correct; eauto. Qed. @@ -1266,8 +1284,19 @@ Theorem Field_rw_pow_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear; apply rdiv_ext; - eapply ring_rw_pow_correct;eauto. + unfold display_pow_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_pow_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_pow _ _). + apply eq_trans with (nnum / NPphi_pow l (Pc c)). + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. + rewrite Pphi_pow_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. Qed. Theorem Field_correct n l lpe fe1 fe2 : diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index 03e6ff61ab..38bed570a3 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -324,8 +324,6 @@ unfold cos_approx; simpl; unfold cos_term. rewrite !INR_IZR_INZ. simpl. field_simplify. -unfold Rdiv. -rewrite Rmult_0_l. apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. @@ -1612,4 +1610,3 @@ Lemma PI_ineq : Proof. intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. Qed. - -- cgit v1.2.3 From 1ec731fbef3ac13b7a8783461b8fa6609f962054 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 3 May 2019 09:57:06 +0000 Subject: [Test-suite] Add output case for issue #9370 --- test-suite/output/bug_9370.out | 12 ++++++++++++ test-suite/output/bug_9370.v | 12 ++++++++++++ 2 files changed, 24 insertions(+) create mode 100644 test-suite/output/bug_9370.out create mode 100644 test-suite/output/bug_9370.v diff --git a/test-suite/output/bug_9370.out b/test-suite/output/bug_9370.out new file mode 100644 index 0000000000..0ff151c8b4 --- /dev/null +++ b/test-suite/output/bug_9370.out @@ -0,0 +1,12 @@ +1 subgoal + + ============================ + 1 = 1 +1 subgoal + + ============================ + 1 = 1 +1 subgoal + + ============================ + 1 = 1 diff --git a/test-suite/output/bug_9370.v b/test-suite/output/bug_9370.v new file mode 100644 index 0000000000..a7f4b7c23e --- /dev/null +++ b/test-suite/output/bug_9370.v @@ -0,0 +1,12 @@ +Require Import Reals. +Open Scope R_scope. +Goal 1/1=1. +Proof. + field_simplify (1/1). +Show. + field_simplify. +Show. + field_simplify. +Show. + reflexivity. +Qed. -- cgit v1.2.3 From b50bd0f9fd2fedb7dd14edd39baabf2fc3be8e3b Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 3 May 2019 10:06:29 +0000 Subject: Add overlays for CompCert, VST, and coquelicot --- dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh diff --git a/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh b/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh new file mode 100644 index 0000000000..88f5f73e5f --- /dev/null +++ b/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "9854" ] || [ "$CI_BRANCH" = "field_simplify_int" ]; then + + compcert_CI_REF=field_simplify_int + compcert_CI_GITURL=https://github.com/vbgl/CompCert + + coquelicot_CI_REF=field_simplify_int + coquelicot_CI_GITURL=https://gitlab.com/vbgl/coquelicot + + vst_CI_REF=field_simplify_int + vst_CI_GITURL=https://github.com/vbgl/VST + +fi -- cgit v1.2.3 From 782312a65310dc717d830b3e8e5a7ba54b4cfb6e Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 3 May 2019 12:00:34 +0000 Subject: [nix-ci] Add coquelicot, improve flocq --- dev/ci/nix/coquelicot.nix | 9 +++++++++ dev/ci/nix/default.nix | 1 + dev/ci/nix/flocq.nix | 1 + 3 files changed, 11 insertions(+) create mode 100644 dev/ci/nix/coquelicot.nix diff --git a/dev/ci/nix/coquelicot.nix b/dev/ci/nix/coquelicot.nix new file mode 100644 index 0000000000..d379bfa73d --- /dev/null +++ b/dev/ci/nix/coquelicot.nix @@ -0,0 +1,9 @@ +{ autoconf, automake, ssreflect }: + +{ + buildInputs = [ autoconf automake ]; + coqBuildInputs = [ ssreflect ]; + configure = "./autogen.sh && ./configure"; + make = "./remake"; + clean = "./remake clean"; +} diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 17070e66ee..a9cc91170f 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -72,6 +72,7 @@ let projects = { CoLoR = callPackage ./CoLoR.nix {}; CompCert = callPackage ./CompCert.nix {}; coq_dpdgraph = callPackage ./coq_dpdgraph.nix {}; + coquelicot = callPackage ./coquelicot.nix {}; Corn = callPackage ./Corn.nix {}; cross_crypto = callPackage ./cross_crypto.nix {}; Elpi = callPackage ./Elpi.nix {}; diff --git a/dev/ci/nix/flocq.nix b/dev/ci/nix/flocq.nix index e153043557..71028ec2dc 100644 --- a/dev/ci/nix/flocq.nix +++ b/dev/ci/nix/flocq.nix @@ -4,4 +4,5 @@ buildInputs = [ autoconf automake ]; configure = "./autogen.sh && ./configure"; make = "./remake"; + clean = "./remake clean"; } -- cgit v1.2.3 From 5d426eecb6c7f2e956cde98780aef349fdc75af0 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 7 May 2019 14:17:50 +0000 Subject: Remove overlays for CompCert and VST --- dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh | 6 ------ 1 file changed, 6 deletions(-) diff --git a/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh b/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh index 88f5f73e5f..720adbc979 100644 --- a/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh +++ b/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh @@ -1,12 +1,6 @@ if [ "$CI_PULL_REQUEST" = "9854" ] || [ "$CI_BRANCH" = "field_simplify_int" ]; then - compcert_CI_REF=field_simplify_int - compcert_CI_GITURL=https://github.com/vbgl/CompCert - coquelicot_CI_REF=field_simplify_int coquelicot_CI_GITURL=https://gitlab.com/vbgl/coquelicot - vst_CI_REF=field_simplify_int - vst_CI_GITURL=https://github.com/vbgl/VST - fi -- cgit v1.2.3 From b474e39c2c21122de64a76e087508770763250f1 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 7 May 2019 18:27:20 +0200 Subject: Fix gitignore for ltac2 --- .gitignore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 8fd9fc614c..5264968e95 100644 --- a/.gitignore +++ b/.gitignore @@ -165,7 +165,8 @@ ide/index_urls.txt # coqide generated files (when testing) *.crashcoqide -user-contrib +/user-contrib/* +!/user-contrib/Ltac2 .*.sw* .#* -- cgit v1.2.3 From f958d281ab57acfb37e69bbe92ed603d87962ce6 Mon Sep 17 00:00:00 2001 From: Robert Rand Date: Tue, 7 May 2019 12:44:09 -0400 Subject: Added description of Q Note that this description is identical to that of R. R should maybe start with the word "Recursively"?--- doc/sphinx/practical-tools/utilities.rst | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 35231610fe..f799091af3 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -911,11 +911,13 @@ Command line options Coq``. :-R dir coqdir: Map physical directory dir to |Coq| logical directory ``coqdir`` (similarly to |Coq| option ``-R``). + :-Q dir coqdir: Map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-Q``). .. note:: - option ``-R`` only has - effect on the files *following* it on the command line, so you will + options ``-R`` and ``-Q`` only have + effect on the files *following* them on the command line, so you will probably need to put this option first. -- cgit v1.2.3 From 8f7559931d79588328049586b389d4109c59a9d2 Mon Sep 17 00:00:00 2001 From: Robert Rand Date: Tue, 7 May 2019 13:05:19 -0400 Subject: Added "Recursively" for the R option --- doc/sphinx/practical-tools/utilities.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index f799091af3..554f6bf230 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -909,7 +909,7 @@ Command line options :--coqlib url: Set base URL for the Coq standard library (default is ``_). This is equivalent to ``--external url Coq``. - :-R dir coqdir: Map physical directory dir to |Coq| logical + :-R dir coqdir: Recursively map physical directory dir to |Coq| logical directory ``coqdir`` (similarly to |Coq| option ``-R``). :-Q dir coqdir: Map physical directory dir to |Coq| logical directory ``coqdir`` (similarly to |Coq| option ``-Q``). -- cgit v1.2.3 From 21e5a5d510de59a33f3e6a0f88b8321ac0d7d23d Mon Sep 17 00:00:00 2001 From: Jim Fehrle Date: Tue, 7 May 2019 12:04:34 -0700 Subject: Show diffs in error messages only if Diffs is enabled --- test-suite/output/Error_msg_diffs.v | 2 +- vernac/himsg.ml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/output/Error_msg_diffs.v b/test-suite/output/Error_msg_diffs.v index 11c766b210..a26e683398 100644 --- a/test-suite/output/Error_msg_diffs.v +++ b/test-suite/output/Error_msg_diffs.v @@ -1,4 +1,4 @@ -(* coq-prog-args: ("-color" "on" "-async-proofs" "off") *) +(* coq-prog-args: ("-color" "on" "-diffs" "on" "-async-proofs" "off") *) (* Re: -async-proofs off, see https://github.com/coq/coq/issues/9671 *) (* Shows diffs in an error message for an "Unable to unify" error *) Require Import Arith List Bool. diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 082b22b373..f58eeae6dc 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -150,6 +150,7 @@ let explicit_flags = [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] let with_diffs pm pn = + if not (Proof_diffs.show_diffs ()) then pm, pn else try let tokenize_string = Proof_diffs.tokenize_string in Pp_diff.diff_pp ~tokenize_string pm pn -- cgit v1.2.3 From df8e45d9bd3908278254e769839ddc98d5057ee5 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 8 May 2019 20:35:58 +0200 Subject: Clean-up: remove dead appveyor.sh file. --- dev/ci/appveyor.sh | 17 ----------------- 1 file changed, 17 deletions(-) delete mode 100644 dev/ci/appveyor.sh diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh deleted file mode 100644 index f26e0904bc..0000000000 --- a/dev/ci/appveyor.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/bash - -set -e -x - -APPVEYOR_OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c -NJOBS=2 - -wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz -tar -xf opam64.tar.xz -bash opam64/install.sh - -opam init default -j $NJOBS -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $APPVEYOR_OPAM_VARIANT --disable-sandboxing -eval "$(opam env)" -opam install -j $NJOBS -y num ocamlfind ounit - -# Full regular Coq Build -cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make -j $NJOBS && make byte -j $NJOBS && make -j $NJOBS -C test-suite all INTERACTIVE= # && make validate -- cgit v1.2.3 From 053e64206aa70c6a12c75b59e8267eeaba00d1ce Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 8 May 2019 20:40:19 +0200 Subject: Remove ltac2 add-on from Windows installer now that it is in the main Coq package. --- dev/build/windows/makecoq_mingw.sh | 13 ------------- dev/ci/gitlab.bat | 1 - 2 files changed, 14 deletions(-) diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index ea9af60330..d737632638 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1630,19 +1630,6 @@ function make_addon_ssreflect { fi } -# Ltac-2 plugin -# A new (experimental) tactic language - -function make_addon_ltac2 { - installer_addon_dependency ltac2 - if build_prep_overlay ltac2; then - installer_addon_section ltac2 "Ltac-2" "Coq plugin with the Ltac-2 enhanced tactic language" "" - log1 make $MAKE_OPT all - log2 make install - build_post - fi -} - # UniCoq plugin # An alternative unification algorithm function make_addon_unicoq { diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index cc1931d13d..6c4ccfc14d 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -41,7 +41,6 @@ IF "%WINDOWS%" == "enabled_all_addons" ( SET EXTRA_ADDONS=^ -addon=bignums ^ -addon=equations ^ - -addon=ltac2 ^ -addon=mtac2 ^ -addon=mathcomp ^ -addon=menhir ^ -- cgit v1.2.3 From 50a89e6882e319cf6107147b49d387dd41e81805 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 8 May 2019 20:50:36 +0200 Subject: Define a new `is_a_released_version` variable in configure.ml. Use it to not include unreleased changes when building a released version. --- configure.ml | 5 +++-- doc/sphinx/changes.rst | 4 +++- doc/sphinx/conf.py | 2 ++ 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/configure.ml b/configure.ml index 5b99851f83..57f31fec4c 100644 --- a/configure.ml +++ b/configure.ml @@ -17,6 +17,7 @@ let coq_macos_version = "8.9.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) let vo_magic = 8991 let state_magic = 58991 +let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] @@ -1205,8 +1206,8 @@ let write_configpy f = safe_remove f; let o = open_out f in let pr s = fprintf o s in - let pr_s = pr "%s = '%s'\n" in pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure\n"; - pr_s "version" coq_version + pr "version = '%s'\n" coq_version; + pr "is_a_released_version = %s\n" (if is_a_released_version then "True" else "False") let _ = write_configpy "config/coq_config.py" diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 5704587ae0..574b943a78 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -2,7 +2,9 @@ Recent changes -------------- -.. include:: ../unreleased.rst +.. ifconfig:: not coq_config.is_a_released_version + + .. include:: ../unreleased.rst Version 8.10 ------------ diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 48ad60c6dd..25800d3a7d 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -53,6 +53,7 @@ with open("refman-preamble.rst") as s: # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom # ones. extensions = [ + 'sphinx.ext.ifconfig', 'sphinx.ext.mathjax', 'sphinx.ext.todo', 'sphinxcontrib.bibtex', @@ -100,6 +101,7 @@ def copy_formatspecific_files(app): def setup(app): app.connect('builder-inited', copy_formatspecific_files) + app.add_config_value('coq_config', coq_config, 'env') # The master toctree document. # We create this file in `copy_master_doc` above. -- cgit v1.2.3 From 963b950f201614078a432d1ac7568e8757d8df19 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 8 May 2019 20:51:31 +0200 Subject: Add a test that unreleased changelog of released versions is empty. This test is active only when configure `is_a_released_version` is set to true. In this case, to pass the test-suite, there must be no unreleased changelog entries left, i.e. `doc/changelog/*/` must only contain `00000-title.rst` files. --- test-suite/dune | 2 ++ test-suite/misc/changelog.sh | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+) create mode 100755 test-suite/misc/changelog.sh diff --git a/test-suite/dune b/test-suite/dune index c430400ba5..cd33319fa4 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -20,6 +20,8 @@ ../dev/header.ml ../dev/tools/update-compat.py ../doc/stdlib/index-list.html.template + ; For the changelog test + ../config/coq_config.py (package coq) ; For fake_ide (package coqide-server) diff --git a/test-suite/misc/changelog.sh b/test-suite/misc/changelog.sh new file mode 100755 index 0000000000..8b4a49e577 --- /dev/null +++ b/test-suite/misc/changelog.sh @@ -0,0 +1,18 @@ +#!/bin/sh + +while read line; do + if [ "$line" = "is_a_released_version = False" ]; then + echo "This is not a released version: nothing to test." + exit 0 + fi +done < ../config/coq_config.py + +for d in ../doc/changelog/*; do + if [ -d "$d" ]; then + if [ "$(ls $d/*.rst | wc -l)" != "1" ]; then + echo "Fatal: unreleased changelog entries remain in ${d#../}/" + echo "Include them in doc/sphinx/changes.rst and remove them from doc/changelog/" + exit 1 + fi + fi +done -- cgit v1.2.3 From 60e976a627b213445443952342a8eec7193d9b85 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Wed, 8 May 2019 20:57:12 +0200 Subject: Update release process documentation and changelog entry. --- dev/doc/release-process.md | 22 +++++++++++++++++++--- doc/changelog/12-misc/09964-changes.rst | 5 +++-- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 60c0886896..189d6f9fa5 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -84,10 +84,18 @@ Coq has been tagged. - [ ] Have some people test the recently auto-generated Windows and MacOS packages. -- [ ] Change the version name from alpha to beta1 (see +- [ ] In a PR: + - Change the version name from alpha to beta1 (see [#7009](https://github.com/coq/coq/pull/7009/files)). - We generally do not update the magic numbers at this point. + - We generally do not update the magic numbers at this point. + - Set `is_a_released_version` to `true` in `configure.ml`. - [ ] Put the `VX.X+beta1` tag using `git tag -s`. +- [ ] Check using `git push --tags --dry-run` that you are not + pushing anything else than the new tag. If needed, remove spurious + tags with `git tag -d`. When this is OK, proceed with `git push --tags`. +- [ ] Set `is_a_released_version` to `false` in `configure.ml` + (if you forget about it, you'll be reminded whenever you try to + backport a PR with a changelog entry). ### These steps are the same for all releases (beta, final, patch-level) ### @@ -112,9 +120,17 @@ ## At the final release time ## -- [ ] Change the version name to X.X.0 and the magic numbers (see +- [ ] In a PR: + - Change the version name from X.X.0 and the magic numbers (see [#7271](https://github.com/coq/coq/pull/7271/files)). + - Set `is_a_released_version` to `true` in `configure.ml`. - [ ] Put the `VX.X.0` tag. +- [ ] Check using `git push --tags --dry-run` that you are not + pushing anything else than the new tag. If needed, remove spurious + tags with `git tag -d`. When this is OK, proceed with `git push --tags`. +- [ ] Set `is_a_released_version` to `false` in `configure.ml` + (if you forget about it, you'll be reminded whenever you try to + backport a PR with a changelog entry). Repeat the generic process documented above for all releases. diff --git a/doc/changelog/12-misc/09964-changes.rst b/doc/changelog/12-misc/09964-changes.rst index 1113782180..dd873cfdd5 100644 --- a/doc/changelog/12-misc/09964-changes.rst +++ b/doc/changelog/12-misc/09964-changes.rst @@ -8,6 +8,7 @@ `#9668 `_, `#9939 `_, `#9964 `_, + and `#10085 `_, by Théo Zimmermann, - with help and ideas from Emilio Jesús Gallego Arias, - Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). + with help and ideas from Emilio Jesús Gallego Arias, Gaëtan + Gilbert, Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). -- cgit v1.2.3 From d3a33d5d5177d301d0fbae08fde7e82be2bf3351 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Tue, 7 May 2019 14:27:30 +0200 Subject: [refman] Move all the Ltac examples to the Ltac chapter. The Detailed examples of tactics chapter can be removed when the remaining examples are moved closer to the definitions of the corresponding tactics. This commit also moves back the footnotes from the Tactics chapter at the end of the chapter, and removes an old footnote that doesn't matter anymore. --- .../proof-engine/detailed-tactic-examples.rst | 378 ------------------- doc/sphinx/proof-engine/ltac.rst | 407 ++++++++++++++++++++- doc/sphinx/proof-engine/tactics.rst | 53 +-- 3 files changed, 414 insertions(+), 424 deletions(-) diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index b629d15b11..0ace9ef5b9 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -396,381 +396,3 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: none Qed. - -Using the tactic language -------------------------- - - -About the cardinality of the set of natural numbers -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The first example which shows how to use pattern matching over the -proof context is a proof of the fact that natural numbers have more -than two elements. This can be done as follows: - -.. coqtop:: in reset - - Lemma card_nat : - ~ exists x : nat, exists y : nat, forall z:nat, x = z \/ y = z. - Proof. - -.. coqtop:: in - - red; intros (x, (y, Hy)). - -.. coqtop:: in - - elim (Hy 0); elim (Hy 1); elim (Hy 2); intros; - - match goal with - | _ : ?a = ?b, _ : ?a = ?c |- _ => - cut (b = c); [ discriminate | transitivity a; auto ] - end. - -.. coqtop:: in - - Qed. - -We can notice that all the (very similar) cases coming from the three -eliminations (with three distinct natural numbers) are successfully -solved by a match goal structure and, in particular, with only one -pattern (use of non-linear matching). - - -Permutations of lists -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A more complex example is the problem of permutations of -lists. The aim is to show that a list is a permutation of -another list. - -.. coqtop:: in reset - - Section Sort. - -.. coqtop:: in - - Variable A : Set. - -.. coqtop:: in - - Inductive perm : list A -> list A -> Prop := - | perm_refl : forall l, perm l l - | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) - | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) - | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. - -.. coqtop:: in - - End Sort. - -First, we define the permutation predicate as shown above. - -.. coqtop:: none - - Require Import List. - - -.. coqtop:: in - - Ltac perm_aux n := - match goal with - | |- (perm _ ?l ?l) => apply perm_refl - | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => - let newn := eval compute in (length l1) in - (apply perm_cons; perm_aux newn) - | |- (perm ?A (?a :: ?l1) ?l2) => - match eval compute in n with - | 1 => fail - | _ => - let l1' := constr:(l1 ++ a :: nil) in - (apply (perm_trans A (a :: l1) l1' l2); - [ apply perm_append | compute; perm_aux (pred n) ]) - end - end. - -Next we define an auxiliary tactic ``perm_aux`` which takes an argument -used to control the recursion depth. This tactic behaves as follows. If -the lists are identical (i.e. convertible), it concludes. Otherwise, if -the lists have identical heads, it proceeds to look at their tails. -Finally, if the lists have different heads, it rotates the first list by -putting its head at the end if the new head hasn't been the head previously. To check this, we keep track of the -number of performed rotations using the argument ``n``. We do this by -decrementing ``n`` each time we perform a rotation. It works because -for a list of length ``n`` we can make exactly ``n - 1`` rotations -to generate at most ``n`` distinct lists. Notice that we use the natural -numbers of Coq for the rotation counter. From :ref:`ltac-syntax` we know -that it is possible to use the usual natural numbers, but they are only -used as arguments for primitive tactics and they cannot be handled, so, -in particular, we cannot make computations with them. Thus the natural -choice is to use Coq data structures so that Coq makes the computations -(reductions) by ``eval compute in`` and we can get the terms back by match. - -.. coqtop:: in - - Ltac solve_perm := - match goal with - | |- (perm _ ?l1 ?l2) => - match eval compute in (length l1 = length l2) with - | (?n = ?n) => perm_aux n - end - end. - -The main tactic is ``solve_perm``. It computes the lengths of the two lists -and uses them as arguments to call ``perm_aux`` if the lengths are equal (if they -aren't, the lists cannot be permutations of each other). Using this tactic we -can now prove lemmas as follows: - -.. coqtop:: in - - Lemma solve_perm_ex1 : - perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). - Proof. solve_perm. Qed. - -.. coqtop:: in - - Lemma solve_perm_ex2 : - perm nat - (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) - (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). - Proof. solve_perm. Qed. - -Deciding intuitionistic propositional logic -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Pattern matching on goals allows a powerful backtracking when returning tactic -values. An interesting application is the problem of deciding intuitionistic -propositional logic. Considering the contraction-free sequent calculi LJT* of -Roy Dyckhoff :cite:`Dyc92`, it is quite natural to code such a tactic using the -tactic language as shown below. - -.. coqtop:: in reset - - Ltac basic := - match goal with - | |- True => trivial - | _ : False |- _ => contradiction - | _ : ?A |- ?A => assumption - end. - -.. coqtop:: in - - Ltac simplify := - repeat (intros; - match goal with - | H : ~ _ |- _ => red in H - | H : _ /\ _ |- _ => - elim H; do 2 intro; clear H - | H : _ \/ _ |- _ => - elim H; intro; clear H - | H : ?A /\ ?B -> ?C |- _ => - cut (A -> B -> C); - [ intro | intros; apply H; split; assumption ] - | H: ?A \/ ?B -> ?C |- _ => - cut (B -> C); - [ cut (A -> C); - [ intros; clear H - | intro; apply H; left; assumption ] - | intro; apply H; right; assumption ] - | H0 : ?A -> ?B, H1 : ?A |- _ => - cut B; [ intro; clear H0 | apply H0; assumption ] - | |- _ /\ _ => split - | |- ~ _ => red - end). - -.. coqtop:: in - - Ltac my_tauto := - simplify; basic || - match goal with - | H : (?A -> ?B) -> ?C |- _ => - cut (B -> C); - [ intro; cut (A -> B); - [ intro; cut C; - [ intro; clear H | apply H; assumption ] - | clear H ] - | intro; apply H; intro; assumption ]; my_tauto - | H : ~ ?A -> ?B |- _ => - cut (False -> B); - [ intro; cut (A -> False); - [ intro; cut B; - [ intro; clear H | apply H; assumption ] - | clear H ] - | intro; apply H; red; intro; assumption ]; my_tauto - | |- _ \/ _ => (left; my_tauto) || (right; my_tauto) - end. - -The tactic ``basic`` tries to reason using simple rules involving truth, falsity -and available assumptions. The tactic ``simplify`` applies all the reversible -rules of Dyckhoff’s system. Finally, the tactic ``my_tauto`` (the main -tactic to be called) simplifies with ``simplify``, tries to conclude with -``basic`` and tries several paths using the backtracking rules (one of the -four Dyckhoff’s rules for the left implication to get rid of the contraction -and the right ``or``). - -Having defined ``my_tauto``, we can prove tautologies like these: - -.. coqtop:: in - - Lemma my_tauto_ex1 : - forall A B : Prop, A /\ B -> A \/ B. - Proof. my_tauto. Qed. - -.. coqtop:: in - - Lemma my_tauto_ex2 : - forall A B : Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. - Proof. my_tauto. Qed. - - -Deciding type isomorphisms -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A more tricky problem is to decide equalities between types modulo -isomorphisms. Here, we choose to use the isomorphisms of the simply -typed λ-calculus with Cartesian product and unit type (see, for -example, :cite:`RC95`). The axioms of this λ-calculus are given below. - -.. coqtop:: in reset - - Open Scope type_scope. - -.. coqtop:: in - - Section Iso_axioms. - -.. coqtop:: in - - Variables A B C : Set. - -.. coqtop:: in - - Axiom Com : A * B = B * A. - - Axiom Ass : A * (B * C) = A * B * C. - - Axiom Cur : (A * B -> C) = (A -> B -> C). - - Axiom Dis : (A -> B * C) = (A -> B) * (A -> C). - - Axiom P_unit : A * unit = A. - - Axiom AR_unit : (A -> unit) = unit. - - Axiom AL_unit : (unit -> A) = A. - -.. coqtop:: in - - Lemma Cons : B = C -> A * B = A * C. - - Proof. - - intro Heq; rewrite Heq; reflexivity. - - Qed. - -.. coqtop:: in - - End Iso_axioms. - -.. coqtop:: in - - Ltac simplify_type ty := - match ty with - | ?A * ?B * ?C => - rewrite <- (Ass A B C); try simplify_type_eq - | ?A * ?B -> ?C => - rewrite (Cur A B C); try simplify_type_eq - | ?A -> ?B * ?C => - rewrite (Dis A B C); try simplify_type_eq - | ?A * unit => - rewrite (P_unit A); try simplify_type_eq - | unit * ?B => - rewrite (Com unit B); try simplify_type_eq - | ?A -> unit => - rewrite (AR_unit A); try simplify_type_eq - | unit -> ?B => - rewrite (AL_unit B); try simplify_type_eq - | ?A * ?B => - (simplify_type A; try simplify_type_eq) || - (simplify_type B; try simplify_type_eq) - | ?A -> ?B => - (simplify_type A; try simplify_type_eq) || - (simplify_type B; try simplify_type_eq) - end - with simplify_type_eq := - match goal with - | |- ?A = ?B => try simplify_type A; try simplify_type B - end. - -.. coqtop:: in - - Ltac len trm := - match trm with - | _ * ?B => let succ := len B in constr:(S succ) - | _ => constr:(1) - end. - -.. coqtop:: in - - Ltac assoc := repeat rewrite <- Ass. - -.. coqtop:: in - - Ltac solve_type_eq n := - match goal with - | |- ?A = ?A => reflexivity - | |- ?A * ?B = ?A * ?C => - apply Cons; let newn := len B in solve_type_eq newn - | |- ?A * ?B = ?C => - match eval compute in n with - | 1 => fail - | _ => - pattern (A * B) at 1; rewrite Com; assoc; solve_type_eq (pred n) - end - end. - -.. coqtop:: in - - Ltac compare_structure := - match goal with - | |- ?A = ?B => - let l1 := len A - with l2 := len B in - match eval compute in (l1 = l2) with - | ?n = ?n => solve_type_eq n - end - end. - -.. coqtop:: in - - Ltac solve_iso := simplify_type_eq; compare_structure. - -The tactic to judge equalities modulo this axiomatization is shown above. -The algorithm is quite simple. First types are simplified using axioms that -can be oriented (this is done by ``simplify_type`` and ``simplify_type_eq``). -The normal forms are sequences of Cartesian products without Cartesian product -in the left component. These normal forms are then compared modulo permutation -of the components by the tactic ``compare_structure``. If they have the same -lengths, the tactic ``solve_type_eq`` attempts to prove that the types are equal. -The main tactic that puts all these components together is called ``solve_iso``. - -Here are examples of what can be solved by ``solve_iso``. - -.. coqtop:: in - - Lemma solve_iso_ex1 : - forall A B : Set, A * unit * B = B * (unit * A). - Proof. - intros; solve_iso. - Qed. - -.. coqtop:: in - - Lemma solve_iso_ex2 : - forall A B C : Set, - (A * unit -> B * (C * unit)) = - (A * unit -> (C -> unit) * C) * (unit -> A -> B). - Proof. - intros; solve_iso. - Qed. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index d3562b52c5..d35e4ab782 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -3,12 +3,25 @@ Ltac ==== -This chapter gives a compact documentation of |Ltac|, the tactic language -available in |Coq|. We start by giving the syntax, and next, we present the -informal semantics. If you want to know more regarding this language and -especially about its foundations, you can refer to :cite:`Del00`. Chapter -:ref:`detailedexamplesoftactics` is devoted to giving small but nontrivial -use examples of this language. +This chapter documents the tactic language |Ltac|. + +We start by giving the syntax, and next, we present the informal +semantics. If you want to know more regarding this language and +especially about its foundations, you can refer to :cite:`Del00`. + +.. example:: + + Here are some examples of the kind of tactic macros that this + language allows to write. + + .. coqdoc:: + + Ltac reduce_and_try_to_solve := simpl; intros; auto. + + Ltac destruct_bool_and_rewrite b H1 H2 := + destruct b; [ rewrite H1; eauto | rewrite H2; eauto ]. + + Some more advanced examples are given in Section :ref:`ltac-examples`. .. _ltac-syntax: @@ -1160,6 +1173,388 @@ Printing |Ltac| tactics This command displays a list of all user-defined tactics, with their arguments. + +.. _ltac-examples: + +Examples of using |Ltac| +------------------------- + + +About the cardinality of the set of natural numbers +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The first example which shows how to use pattern matching over the +proof context is a proof of the fact that natural numbers have more +than two elements. This can be done as follows: + +.. coqtop:: in reset + + Lemma card_nat : + ~ exists x : nat, exists y : nat, forall z:nat, x = z \/ y = z. + Proof. + +.. coqtop:: in + + red; intros (x, (y, Hy)). + +.. coqtop:: in + + elim (Hy 0); elim (Hy 1); elim (Hy 2); intros; + + match goal with + | _ : ?a = ?b, _ : ?a = ?c |- _ => + cut (b = c); [ discriminate | transitivity a; auto ] + end. + +.. coqtop:: in + + Qed. + +We can notice that all the (very similar) cases coming from the three +eliminations (with three distinct natural numbers) are successfully +solved by a match goal structure and, in particular, with only one +pattern (use of non-linear matching). + + +Permutations of lists +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A more complex example is the problem of permutations of +lists. The aim is to show that a list is a permutation of +another list. + +.. coqtop:: in reset + + Section Sort. + +.. coqtop:: in + + Variable A : Set. + +.. coqtop:: in + + Inductive perm : list A -> list A -> Prop := + | perm_refl : forall l, perm l l + | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) + | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) + | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. + +.. coqtop:: in + + End Sort. + +First, we define the permutation predicate as shown above. + +.. coqtop:: none + + Require Import List. + + +.. coqtop:: in + + Ltac perm_aux n := + match goal with + | |- (perm _ ?l ?l) => apply perm_refl + | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => + let newn := eval compute in (length l1) in + (apply perm_cons; perm_aux newn) + | |- (perm ?A (?a :: ?l1) ?l2) => + match eval compute in n with + | 1 => fail + | _ => + let l1' := constr:(l1 ++ a :: nil) in + (apply (perm_trans A (a :: l1) l1' l2); + [ apply perm_append | compute; perm_aux (pred n) ]) + end + end. + +Next we define an auxiliary tactic ``perm_aux`` which takes an argument +used to control the recursion depth. This tactic behaves as follows. If +the lists are identical (i.e. convertible), it concludes. Otherwise, if +the lists have identical heads, it proceeds to look at their tails. +Finally, if the lists have different heads, it rotates the first list by +putting its head at the end if the new head hasn't been the head previously. To check this, we keep track of the +number of performed rotations using the argument ``n``. We do this by +decrementing ``n`` each time we perform a rotation. It works because +for a list of length ``n`` we can make exactly ``n - 1`` rotations +to generate at most ``n`` distinct lists. Notice that we use the natural +numbers of Coq for the rotation counter. From :ref:`ltac-syntax` we know +that it is possible to use the usual natural numbers, but they are only +used as arguments for primitive tactics and they cannot be handled, so, +in particular, we cannot make computations with them. Thus the natural +choice is to use Coq data structures so that Coq makes the computations +(reductions) by ``eval compute in`` and we can get the terms back by match. + +.. coqtop:: in + + Ltac solve_perm := + match goal with + | |- (perm _ ?l1 ?l2) => + match eval compute in (length l1 = length l2) with + | (?n = ?n) => perm_aux n + end + end. + +The main tactic is ``solve_perm``. It computes the lengths of the two lists +and uses them as arguments to call ``perm_aux`` if the lengths are equal (if they +aren't, the lists cannot be permutations of each other). Using this tactic we +can now prove lemmas as follows: + +.. coqtop:: in + + Lemma solve_perm_ex1 : + perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). + Proof. solve_perm. Qed. + +.. coqtop:: in + + Lemma solve_perm_ex2 : + perm nat + (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) + (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). + Proof. solve_perm. Qed. + +Deciding intuitionistic propositional logic +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Pattern matching on goals allows a powerful backtracking when returning tactic +values. An interesting application is the problem of deciding intuitionistic +propositional logic. Considering the contraction-free sequent calculi LJT* of +Roy Dyckhoff :cite:`Dyc92`, it is quite natural to code such a tactic using the +tactic language as shown below. + +.. coqtop:: in reset + + Ltac basic := + match goal with + | |- True => trivial + | _ : False |- _ => contradiction + | _ : ?A |- ?A => assumption + end. + +.. coqtop:: in + + Ltac simplify := + repeat (intros; + match goal with + | H : ~ _ |- _ => red in H + | H : _ /\ _ |- _ => + elim H; do 2 intro; clear H + | H : _ \/ _ |- _ => + elim H; intro; clear H + | H : ?A /\ ?B -> ?C |- _ => + cut (A -> B -> C); + [ intro | intros; apply H; split; assumption ] + | H: ?A \/ ?B -> ?C |- _ => + cut (B -> C); + [ cut (A -> C); + [ intros; clear H + | intro; apply H; left; assumption ] + | intro; apply H; right; assumption ] + | H0 : ?A -> ?B, H1 : ?A |- _ => + cut B; [ intro; clear H0 | apply H0; assumption ] + | |- _ /\ _ => split + | |- ~ _ => red + end). + +.. coqtop:: in + + Ltac my_tauto := + simplify; basic || + match goal with + | H : (?A -> ?B) -> ?C |- _ => + cut (B -> C); + [ intro; cut (A -> B); + [ intro; cut C; + [ intro; clear H | apply H; assumption ] + | clear H ] + | intro; apply H; intro; assumption ]; my_tauto + | H : ~ ?A -> ?B |- _ => + cut (False -> B); + [ intro; cut (A -> False); + [ intro; cut B; + [ intro; clear H | apply H; assumption ] + | clear H ] + | intro; apply H; red; intro; assumption ]; my_tauto + | |- _ \/ _ => (left; my_tauto) || (right; my_tauto) + end. + +The tactic ``basic`` tries to reason using simple rules involving truth, falsity +and available assumptions. The tactic ``simplify`` applies all the reversible +rules of Dyckhoff’s system. Finally, the tactic ``my_tauto`` (the main +tactic to be called) simplifies with ``simplify``, tries to conclude with +``basic`` and tries several paths using the backtracking rules (one of the +four Dyckhoff’s rules for the left implication to get rid of the contraction +and the right ``or``). + +Having defined ``my_tauto``, we can prove tautologies like these: + +.. coqtop:: in + + Lemma my_tauto_ex1 : + forall A B : Prop, A /\ B -> A \/ B. + Proof. my_tauto. Qed. + +.. coqtop:: in + + Lemma my_tauto_ex2 : + forall A B : Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. + Proof. my_tauto. Qed. + + +Deciding type isomorphisms +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A more tricky problem is to decide equalities between types modulo +isomorphisms. Here, we choose to use the isomorphisms of the simply +typed λ-calculus with Cartesian product and unit type (see, for +example, :cite:`RC95`). The axioms of this λ-calculus are given below. + +.. coqtop:: in reset + + Open Scope type_scope. + +.. coqtop:: in + + Section Iso_axioms. + +.. coqtop:: in + + Variables A B C : Set. + +.. coqtop:: in + + Axiom Com : A * B = B * A. + + Axiom Ass : A * (B * C) = A * B * C. + + Axiom Cur : (A * B -> C) = (A -> B -> C). + + Axiom Dis : (A -> B * C) = (A -> B) * (A -> C). + + Axiom P_unit : A * unit = A. + + Axiom AR_unit : (A -> unit) = unit. + + Axiom AL_unit : (unit -> A) = A. + +.. coqtop:: in + + Lemma Cons : B = C -> A * B = A * C. + + Proof. + + intro Heq; rewrite Heq; reflexivity. + + Qed. + +.. coqtop:: in + + End Iso_axioms. + +.. coqtop:: in + + Ltac simplify_type ty := + match ty with + | ?A * ?B * ?C => + rewrite <- (Ass A B C); try simplify_type_eq + | ?A * ?B -> ?C => + rewrite (Cur A B C); try simplify_type_eq + | ?A -> ?B * ?C => + rewrite (Dis A B C); try simplify_type_eq + | ?A * unit => + rewrite (P_unit A); try simplify_type_eq + | unit * ?B => + rewrite (Com unit B); try simplify_type_eq + | ?A -> unit => + rewrite (AR_unit A); try simplify_type_eq + | unit -> ?B => + rewrite (AL_unit B); try simplify_type_eq + | ?A * ?B => + (simplify_type A; try simplify_type_eq) || + (simplify_type B; try simplify_type_eq) + | ?A -> ?B => + (simplify_type A; try simplify_type_eq) || + (simplify_type B; try simplify_type_eq) + end + with simplify_type_eq := + match goal with + | |- ?A = ?B => try simplify_type A; try simplify_type B + end. + +.. coqtop:: in + + Ltac len trm := + match trm with + | _ * ?B => let succ := len B in constr:(S succ) + | _ => constr:(1) + end. + +.. coqtop:: in + + Ltac assoc := repeat rewrite <- Ass. + +.. coqtop:: in + + Ltac solve_type_eq n := + match goal with + | |- ?A = ?A => reflexivity + | |- ?A * ?B = ?A * ?C => + apply Cons; let newn := len B in solve_type_eq newn + | |- ?A * ?B = ?C => + match eval compute in n with + | 1 => fail + | _ => + pattern (A * B) at 1; rewrite Com; assoc; solve_type_eq (pred n) + end + end. + +.. coqtop:: in + + Ltac compare_structure := + match goal with + | |- ?A = ?B => + let l1 := len A + with l2 := len B in + match eval compute in (l1 = l2) with + | ?n = ?n => solve_type_eq n + end + end. + +.. coqtop:: in + + Ltac solve_iso := simplify_type_eq; compare_structure. + +The tactic to judge equalities modulo this axiomatization is shown above. +The algorithm is quite simple. First types are simplified using axioms that +can be oriented (this is done by ``simplify_type`` and ``simplify_type_eq``). +The normal forms are sequences of Cartesian products without Cartesian product +in the left component. These normal forms are then compared modulo permutation +of the components by the tactic ``compare_structure``. If they have the same +lengths, the tactic ``solve_type_eq`` attempts to prove that the types are equal. +The main tactic that puts all these components together is called ``solve_iso``. + +Here are examples of what can be solved by ``solve_iso``. + +.. coqtop:: in + + Lemma solve_iso_ex1 : + forall A B : Set, A * unit * B = B * (unit * A). + Proof. + intros; solve_iso. + Qed. + +.. coqtop:: in + + Lemma solve_iso_ex2 : + forall A B C : Set, + (A * unit -> B * (C * unit)) = + (A * unit -> (C -> unit) * C) * (unit -> A -> B). + Proof. + intros; solve_iso. + Qed. + + Debugging |Ltac| tactics ------------------------ diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 0f78a9b84a..c728b925ac 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3561,7 +3561,7 @@ Automation .. tacn:: autorewrite with {+ @ident} :name: autorewrite - This tactic [4]_ carries out rewritings according to the rewriting rule + This tactic carries out rewritings according to the rewriting rule bases :n:`{+ @ident}`. Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until @@ -4661,9 +4661,12 @@ Non-logical tactics .. example:: - .. coqtop:: all reset + .. coqtop:: none reset Parameter P : nat -> Prop. + + .. coqtop:: all abort + Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. repeat split. all: cycle 2. @@ -4679,9 +4682,8 @@ Non-logical tactics .. example:: - .. coqtop:: reset all + .. coqtop:: all abort - Parameter P : nat -> Prop. Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. repeat split. all: swap 1 3. @@ -4694,9 +4696,8 @@ Non-logical tactics .. example:: - .. coqtop:: all reset + .. coqtop:: all abort - Parameter P : nat -> Prop. Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. repeat split. all: revgoals. @@ -4717,7 +4718,7 @@ Non-logical tactics .. example:: - .. coqtop:: all reset + .. coqtop:: all abort Goal exists n, n=0. refine (ex_intro _ _ _). @@ -4746,39 +4747,6 @@ Non-logical tactics The ``give_up`` tactic can be used while editing a proof, to choose to write the proof script in a non-sequential order. -Simple tactic macros -------------------------- - -A simple example has more value than a long explanation: - -.. example:: - - .. coqtop:: reset all - - Ltac Solve := simpl; intros; auto. - - Ltac ElimBoolRewrite b H1 H2 := - elim b; [ intros; rewrite H1; eauto | intros; rewrite H2; eauto ]. - -The tactics macros are synchronous with the Coq section mechanism: a -tactic definition is deleted from the current environment when you -close the section (see also :ref:`section-mechanism`) where it was -defined. If you want that a tactic macro defined in a module is usable in the -modules that require it, you should put it outside of any section. - -:ref:`ltac` gives examples of more complex -user-defined tactics. - -.. [1] Actually, only the second subgoal will be generated since the - other one can be automatically checked. -.. [2] This corresponds to the cut rule of sequent calculus. -.. [3] Reminder: opaque constants will not be expanded by δ reductions. -.. [4] The behavior of this tactic has changed a lot compared to the - versions available in the previous distributions (V6). This may cause - significant changes in your theories to obtain the same result. As a - drawback of the re-engineering of the code, this tactic has also been - completely revised to get a very compact and readable version. - Delaying solving unification constraints ---------------------------------------- @@ -4917,3 +4885,8 @@ Performance-oriented tactic variants Goal False. native_cast_no_check I. Fail Qed. + +.. [1] Actually, only the second subgoal will be generated since the + other one can be automatically checked. +.. [2] This corresponds to the cut rule of sequent calculus. +.. [3] Reminder: opaque constants will not be expanded by δ reductions. -- cgit v1.2.3 From f39ff2b2390a6a5634dbf60ea0383fae4b9f3069 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 9 May 2019 13:11:56 +0200 Subject: Rewording, language improvements. Co-Authored-By: Jim Fehrle --- doc/sphinx/proof-engine/ltac.rst | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index d35e4ab782..b02f9661e2 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -6,13 +6,13 @@ Ltac This chapter documents the tactic language |Ltac|. We start by giving the syntax, and next, we present the informal -semantics. If you want to know more regarding this language and -especially about its foundations, you can refer to :cite:`Del00`. +semantics. To learn more about the language and +especially about its foundations, please refer to :cite:`Del00`. .. example:: - Here are some examples of the kind of tactic macros that this - language allows to write. + Here are some examples of simple tactic macros that the + language lets you write. .. coqdoc:: @@ -21,7 +21,7 @@ especially about its foundations, you can refer to :cite:`Del00`. Ltac destruct_bool_and_rewrite b H1 H2 := destruct b; [ rewrite H1; eauto | rewrite H2; eauto ]. - Some more advanced examples are given in Section :ref:`ltac-examples`. + See Section :ref:`ltac-examples` for more advanced examples. .. _ltac-syntax: @@ -1183,8 +1183,8 @@ Examples of using |Ltac| About the cardinality of the set of natural numbers ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The first example which shows how to use pattern matching over the -proof context is a proof of the fact that natural numbers have more +The first example shows how to use pattern matching over the +proof context to prove that natural numbers have more than two elements. This can be done as follows: .. coqtop:: in reset @@ -1210,7 +1210,7 @@ than two elements. This can be done as follows: Qed. -We can notice that all the (very similar) cases coming from the three +Notice that all the (very similar) cases coming from the three eliminations (with three distinct natural numbers) are successfully solved by a match goal structure and, in particular, with only one pattern (use of non-linear matching). @@ -1269,9 +1269,9 @@ First, we define the permutation predicate as shown above. end. Next we define an auxiliary tactic ``perm_aux`` which takes an argument -used to control the recursion depth. This tactic behaves as follows. If +used to control the recursion depth. This tactic works as follows: If the lists are identical (i.e. convertible), it concludes. Otherwise, if -the lists have identical heads, it proceeds to look at their tails. +the lists have identical heads, it looks at their tails. Finally, if the lists have different heads, it rotates the first list by putting its head at the end if the new head hasn't been the head previously. To check this, we keep track of the number of performed rotations using the argument ``n``. We do this by @@ -1296,8 +1296,8 @@ choice is to use Coq data structures so that Coq makes the computations end. The main tactic is ``solve_perm``. It computes the lengths of the two lists -and uses them as arguments to call ``perm_aux`` if the lengths are equal (if they -aren't, the lists cannot be permutations of each other). Using this tactic we +and uses them as arguments to call ``perm_aux`` if the lengths are equal. (If they +aren't, the lists cannot be permutations of each other.) Using this tactic we can now prove lemmas as follows: .. coqtop:: in @@ -1317,7 +1317,7 @@ can now prove lemmas as follows: Deciding intuitionistic propositional logic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Pattern matching on goals allows a powerful backtracking when returning tactic +Pattern matching on goals allows powerful backtracking when returning tactic values. An interesting application is the problem of deciding intuitionistic propositional logic. Considering the contraction-free sequent calculi LJT* of Roy Dyckhoff :cite:`Dyc92`, it is quite natural to code such a tactic using the @@ -1405,7 +1405,7 @@ Having defined ``my_tauto``, we can prove tautologies like these: Deciding type isomorphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~ -A more tricky problem is to decide equalities between types modulo +A trickier problem is to decide equalities between types modulo isomorphisms. Here, we choose to use the isomorphisms of the simply typed λ-calculus with Cartesian product and unit type (see, for example, :cite:`RC95`). The axioms of this λ-calculus are given below. @@ -1528,11 +1528,11 @@ example, :cite:`RC95`). The axioms of this λ-calculus are given below. The tactic to judge equalities modulo this axiomatization is shown above. The algorithm is quite simple. First types are simplified using axioms that can be oriented (this is done by ``simplify_type`` and ``simplify_type_eq``). -The normal forms are sequences of Cartesian products without Cartesian product +The normal forms are sequences of Cartesian products without a Cartesian product in the left component. These normal forms are then compared modulo permutation of the components by the tactic ``compare_structure``. If they have the same -lengths, the tactic ``solve_type_eq`` attempts to prove that the types are equal. -The main tactic that puts all these components together is called ``solve_iso``. +length, the tactic ``solve_type_eq`` attempts to prove that the types are equal. +The main tactic that puts all these components together is ``solve_iso``. Here are examples of what can be solved by ``solve_iso``. -- cgit v1.2.3 From 66df9050edb8c1fe10992a58f2ec51957cf03449 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 9 May 2019 12:44:28 +0000 Subject: Ignore generated dune file for Ltac2 --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 5264968e95..5339a0c44d 100644 --- a/.gitignore +++ b/.gitignore @@ -167,6 +167,7 @@ ide/index_urls.txt /user-contrib/* !/user-contrib/Ltac2 + .*.sw* .#* @@ -184,5 +185,6 @@ plugins/*/dune theories/*/dune theories/*/*/dune theories/*/*/*/dune +/user-contrib/Ltac2/dune *.install !Makefile.install -- cgit v1.2.3 From 7843c21c9568f49a78d7c306978f446618ef8d25 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Thu, 9 May 2019 18:11:01 +0200 Subject: Improve the first two Ltac examples. --- doc/sphinx/proof-engine/ltac.rst | 193 +++++++++++++++++++++------------------ 1 file changed, 102 insertions(+), 91 deletions(-) diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b02f9661e2..83b8bc2308 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -9,7 +9,7 @@ We start by giving the syntax, and next, we present the informal semantics. To learn more about the language and especially about its foundations, please refer to :cite:`Del00`. -.. example:: +.. example:: Basic tactic macros Here are some examples of simple tactic macros that the language lets you write. @@ -1179,140 +1179,151 @@ Printing |Ltac| tactics Examples of using |Ltac| ------------------------- - About the cardinality of the set of natural numbers ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The first example shows how to use pattern matching over the -proof context to prove that natural numbers have more -than two elements. This can be done as follows: +.. example:: About the cardinality of the set of natural numbers -.. coqtop:: in reset + The first example shows how to use pattern matching over the proof + context to prove that natural numbers have at least two + elements. This can be done as follows: - Lemma card_nat : - ~ exists x : nat, exists y : nat, forall z:nat, x = z \/ y = z. - Proof. + .. coqtop:: reset all -.. coqtop:: in + Lemma card_nat : + ~ exists x y : nat, forall z:nat, x = z \/ y = z. + Proof. + intros (x & y & Hz). + destruct (Hz 0), (Hz 1), (Hz 2). - red; intros (x, (y, Hy)). + At this point, the :tacn:`congruence` tactic would finish the job: -.. coqtop:: in + .. coqtop:: all abort - elim (Hy 0); elim (Hy 1); elim (Hy 2); intros; + all: congruence. - match goal with - | _ : ?a = ?b, _ : ?a = ?c |- _ => - cut (b = c); [ discriminate | transitivity a; auto ] - end. + But for the purpose of the example, let's craft our own custom + tactic to solve this: -.. coqtop:: in + .. coqtop:: none - Qed. + Lemma card_nat : + ~ exists x y : nat, forall z:nat, x = z \/ y = z. + Proof. + intros (x & y & Hz). + destruct (Hz 0), (Hz 1), (Hz 2). -Notice that all the (very similar) cases coming from the three -eliminations (with three distinct natural numbers) are successfully -solved by a match goal structure and, in particular, with only one -pattern (use of non-linear matching). + .. coqtop:: all abort + all: match goal with + | _ : ?a = ?b, _ : ?a = ?c |- _ => assert (b = c) by now transitivity a + end. + all: discriminate. -Permutations of lists -~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Notice that all the (very similar) cases coming from the three + eliminations (with three distinct natural numbers) are successfully + solved by a ``match goal`` structure and, in particular, with only one + pattern (use of non-linear matching). -A more complex example is the problem of permutations of -lists. The aim is to show that a list is a permutation of -another list. -.. coqtop:: in reset +Proving that a list is a permutation of a second list +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Section Sort. +.. example:: Proving that a list is a permutation of a second list -.. coqtop:: in + Let's first define the permutation predicate: - Variable A : Set. + .. coqtop:: in reset -.. coqtop:: in + Section Sort. - Inductive perm : list A -> list A -> Prop := - | perm_refl : forall l, perm l l - | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) - | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) - | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. + Variable A : Set. -.. coqtop:: in + Inductive perm : list A -> list A -> Prop := + | perm_refl : forall l, perm l l + | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) + | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) + | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. - End Sort. + End Sort. -First, we define the permutation predicate as shown above. + .. coqtop:: none -.. coqtop:: none + Require Import List. - Require Import List. + Next we define an auxiliary tactic :g:`perm_aux` which takes an + argument used to control the recursion depth. This tactic works as + follows: If the lists are identical (i.e. convertible), it + completes the proof. Otherwise, if the lists have identical heads, + it looks at their tails. Finally, if the lists have different + heads, it rotates the first list by putting its head at the end. -.. coqtop:: in + Every time we perform a rotation, we decrement :g:`n`. When :g:`n` + drops down to :g:`1`, we stop performing rotations and we fail. + The idea is to give the length of the list as the initial value of + :g:`n`. This way of counting the number of rotations will avoid + going back to a head that had been considered before. - Ltac perm_aux n := - match goal with - | |- (perm _ ?l ?l) => apply perm_refl - | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => + From Section :ref:`ltac-syntax` we know that Ltac has a primitive + notion of integers, but they are only used as arguments for + primitive tactics and we cannot make computations with them. Thus, + instead, we use Coq's natural number type :g:`nat`. + + .. coqtop:: in + + Ltac perm_aux n := + match goal with + | |- (perm _ ?l ?l) => apply perm_refl + | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => let newn := eval compute in (length l1) in (apply perm_cons; perm_aux newn) - | |- (perm ?A (?a :: ?l1) ?l2) => + | |- (perm ?A (?a :: ?l1) ?l2) => match eval compute in n with - | 1 => fail - | _ => - let l1' := constr:(l1 ++ a :: nil) in - (apply (perm_trans A (a :: l1) l1' l2); - [ apply perm_append | compute; perm_aux (pred n) ]) + | 1 => fail + | _ => + let l1' := constr:(l1 ++ a :: nil) in + (apply (perm_trans A (a :: l1) l1' l2); + [ apply perm_append | compute; perm_aux (pred n) ]) end - end. + end. -Next we define an auxiliary tactic ``perm_aux`` which takes an argument -used to control the recursion depth. This tactic works as follows: If -the lists are identical (i.e. convertible), it concludes. Otherwise, if -the lists have identical heads, it looks at their tails. -Finally, if the lists have different heads, it rotates the first list by -putting its head at the end if the new head hasn't been the head previously. To check this, we keep track of the -number of performed rotations using the argument ``n``. We do this by -decrementing ``n`` each time we perform a rotation. It works because -for a list of length ``n`` we can make exactly ``n - 1`` rotations -to generate at most ``n`` distinct lists. Notice that we use the natural -numbers of Coq for the rotation counter. From :ref:`ltac-syntax` we know -that it is possible to use the usual natural numbers, but they are only -used as arguments for primitive tactics and they cannot be handled, so, -in particular, we cannot make computations with them. Thus the natural -choice is to use Coq data structures so that Coq makes the computations -(reductions) by ``eval compute in`` and we can get the terms back by match. -.. coqtop:: in + The main tactic is :g:`solve_perm`. It computes the lengths of the + two lists and uses them as arguments to call :g:`perm_aux` if the + lengths are equal. (If they aren't, the lists cannot be + permutations of each other.) - Ltac solve_perm := - match goal with - | |- (perm _ ?l1 ?l2) => + .. coqtop:: in + + Ltac solve_perm := + match goal with + | |- (perm _ ?l1 ?l2) => match eval compute in (length l1 = length l2) with - | (?n = ?n) => perm_aux n + | (?n = ?n) => perm_aux n end - end. + end. -The main tactic is ``solve_perm``. It computes the lengths of the two lists -and uses them as arguments to call ``perm_aux`` if the lengths are equal. (If they -aren't, the lists cannot be permutations of each other.) Using this tactic we -can now prove lemmas as follows: + And now, here is how we can use the tactic :g:`solve_perm`: -.. coqtop:: in + .. coqtop:: out - Lemma solve_perm_ex1 : - perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). - Proof. solve_perm. Qed. + Goal perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). -.. coqtop:: in + .. coqtop:: all abort + + solve_perm. + + .. coqtop:: out + + Goal perm nat + (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) + (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). + + .. coqtop:: all abort + + solve_perm. - Lemma solve_perm_ex2 : - perm nat - (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) - (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). - Proof. solve_perm. Qed. Deciding intuitionistic propositional logic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- cgit v1.2.3 From 281e6657c7fe5033a13c7a2fd2b6cc6f51cb6911 Mon Sep 17 00:00:00 2001 From: Michael Soegtrop Date: Thu, 9 May 2019 10:44:15 +0200 Subject: Switched Coquelicot CI URLs from INRIA gforge to INRIA gitlab --- dev/ci/ci-basic-overlay.sh | 3 ++- dev/ci/ci-coquelicot.sh | 1 - dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh | 6 ------ 3 files changed, 2 insertions(+), 8 deletions(-) delete mode 100644 dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4f5988c59c..d39b92467d 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -105,7 +105,8 @@ # Coquelicot ######################################################################## : "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" +: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" +: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" ######################################################################## # CompCert diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 33627fd8ef..6cb8dad604 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -5,7 +5,6 @@ ci_dir="$(dirname "$0")" install_ssreflect -FORCE_GIT=1 git_download coquelicot ( cd "${CI_BUILD_DIR}/coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh b/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh deleted file mode 100644 index 720adbc979..0000000000 --- a/dev/ci/user-overlays/09854-vbgl-field_simplify_int.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9854" ] || [ "$CI_BRANCH" = "field_simplify_int" ]; then - - coquelicot_CI_REF=field_simplify_int - coquelicot_CI_GITURL=https://gitlab.com/vbgl/coquelicot - -fi -- cgit v1.2.3 From 3603a6d3324aa54c385f3f84a9fb4d5b9c2fde57 Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Fri, 10 May 2019 00:15:23 +0200 Subject: Better title for the first example of the Ltac examples section. --- doc/sphinx/proof-engine/ltac.rst | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 83b8bc2308..a7eb7c2319 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1179,10 +1179,10 @@ Printing |Ltac| tactics Examples of using |Ltac| ------------------------- -About the cardinality of the set of natural numbers -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Proof that the natural numbers have at least two elements +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. example:: About the cardinality of the set of natural numbers +.. example:: Proof that the natural numbers have at least two elements The first example shows how to use pattern matching over the proof context to prove that natural numbers have at least two -- cgit v1.2.3 From 1cdaa823aa2db2f68cf63561a85771bb98aec70f Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 2 Apr 2019 13:22:11 +0200 Subject: [api] Remove 8.10 deprecations. Some of them are significant so presumably it will take a bit of effort to fix overlays. I left out the removal of `nf_enter` for now as MTac2 needs some serious porting in order to avoid it. --- clib/cString.ml | 8 ----- clib/cString.mli | 8 ----- dev/doc/changes.md | 7 +++++ engine/evarutil.ml | 19 +----------- engine/evarutil.mli | 9 ------ engine/evd.ml | 2 -- engine/evd.mli | 3 -- engine/ftactic.ml | 7 ----- engine/ftactic.mli | 3 -- engine/proofview.ml | 7 ----- engine/proofview.mli | 4 --- engine/termops.ml | 18 ----------- engine/termops.mli | 24 --------------- engine/uState.ml | 2 -- engine/uState.mli | 3 -- engine/univGen.ml | 42 -------------------------- engine/univGen.mli | 27 ----------------- interp/impargs.ml | 2 -- interp/impargs.mli | 4 --- kernel/indtypes.ml | 17 ++--------- kernel/indtypes.mli | 19 ------------ kernel/names.ml | 3 -- kernel/names.mli | 3 -- lib/rtree.ml | 5 --- lib/rtree.mli | 6 ---- library/global.ml | 5 --- library/global.mli | 8 ----- library/globnames.ml | 12 -------- library/globnames.mli | 18 ----------- library/lib.ml | 4 +-- library/nametab.ml | 17 ----------- library/nametab.mli | 16 ---------- plugins/funind/recdef.ml | 30 +++++++++--------- plugins/micromega/coq_micromega.ml | 2 +- plugins/ssr/ssrequality.ml | 4 +-- pretyping/evarconv.ml | 25 --------------- pretyping/evarconv.mli | 13 -------- printing/printmod.ml | 2 +- proofs/proof.ml | 62 ++++++++++---------------------------- proofs/proof.mli | 47 ----------------------------- proofs/tacmach.ml | 4 --- proofs/tacmach.mli | 2 -- tactics/ppred.mli | 5 --- toplevel/coqargs.ml | 7 ----- toplevel/coqtop.ml | 26 ---------------- toplevel/usage.ml | 14 --------- vernac/himsg.ml | 3 -- vernac/himsg.mli | 5 --- 48 files changed, 47 insertions(+), 536 deletions(-) diff --git a/clib/cString.ml b/clib/cString.ml index 111be3da82..423c08da13 100644 --- a/clib/cString.ml +++ b/clib/cString.ml @@ -17,16 +17,12 @@ sig val is_empty : string -> bool val explode : string -> string list val implode : string list -> string - val strip : string -> string - [@@ocaml.deprecated "Use [trim]"] val drop_simple_quotes : string -> string val string_index_from : string -> int -> string -> int val string_contains : where:string -> what:string -> bool val plural : int -> string -> string val conjugate_verb_to_be : int -> string val ordinal : int -> string - val split : char -> string -> string list - [@@ocaml.deprecated "Use [split_on_char]"] val is_sub : string -> string -> int -> bool module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set @@ -59,8 +55,6 @@ let implode sl = String.concat "" sl let is_empty s = String.length s = 0 -let strip = String.trim - let drop_simple_quotes s = let n = String.length s in if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s @@ -124,8 +118,6 @@ let ordinal n = (* string parsing *) -let split = String.split_on_char - module Self = struct type t = string diff --git a/clib/cString.mli b/clib/cString.mli index 364b6a34b1..f68bd3bb65 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -30,10 +30,6 @@ sig val implode : string list -> string (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *) - val strip : string -> string - [@@ocaml.deprecated "Use [trim]"] - (** Alias for [String.trim] *) - val drop_simple_quotes : string -> string (** Remove the eventual first surrounding simple quotes of a string. *) @@ -52,10 +48,6 @@ sig val ordinal : int -> string (** Generate the ordinal number in English. *) - val split : char -> string -> string list - [@@ocaml.deprecated "Use [split_on_char]"] - (** [split c s] alias of [String.split_on_char] *) - val is_sub : string -> string -> int -> bool (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *) diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 9e0d47651e..7221c3de56 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,3 +1,10 @@ +## Changes between Coq 8.10 and Coq 8.11 + +### ML API + +- Functions and types deprecated in 8.10 have been removed in Coq + 8.11. + ## Changes between Coq 8.9 and Coq 8.10 ### ML4 Pre Processing diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 96beb72a56..be0318fbde 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -26,24 +26,7 @@ let safe_evar_value sigma ev = try Some (EConstr.Unsafe.to_constr @@ Evd.existential_value sigma ev) with NotInstantiatedEvar | Not_found -> None -(** Combinators *) - -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - -let new_global evd x = +let new_global evd x = let (evd, c) = Evd.fresh_global (Global.env()) evd x in (evd, c) diff --git a/engine/evarutil.mli b/engine/evarutil.mli index bb0da44103..8eaff8bd13 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -274,15 +274,6 @@ val push_rel_context_to_named_context : ?hypnaming:naming_mode -> val generalize_evar_over_rels : evar_map -> existential -> types * constr list -(** Evar combinators *) - -val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a -[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] -val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a -[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] -val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a -[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] - val subterm_source : Evar.t -> ?where:Evar_kinds.subevar_kind -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located diff --git a/engine/evd.ml b/engine/evd.ml index b89222cf8e..d37b49e2dc 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -869,8 +869,6 @@ let to_universe_context evd = UState.context evd.universes let univ_entry ~poly evd = UState.univ_entry ~poly evd.universes -let const_univ_entry = univ_entry - let check_univ_decl ~poly evd decl = UState.check_univ_decl ~poly evd.universes decl let restrict_universe_context evd vars = diff --git a/engine/evd.mli b/engine/evd.mli index b0fcddb068..29235050b0 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -615,9 +615,6 @@ val to_universe_context : evar_map -> Univ.UContext.t val univ_entry : poly:bool -> evar_map -> Entries.universes_entry -val const_univ_entry : poly:bool -> evar_map -> Entries.universes_entry -[@@ocaml.deprecated "Use [univ_entry]."] - val check_univ_decl : poly:bool -> evar_map -> UState.universe_decl -> Entries.universes_entry val merge_universe_context : evar_map -> UState.t -> evar_map diff --git a/engine/ftactic.ml b/engine/ftactic.ml index ac0344148a..dab2e7d5ef 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -56,13 +56,6 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) -let nf_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) [@warning "-3"] - let enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 3c4fa6f4e8..ed95d62bc6 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -41,9 +41,6 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : (Proofview.Goal.t -> 'a t) -> 'a t -[@@ocaml.deprecated "Normalization is enforced by EConstr, please use [enter]"] - (** Enter a goal. The resulting tactic is focussed. *) val enter : (Proofview.Goal.t -> 'a t) -> 'a t diff --git a/engine/proofview.ml b/engine/proofview.ml index f278c83912..ecea637947 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1104,13 +1104,6 @@ module Goal = struct tclZERO ~info e end end - - let normalize { self; state } = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - let (gl,sigma) = nf_gmake env sigma (goal_with_state self state) in - tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) - let gmake env sigma goal = let state = get_state goal in let goal = drop_state goal in diff --git a/engine/proofview.mli b/engine/proofview.mli index 9455dae643..92f8b86df5 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -505,10 +505,6 @@ module Goal : sig (** Type of goals. *) type t - (** Normalises the argument goal. *) - val normalize : t -> t tactic - [@@ocaml.deprecated "Normalization is enforced by EConstr, [normalize] is not needed anymore"] - (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the diff --git a/engine/termops.ml b/engine/termops.ml index 8e12c9be88..8a6bd17948 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -25,11 +25,6 @@ module CompactedDecl = Context.Compacted.Declaration module Internal = struct -let pr_sort_family = Sorts.pr_sort_family -[@@ocaml.deprecated "Use [Sorts.pr_sort_family]"] -let pr_fix = Constr.debug_print_fix -[@@ocaml.deprecated "Use [Constr.debug_print_fix]"] - let debug_print_constr c = Constr.debug_print EConstr.Unsafe.(to_constr c) let debug_print_constr_env env sigma c = Constr.debug_print EConstr.(to_constr sigma c) let term_printer = ref debug_print_constr_env @@ -761,13 +756,6 @@ let fold_constr_with_binders sigma g f n acc c = let c = Unsafe.to_constr (whd_evar sigma c) in Constr.fold_constr_with_binders g f n acc c -(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate - subterms of [c]; it carries an extra data [acc] which is processed by [g] at - each binder traversal; it is not recursive and the order with which - subterms are processed is not specified *) - -let iter_constr_with_full_binders = EConstr.iter_with_full_binders - (***************************) (* occurs check functions *) (***************************) @@ -862,8 +850,6 @@ let collect_vars sigma c = | _ -> EConstr.fold sigma aux vars c in aux Id.Set.empty c -let vars_of_global_reference = vars_of_global - (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) @@ -1417,10 +1403,6 @@ let prod_applist_assum sigma n c l = | _ -> anomaly (Pp.str "Not enough prod/let's.") in app n [] c l -let on_judgment = Environ.on_judgment -let on_judgment_value = Environ.on_judgment_value -let on_judgment_type = Environ.on_judgment_type - (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in variables skips let-in's; let-in's in the middle are put in ctx2 *) let context_chop k ctx = diff --git a/engine/termops.mli b/engine/termops.mli index 1dd9941c5e..a9217b3586 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -16,12 +16,6 @@ open Constr open Environ open EConstr -(** printers *) -val pr_sort_family : Sorts.family -> Pp.t -[@@ocaml.deprecated "Use [Sorts.pr_sort_family]"] -val pr_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t -[@@ocaml.deprecated "Use [Constr.debug_print_fix]"] - (** about contexts *) val push_rel_assum : Name.t Context.binder_annot * types -> env -> env val push_rels_assum : (Name.t Context.binder_annot * Constr.types) list -> env -> env @@ -84,12 +78,6 @@ val fold_constr_with_full_binders : Evd.evar_map -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b -val iter_constr_with_full_binders : Evd.evar_map -> - (rel_declaration -> 'a -> 'a) -> - ('a -> constr -> unit) -> 'a -> - constr -> unit -[@@ocaml.deprecated "Use [EConstr.iter_with_full_binders]."] - (**********************************************************************) val strip_head_cast : Evd.evar_map -> constr -> constr @@ -121,9 +109,6 @@ val count_occurrences : Evd.evar_map -> constr -> constr -> int val collect_metas : Evd.evar_map -> constr -> int list val collect_vars : Evd.evar_map -> constr -> Id.Set.t (** for visible vars only *) -val vars_of_global_reference : env -> GlobRef.t -> Id.Set.t -[@@ocaml.deprecated "Use [Environ.vars_of_global]"] - (* Substitution of metavariables *) type meta_value_map = (metavariable * Constr.constr) list val subst_meta : meta_value_map -> Constr.constr -> Constr.constr @@ -292,15 +277,6 @@ val is_Type : Evd.evar_map -> constr -> bool val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.qualid option -(** Combinators on judgments *) - -val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment -[@@ocaml.deprecated "Use [Environ.on_judgment]."] -val on_judgment_value : ('c -> 'c) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment -[@@ocaml.deprecated "Use [Environ.on_judgment_value]."] -val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment -[@@ocaml.deprecated "Use [Environ.on_judgment_type]."] - (** {5 Debug pretty-printers} *) open Evd diff --git a/engine/uState.ml b/engine/uState.ml index aa14f66df6..adea78d4c9 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -116,8 +116,6 @@ let univ_entry ~poly uctx = Polymorphic_entry (nas, uctx) else Monomorphic_entry (context_set uctx) -let const_univ_entry = univ_entry - let of_context_set ctx = { empty with uctx_local = ctx } let subst ctx = ctx.uctx_univ_variables diff --git a/engine/uState.mli b/engine/uState.mli index a358813825..3df7f9e8e9 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -67,9 +67,6 @@ val context : t -> Univ.UContext.t val univ_entry : poly:bool -> t -> Entries.universes_entry (** Pick from {!context} or {!context_set} based on [poly]. *) -val const_univ_entry : poly:bool -> t -> Entries.universes_entry -[@@ocaml.deprecated "Use [univ_entry]."] - (** {5 Constraints handling} *) val drop_weak_constraints : bool ref diff --git a/engine/univGen.ml b/engine/univGen.ml index c310331b15..f1deb1bfaf 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -25,11 +25,6 @@ let new_univ_global () = let fresh_level () = Univ.Level.make (new_univ_global ()) -(* TODO: remove *) -let new_univ () = Univ.Universe.make (fresh_level ()) -let new_Type () = mkType (new_univ ()) -let new_Type_sort () = sort_of_univ (new_univ ()) - let fresh_instance auctx = let inst = Array.init (AUContext.size auctx) (fun _ -> fresh_level()) in let ctx = Array.fold_right LSet.add inst LSet.empty in @@ -83,10 +78,6 @@ let constr_of_monomorphic_global gr = Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ str " would forget universes.") -let constr_of_global gr = constr_of_monomorphic_global gr - -let constr_of_global_univ = mkRef - let fresh_global_or_constr_instance env = function | IsConstr c -> c, ContextSet.empty | IsGlobal gr -> fresh_global_instance env gr @@ -99,34 +90,6 @@ let global_of_constr c = | Var id -> VarRef id, Instance.empty | _ -> raise Not_found -open Declarations - -let type_of_reference env r = - match r with - | VarRef id -> Environ.named_type id env, ContextSet.empty - - | ConstRef c -> - let cb = Environ.lookup_constant c env in - let ty = cb.const_type in - let auctx = Declareops.constant_polymorphic_context cb in - let inst, ctx = fresh_instance auctx in - Vars.subst_instance_constr inst ty, ctx - - | IndRef ind -> - let (mib, _ as specif) = Inductive.lookup_mind_specif env ind in - let auctx = Declareops.inductive_polymorphic_context mib in - let inst, ctx = fresh_instance auctx in - let ty = Inductive.type_of_inductive env (specif, inst) in - ty, ctx - - | ConstructRef (ind,_ as cstr) -> - let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in - let auctx = Declareops.inductive_polymorphic_context mib in - let inst, ctx = fresh_instance auctx in - Inductive.type_of_constructor (cstr,inst) specif, ctx - -let type_of_global t = type_of_reference (Global.env ()) t - let fresh_sort_in_family = function | InSProp -> Sorts.sprop, ContextSet.empty | InProp -> Sorts.prop, ContextSet.empty @@ -135,11 +98,6 @@ let fresh_sort_in_family = function let u = fresh_level () in sort_of_univ (Univ.Universe.make u), ContextSet.singleton u -let new_sort_in_family sf = - fst (fresh_sort_in_family sf) - -let extend_context = Univ.extend_in_context_set - let new_global_univ () = let u = fresh_level () in (Univ.Universe.make u, ContextSet.singleton u) diff --git a/engine/univGen.mli b/engine/univGen.mli index b4598e10d0..34920e5620 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -24,16 +24,7 @@ val new_univ_id : unit -> univ_unique_id (** for the stm *) val new_univ_global : unit -> Level.UGlobal.t val fresh_level : unit -> Level.t -val new_univ : unit -> Universe.t -[@@ocaml.deprecated "Use [new_univ_level]"] -val new_Type : unit -> types -[@@ocaml.deprecated "Use [new_univ_level]"] -val new_Type_sort : unit -> Sorts.t -[@@ocaml.deprecated "Use [new_univ_level]"] - val new_global_univ : unit -> Universe.t in_universe_context_set -val new_sort_in_family : Sorts.family -> Sorts.t -[@@ocaml.deprecated "Use [fresh_sort_in_family]"] (** Build a fresh instance for a given context, its associated substitution and the instantiated constraints. *) @@ -66,27 +57,9 @@ val fresh_universe_context_set_instance : ContextSet.t -> (** Raises [Not_found] if not a global reference. *) val global_of_constr : constr -> GlobRef.t puniverses -val constr_of_global_univ : GlobRef.t puniverses -> constr -[@@ocaml.deprecated "Use [Constr.mkRef]"] - -val extend_context : 'a in_universe_context_set -> ContextSet.t -> - 'a in_universe_context_set -[@@ocaml.deprecated "Use [Univ.extend_in_context_set]"] - (** Create a fresh global in the global environment, without side effects. BEWARE: this raises an error on polymorphic constants/inductives: the constraints should be properly added to an evd. See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for the proper way to get a fresh copy of a polymorphic global reference. *) val constr_of_monomorphic_global : GlobRef.t -> constr - -val constr_of_global : GlobRef.t -> constr -[@@ocaml.deprecated "constr_of_global will crash on polymorphic constants,\ - use [constr_of_monomorphic_global] if the reference is guaranteed to\ - be monomorphic, [Evarutil.new_global] or [Tacmach.New.pf_constr_of_global] otherwise"] - -(** Returns the type of the global reference, by creating a fresh instance of polymorphic - references and computing their instantiated universe context. (side-effect on the - universe counter, use with care). *) -val type_of_global : GlobRef.t -> types in_universe_context_set -[@@ocaml.deprecated "use [Typeops.type_of_global]"] diff --git a/interp/impargs.ml b/interp/impargs.ml index d83a0ce918..90fb5a2036 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -120,8 +120,6 @@ let argument_position_eq p1 p2 = match p1, p2 with | Hyp h1, Hyp h2 -> Int.equal h1 h2 | _ -> false -let explicitation_eq = Constrexpr_ops.explicitation_eq - type implicit_explanation = | DepRigid of argument_position | DepFlex of argument_position diff --git a/interp/impargs.mli b/interp/impargs.mli index 0070423530..ccdd448460 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -143,7 +143,3 @@ val projection_implicits : env -> Projection.t -> implicit_status list -> val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list - -val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool - [@@ocaml.deprecated "Use Constrexpr_ops.explicitation_eq instead (since 8.10)"] -(** Equality on [explicitation]. *) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 009eb3da38..bb3b0a538e 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -49,20 +49,6 @@ let weaker_noccur_between env x nvars t = (************************************************************************) (* Various well-formedness check for inductive declarations *) -(* Errors related to inductive constructions *) -type inductive_error = Type_errors.inductive_error = - | NonPos of env * constr * constr - | NotEnoughArgs of env * constr * constr - | NotConstructor of env * Id.t * constr * constr * int * int - | NonPar of env * constr * int * constr * constr - | SameNamesTypes of Id.t - | SameNamesConstructors of Id.t - | SameNamesOverlap of Id.t list - | NotAnArity of env * constr - | BadEntry - | LargeNonPropInductiveNotInType - | BadUnivs - exception InductiveError = Type_errors.InductiveError (************************************************************************) @@ -84,6 +70,7 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum let explain_ind_err id ntyp env nparamsctxt c err = + let open Type_errors in let (_lparams,c') = mind_extract_params nparamsctxt c in match err with | LocalNonPos kt -> @@ -329,7 +316,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( | Prod (na,b,d) -> let () = assert (List.is_empty largs) in if not recursive && not (noccur_between n ntypes b) then - raise (InductiveError BadEntry); + raise (InductiveError Type_errors.BadEntry); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 7810c1723e..1b8e4208ff 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -9,28 +9,9 @@ (************************************************************************) open Names -open Constr open Declarations open Environ open Entries (** Check an inductive. *) val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - -(** Deprecated *) -type inductive_error = - | NonPos of env * constr * constr - | NotEnoughArgs of env * constr * constr - | NotConstructor of env * Id.t * constr * constr * int * int - | NonPar of env * constr * int * constr * constr - | SameNamesTypes of Id.t - | SameNamesConstructors of Id.t - | SameNamesOverlap of Id.t list - | NotAnArity of env * constr - | BadEntry - | LargeNonPropInductiveNotInType - | BadUnivs -[@@ocaml.deprecated "Use [Type_errors.inductive_error]"] - -exception InductiveError of Type_errors.inductive_error -[@@ocaml.deprecated "Use [Type_errors.InductiveError]"] diff --git a/kernel/names.ml b/kernel/names.ml index 9f27212967..047a1d6525 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -376,9 +376,6 @@ module KerName = struct { modpath; knlabel; refhash = -1; } let repr kn = (kn.modpath, kn.knlabel) - let make2 = make - [@@ocaml.deprecated "Please use [KerName.make]"] - let modpath kn = kn.modpath let label kn = kn.knlabel diff --git a/kernel/names.mli b/kernel/names.mli index 61df3bad0e..2238e932b0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -278,9 +278,6 @@ sig val make : ModPath.t -> Label.t -> t val repr : t -> ModPath.t * Label.t - val make2 : ModPath.t -> Label.t -> t - [@@ocaml.deprecated "Please use [KerName.make]"] - (** Projections *) val modpath : t -> ModPath.t val label : t -> Label.t diff --git a/lib/rtree.ml b/lib/rtree.ml index e1c6a4c4d6..66d9eba3f7 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -115,8 +115,6 @@ struct end -let smartmap = Smart.map - (** Structural equality test, parametrized by an equality on elements *) let rec raw_eq cmp t t' = match t, t' with @@ -149,9 +147,6 @@ let equiv cmp cmp' = let equal cmp t t' = t == t' || raw_eq cmp t t' || equiv cmp cmp t t' -(** Deprecated alias *) -let eq_rtree = equal - (** Intersection of rtrees of same arity *) let rec inter cmp interlbl def n histo t t' = try diff --git a/lib/rtree.mli b/lib/rtree.mli index 5ab14f6039..67519aa387 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -77,15 +77,9 @@ val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t - (** See also [Smart.map] *) val map : ('a -> 'b) -> 'a t -> 'b t -val smartmap : ('a -> 'a) -> 'a t -> 'a t -(** @deprecated Same as [Smart.map] *) - (** A rather simple minded pretty-printer *) val pp_tree : ('a -> Pp.t) -> 'a t -> Pp.t -val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool -(** @deprecated Same as [Rtree.equal] *) - module Smart : sig diff --git a/library/global.ml b/library/global.ml index 55aed1c56e..06e06a8cf2 100644 --- a/library/global.ml +++ b/library/global.ml @@ -157,11 +157,6 @@ let import c u d = globalize (Safe_typing.import c u d) let env_of_context hyps = reset_with_named_context hyps (env()) -let type_of_global_in_context = Typeops.type_of_global_in_context - -let universes_of_global gr = - universes_of_global (env ()) gr - let is_polymorphic r = Environ.is_polymorphic (env()) r let is_template_polymorphic r = is_template_polymorphic (env ()) r diff --git a/library/global.mli b/library/global.mli index 76ac3f6279..a60de48897 100644 --- a/library/global.mli +++ b/library/global.mli @@ -131,14 +131,6 @@ val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool val is_type_in_type : GlobRef.t -> bool -val type_of_global_in_context : Environ.env -> - GlobRef.t -> Constr.types * Univ.AUContext.t - [@@ocaml.deprecated "alias of [Typeops.type_of_global_in_context]"] - -(** Returns the universe context of the global reference (whatever its polymorphic status is). *) -val universes_of_global : GlobRef.t -> Univ.AUContext.t -[@@ocaml.deprecated "Use [Environ.universes_of_global]"] - (** {6 Retroknowledge } *) val register_inline : Constant.t -> unit diff --git a/library/globnames.ml b/library/globnames.ml index db2e8bfaed..99dcc43ad1 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -85,15 +85,6 @@ let printable_constr_of_global = function | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp -module RefOrdered = Names.GlobRef.Ordered -module RefOrdered_env = Names.GlobRef.Ordered_env - -module Refmap = Names.GlobRef.Map -module Refset = Names.GlobRef.Set - -module Refmap_env = Names.GlobRef.Map_env -module Refset_env = Names.GlobRef.Set_env - (* Extended global references *) type syndef_name = KerName.t @@ -134,6 +125,3 @@ end type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr - -(* Deprecated *) -let eq_gr = GlobRef.equal diff --git a/library/globnames.mli b/library/globnames.mli index d49ed453f5..14e422b743 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -25,8 +25,6 @@ val isConstRef : GlobRef.t -> bool val isIndRef : GlobRef.t -> bool val isConstructRef : GlobRef.t -> bool -val eq_gr : GlobRef.t -> GlobRef.t -> bool -[@@ocaml.deprecated "Use Names.GlobRef.equal"] val canonical_gr : GlobRef.t -> GlobRef.t val destVarRef : GlobRef.t -> variable @@ -48,22 +46,6 @@ val printable_constr_of_global : GlobRef.t -> constr raise [Not_found] if not a global reference *) val global_of_constr : constr -> GlobRef.t -module RefOrdered = Names.GlobRef.Ordered -[@@ocaml.deprecated "Use Names.GlobRef.Ordered"] - -module RefOrdered_env = Names.GlobRef.Ordered_env -[@@ocaml.deprecated "Use Names.GlobRef.Ordered_env"] - -module Refset = Names.GlobRef.Set -[@@ocaml.deprecated "Use Names.GlobRef.Set"] -module Refmap = Names.GlobRef.Map -[@@ocaml.deprecated "Use Names.GlobRef.Map"] - -module Refset_env = GlobRef.Set_env -[@@ocaml.deprecated "Use Names.GlobRef.Set_env"] -module Refmap_env = GlobRef.Map_env -[@@ocaml.deprecated "Use Names.GlobRef.Map_env"] - (** {6 Extended global references } *) type syndef_name = KerName.t diff --git a/library/lib.ml b/library/lib.ml index d4381a6923..a046360822 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -278,7 +278,7 @@ let start_mod is_type export id mp fs = let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in let exists = if is_type then Nametab.exists_cci (make_path id) - else Nametab.exists_module dir + else Nametab.exists_dir dir in if exists then user_err ~hdr:"open_module" (Id.print id ++ str " already exists"); @@ -569,7 +569,7 @@ let open_section id = let opp = !lib_state.path_prefix in let obj_dir = add_dirpath_suffix opp.Nametab.obj_dir id in let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in - if Nametab.exists_section obj_dir then + if Nametab.exists_dir obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:false in add_entry (make_foname id) (OpenedSection (prefix, fs)); diff --git a/library/nametab.ml b/library/nametab.ml index 95890b2edf..bd0ea5f04f 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -43,12 +43,6 @@ module GlobDirRef = struct end -type global_dir_reference = GlobDirRef.t -[@@ocaml.deprecated "Use [GlobDirRef.t]"] - -let eq_global_dir_reference = GlobDirRef.equal -[@@ocaml.deprecated "Use [GlobDirRef.equal]"] - exception GlobalizationError of qualid let error_global_not_found qid = @@ -516,10 +510,6 @@ let exists_cci sp = ExtRefTab.exists sp !the_ccitab let exists_dir dir = DirTab.exists dir !the_dirtab -let exists_section = exists_dir - -let exists_module = exists_dir - let exists_modtype sp = MPTab.exists sp !the_modtypetab let exists_universe kn = UnivTab.exists kn !the_univtab @@ -585,10 +575,3 @@ let global_inductive qid = | ref -> user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" (pr_qualid qid ++ spc () ++ str "is not an inductive type") - -(********************************************************************) - -(* Deprecated synonyms *) - -let extended_locate = locate_extended -let absolute_reference = global_of_path diff --git a/library/nametab.mli b/library/nametab.mli index fccb8fd918..a4f177aad0 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -89,13 +89,6 @@ module GlobDirRef : sig val equal : t -> t -> bool end -type global_dir_reference = GlobDirRef.t -[@@ocaml.deprecated "Use [GlobDirRef.t]"] - -val eq_global_dir_reference : - GlobDirRef.t -> GlobDirRef.t -> bool -[@@ocaml.deprecated "Use [GlobDirRef.equal]"] - exception GlobalizationError of qualid (** Raises a globalization error *) @@ -170,10 +163,6 @@ val extended_global_of_path : full_path -> extended_global_reference val exists_cci : full_path -> bool val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool -val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) - -val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) - val exists_universe : full_path -> bool (** {6 These functions locate qualids into full user names } *) @@ -220,11 +209,6 @@ val shortest_qualid_of_modtype : ?loc:Loc.t -> ModPath.t -> qualid val shortest_qualid_of_module : ?loc:Loc.t -> ModPath.t -> qualid val shortest_qualid_of_universe : ?loc:Loc.t -> Univ.Level.UGlobal.t -> qualid -(** Deprecated synonyms *) - -val extended_locate : qualid -> extended_global_reference (*= locate_extended *) -val absolute_reference : full_path -> GlobRef.t (** = global_of_path *) - (** {5 Generic name handling} *) (** NOT FOR PUBLIC USE YET. Plugin writers, please do not rely on this API. *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 3c2b03dfe0..372e918948 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -132,7 +132,7 @@ let nat = function () -> (coq_init_constant "nat") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_global (delayed_force iter_ref)) +let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") @@ -145,7 +145,7 @@ let coq_O = function () -> (coq_init_constant "O") let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) +let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -1041,13 +1041,13 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in + let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter_rd, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: - constr_of_global func::mkRel 1:: + constr_of_monomorphic_global func::mkRel 1:: List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) @@ -1065,7 +1065,7 @@ let compute_terminate_type nb_args func = delayed_force nat, (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), + let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), [|b; (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in compose_prod rev_args value @@ -1161,7 +1161,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a fun g -> let sigma = project g in let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_global func)) in + let func_body = (def_of_const (constr_of_monomorphic_global func)) in let func_body = EConstr.of_constr func_body in let (f_name, _, body1) = destLambda sigma func_body in let f_id = @@ -1222,7 +1222,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types pstate = let p = Proof_global.give_me_the_proof pstate in - let sgs,_,_,_,sigma = Proof.proof p in + let Proof.{ goals=sgs; sigma; _ } = Proof.data p in sigma, List.map (Goal.V82.abstract_type sigma) sgs exception EmptySubgoals @@ -1253,7 +1253,7 @@ let build_and_l sigma l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr)))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) [tclIDTAC; tac ],nb+1 @@ -1437,7 +1437,7 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_global term_f in + let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in @@ -1457,7 +1457,7 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in let evd = Evd.from_ctx uctx in - let f_constr = constr_of_global f_ref in + let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in let pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd (EConstr.of_constr equation_lemma_type) in @@ -1466,12 +1466,12 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_global terminate_ref); + f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); f_constr = EConstr.of_constr f_constr; concl_tac = tclIDTAC; func=functional_ref; info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_global functional_ref))) + (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) (EConstr.of_constr f_constr::List.map mkVar x) ); is_main_branch = true; @@ -1570,9 +1570,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num if not stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in - let f_ref = destConst (constr_of_global f_ref) - and functional_ref = destConst (constr_of_global functional_ref) - and eq_ref = destConst (constr_of_global eq_ref) in + let f_ref = destConst (constr_of_monomorphic_global f_ref) + and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index ef6af16036..de9dec0f74 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -207,7 +207,7 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules [@@@ocaml.warning "+3"] diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ad20113320..6493e2d86b 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -446,7 +446,7 @@ let lz_setoid_relation = | Some (env', srel) when env' == env -> srel | _ -> let srel = - try Some (UnivGen.constr_of_global @@ + try Some (UnivGen.constr_of_monomorphic_global @@ Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in last_srel := Some (env, srel); srel @@ -491,7 +491,7 @@ let rwprocess_rule dir rule gl = | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in EConstr.mkApp (pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.True.type"))) then + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.(lib_ref "core.True.type"))) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 99013a19c9..6b149a8b41 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1769,28 +1769,3 @@ let unify ?flags ?(with_ho=true) env evd cv_pb ty1 ty2 = solve_unif_constraints_with_heuristics ~flags ~with_ho env evd | UnifFailure (evd, reason) -> raise (PretypeError (env, evd, CannotUnify (ty1, ty2, Some reason))) - -(* deprecated *) -let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = - let flags = default_flags_of ts in - match evar_conv_x flags env evd CONV t1 t2 with - | Success evd' -> evd' - | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) - -let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd = - let flags = default_flags_of ts in - match evar_conv_x flags env evd CUMUL t1 t2 with - | Success evd' -> evd' - | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) - -let make_opt = function - | Success evd -> Some evd - | UnifFailure _ -> None - -let conv env ?(ts=default_transparent_state env) evd t1 t2 = - let flags = default_flags_of ts in - make_opt(evar_conv_x flags env evd CONV t1 t2) - -let cumul env ?(ts=default_transparent_state env) evd t1 t2 = - let flags = default_flags_of ts in - make_opt(evar_conv_x flags env evd CUMUL t1 t2) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index bf83f5e88f..eae961714d 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -46,19 +46,6 @@ exception UnableToUnify of evar_map * Pretype_errors.unification_error val unify_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map val unify_leq_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map -(** returns exception UnableToUnify with best known evar_map if not unifiable *) -val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map -[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] -val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map -[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] -(** The same function resolving evars by side-effect and - catching the exception *) - -val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option -[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] -val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option -[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] - (** This function also calls [solve_unif_constraints_with_heuristics] to resolve any remaining constraints. In case of success the two terms are unified without condition. diff --git a/printing/printmod.ml b/printing/printmod.ml index f4986652b3..bd97104f60 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -63,7 +63,7 @@ let keyword s = tag_keyword (str s) let get_new_id locals id = let rec get_id l id = let dir = DirPath.make [id] in - if not (Nametab.exists_module dir) then + if not (Nametab.exists_dir dir) then id else get_id (Id.Set.add id l) (Namegen.next_ident_away id l) diff --git a/proofs/proof.ml b/proofs/proof.ml index 978b1f6f78..778d98b2cd 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -126,9 +126,6 @@ type t = (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) } -let initial_goals pf = Proofview.initial_goals pf.entry -let initial_euctx pf = pf.initial_euctx - (*** General proof functions ***) let proof p = @@ -147,33 +144,6 @@ let proof p = let given_up = p.given_up in (goals,stack,shelf,given_up,sigma) -type 'a pre_goals = { - fg_goals : 'a list; - (** List of the focussed goals *) - bg_goals : ('a list * 'a list) list; - (** Zipper representing the unfocussed background goals *) - shelved_goals : 'a list; - (** List of the goals on the shelf. *) - given_up_goals : 'a list; - (** List of the goals that have been given up *) -} - -let map_structured_proof pfts process_goal: 'a pre_goals = - let (goals, zipper, shelf, given_up, sigma) = proof pfts in - let fg = List.map (process_goal sigma) goals in - let map_zip (lg, rg) = - let lg = List.map (process_goal sigma) lg in - let rg = List.map (process_goal sigma) rg in - (lg, rg) - in - let bg = List.map map_zip zipper in - let shelf = List.map (process_goal sigma) shelf in - let given_up = List.map (process_goal sigma) given_up in - { fg_goals = fg; - bg_goals = bg; - shelved_goals = shelf; - given_up_goals = given_up; } - let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk | [] -> pv @@ -441,22 +411,6 @@ let in_proof p k = k (Proofview.return p.proofview) let unshelve p = { p with proofview = Proofview.unshelve (p.shelf) (p.proofview) ; shelf = [] } -let pr_proof p = - let p = map_structured_proof p (fun _sigma g -> g) in - Pp.( - let pr_goal_list = prlist_with_sep spc Goal.pr_goal in - let rec aux acc = function - | [] -> acc - | (before,after)::stack -> - aux (pr_goal_list before ++ spc () ++ str "{" ++ acc ++ str "}" ++ spc () ++ - pr_goal_list after) stack in - str "[" ++ str "focus structure: " ++ - aux (pr_goal_list p.fg_goals) p.bg_goals ++ str ";" ++ spc () ++ - str "shelved: " ++ pr_goal_list p.shelved_goals ++ str ";" ++ spc () ++ - str "given up: " ++ pr_goal_list p.given_up_goals ++ - str "]" - ) - (*** Compatibility layer with <=v8.2 ***) module V82 = struct @@ -554,3 +508,19 @@ let data { proofview; focus_stack; entry; shelf; given_up; initial_euctx; name; let stack = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) focus_stack in { sigma; goals; entry; stack; shelf; given_up; initial_euctx; name; poly } + +let pr_proof p = + let { goals=fg_goals; stack=bg_goals; shelf; given_up; _ } = data p in + Pp.( + let pr_goal_list = prlist_with_sep spc Goal.pr_goal in + let rec aux acc = function + | [] -> acc + | (before,after)::stack -> + aux (pr_goal_list before ++ spc () ++ str "{" ++ acc ++ str "}" ++ spc () ++ + pr_goal_list after) stack in + str "[" ++ str "focus structure: " ++ + aux (pr_goal_list fg_goals) bg_goals ++ str ";" ++ spc () ++ + str "shelved: " ++ pr_goal_list shelf ++ str ";" ++ spc () ++ + str "given up: " ++ pr_goal_list given_up ++ + str "]" + ) diff --git a/proofs/proof.mli b/proofs/proof.mli index defef57a8d..1f4748141a 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -34,30 +34,6 @@ (* Type of a proof. *) type t -(* Returns a stylised view of a proof for use by, for instance, - ide-s. *) -(* spiwack: the type of [proof] will change as we push more refined - functions to ide-s. This would be better than spawning a new nearly - identical function everytime. Hence the generic name. *) -(* In this version: returns the focused goals, a representation of the - focus stack (the goals at each level), a representation of the - shelf (the list of goals on the shelf), a representation of the - given up goals (the list of the given up goals) and the underlying - evar_map *) -val proof : t -> - Goal.goal list - * (Goal.goal list * Goal.goal list) list - * Goal.goal list - * Goal.goal list - * Evd.evar_map -[@@ocaml.deprecated "use [Proof.data]"] - -val initial_goals : t -> (EConstr.constr * EConstr.types) list -[@@ocaml.deprecated "use [Proof.data]"] - -val initial_euctx : t -> UState.t -[@@ocaml.deprecated "use [Proof.data]"] - type data = { sigma : Evd.evar_map (** A representation of the evar_map [EJGA wouldn't it better to just return the proofview?] *) @@ -81,29 +57,6 @@ type data = val data : t -> data -(* Generic records structured like the return type of proof *) -type 'a pre_goals = { - fg_goals : 'a list; - [@ocaml.deprecated "use [Proof.data]"] - (** List of the focussed goals *) - bg_goals : ('a list * 'a list) list; - [@ocaml.deprecated "use [Proof.data]"] - (** Zipper representing the unfocussed background goals *) - shelved_goals : 'a list; - [@ocaml.deprecated "use [Proof.data]"] - (** List of the goals on the shelf. *) - given_up_goals : 'a list; - [@ocaml.deprecated "use [Proof.data]"] - (** List of the goals that have been given up *) -} -[@@ocaml.deprecated "use [Proof.data]"] - -(* needed in OCaml 4.05.0, not needed in newer ones *) -[@@@ocaml.warning "-3"] -val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) [@ocaml.warning "-3"] -[@@ocaml.deprecated "use [Proof.data]"] -[@@@ocaml.warning "+3"] - (*** General proof functions ***) val start : name:Names.Id.t diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 7b3d9e534b..93031c2202 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -104,10 +104,6 @@ let db_pr_goal sigma g = let pr_gls gls = hov 0 (pr_evar_map (Some 2) (pf_env gls) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) -let pr_glls glls = - hov 0 (pr_evar_map (Some 2) (Global.env()) (sig_sig glls) ++ fnl () ++ - prlist_with_sep fnl (db_pr_goal (project glls)) (sig_it glls)) - (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 218011c316..23e1e6f566 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -68,8 +68,6 @@ val pf_conv_x_leq : Goal.goal sigma -> constr -> constr -> bool (** {6 Pretty-printing functions (debug only). } *) val pr_gls : Goal.goal sigma -> Pp.t -val pr_glls : Goal.goal list sigma -> Pp.t -[@@ocaml.deprecated "Please move to \"new\" proof engine"] (** Variants of [Tacmach] functions built with the new proof engine *) module New : sig diff --git a/tactics/ppred.mli b/tactics/ppred.mli index be21236f4e..c68fab5296 100644 --- a/tactics/ppred.mli +++ b/tactics/ppred.mli @@ -6,11 +6,6 @@ val pr_with_occurrences : val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> - (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t - [@@ocaml.deprecated "Use pr_red_expr_env instead"] - val pr_red_expr_env : Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 9a18baa0bc..ec43dbb1d7 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -184,10 +184,6 @@ let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") -let warn_deprecated_boot = - CWarnings.create ~name:"deprecated-boot" ~category:"noop" - (fun () -> Pp.strbrk "The -boot option is deprecated, please use -q and/or -coqlib options instead.") - let set_inputstate opts s = warn_deprecated_inputstate (); { opts with inputstate = Some s } @@ -488,9 +484,6 @@ let parse_args ~help ~init arglist : t * string list = { oval with batch = true } |"-test-mode" -> Vernacentries.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-boot" -> - warn_deprecated_boot (); - { oval with load_rcfile = false; } |"-bt" -> Backtrace.record_backtrace true; oval |"-color" -> set_color oval (next ()) |"-config"|"--config" -> { oval with print_config = true } diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 9323a57417..b769405cf6 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -271,31 +271,6 @@ let init_toploop opts = let state = { doc; sid; proof = None; time = opts.time } in Ccompile.load_init_vernaculars opts ~state, opts -(* To remove in 8.11 *) -let call_coqc args = - let remove str arr = Array.(of_list List.(filter (fun l -> not String.(equal l str)) (to_list arr))) in - let coqc_name = Filename.remove_extension (System.get_toplevel_path "coqc") in - let args = remove "-compile" args in - Unix.execv coqc_name args - -let deprecated_coqc_warning = CWarnings.(create - ~name:"deprecate-compile-arg" - ~category:"toplevel" - ~default:Enabled - (fun opt_name -> Pp.(seq [str "The option "; str opt_name; str" is deprecated, please use coqc."]))) - -let rec coqc_deprecated_check args acc extras = - match extras with - | [] -> acc - | "-o" :: _ :: rem -> - deprecated_coqc_warning "-o"; - coqc_deprecated_check args acc rem - | ("-compile"|"-compile-verbose") :: file :: rem -> - deprecated_coqc_warning "-compile"; - call_coqc args - | x :: rem -> - coqc_deprecated_check args (x::acc) rem - let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); @@ -317,7 +292,6 @@ let start_coq custom = init_toplevel ~help:Usage.print_usage_coqtop ~init:default custom.init (List.tl (Array.to_list Sys.argv)) in - let extras = coqc_deprecated_check Sys.argv [] extras in if not (CList.is_empty extras) then begin prerr_endline ("Don't know what to do with "^String.concat " " extras); prerr_endline "See -help for the list of supported options"; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 7074215afe..da2094653b 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -102,12 +102,6 @@ let print_usage_coqtop () = coqtop specific options:\ \n\ \n -batch batch mode (exits just after argument parsing)\ -\n\ -\nDeprecated options [use coqc instead]:\ -\n\ -\n -compile f.v compile Coq file f.v (implies -batch)\ -\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ -\n -o f.vo use f.vo as the output file name\ \n"; flush stderr ; exit 1 @@ -128,14 +122,6 @@ coqc specific options:\ \nUndocumented:\ \n -vio2vo [see manual]\ \n -check-vio-tasks [see manual]\ -\n\ -\nDeprecated options:\ -\n\ -\n -image f specify an alternative executable for Coq\ -\n -opt run the native-code version of Coq\ -\n -byte run the bytecode version of Coq\ -\n -t keep temporary files\ -\n -outputstate file save summary state in file \ \n"; flush stderr ; exit 1 diff --git a/vernac/himsg.ml b/vernac/himsg.ml index f58eeae6dc..b2382ce6fc 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1348,9 +1348,6 @@ let explain_pattern_matching_error env sigma = function | CannotInferPredicate typs -> explain_cannot_infer_predicate env sigma typs -let map_pguard_error = map_pguard_error -let map_ptype_error = map_ptype_error - let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) -> let e = map_ptype_error EConstr.of_constr e in diff --git a/vernac/himsg.mli b/vernac/himsg.mli index d0f42ea16b..d1c1c092e3 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -43,9 +43,4 @@ val explain_module_error : Modops.module_typing_error -> Pp.t val explain_module_internalization_error : Modintern.module_internalization_error -> Pp.t -val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error -[@@ocaml.deprecated "Use [Type_errors.map_pguard_error]."] -val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error -[@@ocaml.deprecated "Use [Type_errors.map_ptype_error]."] - val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t -- cgit v1.2.3 From c12c4a01e46aacb97ea3d34047a10d17630baba4 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Sat, 4 May 2019 15:49:15 +0200 Subject: CI: run coqchk without -silent Since it's in its own job it won't pollute the log, and that way if some issue happens it will be easier to tell what's going on. I split the find and coqchk commands again as it's a bit confusing to parenthesize the pipe and `|| touch` otherwise. --- .gitlab-ci.yml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e4815920ce..9e96d3602b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -169,7 +169,15 @@ before_script: - not-a-real-job script: - cd _install_ci - - find lib/coq/ -name '*.vo' -print0 | xargs -0 bin/coqchk -silent -o -m -coqlib lib/coq/ + - find lib/coq/ -name '*.vo' -fprint0 vofiles + - xargs -0 --arg-file=vofiles bin/coqchk -o -m -coqlib lib/coq/ > ../coqchk.log 2>&1 || touch coqchk.failed + - tail -n 1000 ../coqchk.log # the log is too big for gitlab so pipe to a file and display the tail + - "[ ! -f coqchk.failed ]" # needs quoting for yml syntax reasons + artifacts: + name: "$CI_JOB_NAME.logs" + paths: + - coqchk.log + expire_in: 1 month .ci-template: stage: test -- cgit v1.2.3 From 857082b492760c17bfbc2b2022862c7cd758261e Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 2 May 2019 21:28:47 +0200 Subject: Remove various circumvolutions from reduction behaviors Incidentally, this fixes #10056 --- pretyping/reductionops.ml | 249 +++++++++++++++---------------- pretyping/reductionops.mli | 11 +- pretyping/tacred.ml | 85 +++++++---- test-suite/output/Arguments.out | 24 ++- test-suite/output/Arguments.v | 9 ++ test-suite/output/Arguments_renaming.out | 4 +- vernac/vernacentries.ml | 34 +++-- 7 files changed, 226 insertions(+), 190 deletions(-) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 120b4e6f00..85e6f51387 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -90,48 +90,43 @@ module ReductionBehaviour = struct open Names open Libobject - type t = { - b_nargs: int; - b_recargs: int list; - b_dont_expose_case: bool; - } + type t = NeverUnfold | UnfoldWhen of when_flags | UnfoldWhenNoMatch of when_flags + and when_flags = { recargs : int list ; nargs : int option } + + let more_args_when k { recargs; nargs } = + { nargs = Option.map ((+) k) nargs; + recargs = List.map ((+) k) recargs; + } + + let more_args k = function + | NeverUnfold -> NeverUnfold + | UnfoldWhen x -> UnfoldWhen (more_args_when k x) + | UnfoldWhenNoMatch x -> UnfoldWhenNoMatch (more_args_when k x) let table = Summary.ref (GlobRef.Map.empty : t GlobRef.Map.t) ~name:"reductionbehaviour" - type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] - type req = - | ReqLocal - | ReqGlobal of GlobRef.t * (int list * int * flag list) - let load _ (_,(_,(r, b))) = table := GlobRef.Map.add r b !table let cache o = load 1 o - let classify = function - | ReqLocal, _ -> Dispose - | ReqGlobal _, _ as o -> Substitute o + let classify (local,_ as o) = if local then Dispose else Substitute o - let subst (subst, (_, (r,o as orig))) = - ReqLocal, - let r' = fst (subst_global subst r) in if r==r' then orig else (r',o) + let subst (subst, (local, (r,o) as orig)) = + let r' = subst_global_reference subst r in if r==r' then orig + else (local,(r',o)) let discharge = function - | _,(ReqGlobal (ConstRef c as gr, req), (_, b)) -> + | _,(false, (gr, b)) -> let b = if Lib.is_in_section gr then let vars = Lib.variable_section_segment_of_reference gr in let extra = List.length vars in - let nargs' = - if b.b_nargs = max_int then max_int - else if b.b_nargs < 0 then b.b_nargs - else b.b_nargs + extra in - let recargs' = List.map ((+) extra) b.b_recargs in - { b with b_nargs = nargs'; b_recargs = recargs' } + more_args extra b else b in - Some (ReqGlobal (gr, req), (ConstRef c, b)) + Some (false, (gr, b)) | _ -> None let rebuild = function @@ -148,55 +143,45 @@ module ReductionBehaviour = struct rebuild_function = rebuild; } - let set local r (recargs, nargs, flags as req) = - let nargs = if List.mem `ReductionNeverUnfold flags then max_int else nargs in - let behaviour = { - b_nargs = nargs; b_recargs = recargs; - b_dont_expose_case = List.mem `ReductionDontExposeCase flags } in - let req = if local then ReqLocal else ReqGlobal (r, req) in - Lib.add_anonymous_leaf (inRedBehaviour (req, (r, behaviour))) - ;; + let set ~local r b = + Lib.add_anonymous_leaf (inRedBehaviour (local, (r, b))) - let get r = - try - let b = GlobRef.Map.find r !table in - let flags = - if Int.equal b.b_nargs max_int then [`ReductionNeverUnfold] - else if b.b_dont_expose_case then [`ReductionDontExposeCase] else [] in - Some (b.b_recargs, (if Int.equal b.b_nargs max_int then -1 else b.b_nargs), flags) - with Not_found -> None + let get r = GlobRef.Map.find_opt r !table let print ref = let open Pp in let pr_global = Nametab.pr_global_env Id.Set.empty in match get ref with | None -> mt () - | Some (recargs, nargs, flags) -> - let never = List.mem `ReductionNeverUnfold flags in - let nomatch = List.mem `ReductionDontExposeCase flags in - let pp_nomatch = spc() ++ if nomatch then - str "but avoid exposing match constructs" else str"" in - let pp_recargs = spc() ++ str "when the " ++ + | Some b -> + let pp_nomatch = spc () ++ str "but avoid exposing match constructs" in + let pp_recargs recargs = spc() ++ str "when the " ++ pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++ str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ str " to a constructor" in - let pp_nargs = - spc() ++ str "when applied to " ++ int nargs ++ - str (String.plural nargs " argument") in - hov 2 (str "The reduction tactics " ++ - match recargs, nargs, never with - | _,_, true -> str "never unfold " ++ pr_global ref - | [], 0, _ -> str "always unfold " ++ pr_global ref - | _::_, n, _ when n < 0 -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | _::_, n, _ when n > List.fold_left max 0 recargs -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ - str " and" ++ pp_nargs ++ pp_nomatch - | _::_, _, _ -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | [], n, _ when n > 0 -> - str "unfold " ++ pr_global ref ++ pp_nargs ++ pp_nomatch - | _ -> str "unfold " ++ pr_global ref ++ pp_nomatch ) + let pp_nargs nargs = + spc() ++ str "when applied to " ++ int nargs ++ + str (String.plural nargs " argument") in + let pp_when = function + | { recargs = []; nargs = Some 0 } -> + str "always unfold " ++ pr_global ref + | { recargs = []; nargs = Some n } -> + str "unfold " ++ pr_global ref ++ pp_nargs n + | { recargs = []; nargs = None } -> + str "unfold " ++ pr_global ref + | { recargs; nargs = Some n } when n > List.fold_left max 0 recargs -> + str "unfold " ++ pr_global ref ++ pp_recargs recargs ++ + str " and" ++ pp_nargs n + | { recargs; nargs = _ } -> + str "unfold " ++ pr_global ref ++ pp_recargs recargs + in + let pp_behavior = function + | NeverUnfold -> str "never unfold " ++ pr_global ref + | UnfoldWhen x -> pp_when x + | UnfoldWhenNoMatch x -> pp_when x ++ pp_nomatch + in + hov 2 (str "The reduction tactics " ++ pp_behavior b) + end (** Machinery about stack of unfolded constants *) @@ -928,6 +913,7 @@ let equal_stacks sigma (x, l) (y, l') = let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in + let open ReductionBehaviour in let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then let open Pp in @@ -974,37 +960,42 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else (* Looks for ReductionBehaviour *) match ReductionBehaviour.get (Globnames.ConstRef c) with | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < nargs)) - then fold () - else (* maybe unfolds *) - if List.mem `ReductionDontExposeCase flags then - let app_sk,sk = Stack.strip_app stack in - let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) - in - let rec is_case x = match EConstr.kind sigma x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if equal_stacks sigma (x, app_sk) (tm', sk') - || Stack.will_expose_iota sk' - || is_case tm' - then fold () - else whrec cst_l' (tm', sk' @ sk) - else match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) - whrec cst_l (body, stack) - |curr::remains -> match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') - end + | Some behavior -> + begin match behavior with + | NeverUnfold -> fold () + | (UnfoldWhen { nargs = Some n } | + UnfoldWhenNoMatch { nargs = Some n } ) + when Stack.args_size stack < n -> + fold () + | UnfoldWhenNoMatch { recargs } -> (* maybe unfolds *) + let app_sk,sk = Stack.strip_app stack in + let (tm',sk'),cst_l' = + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) + in + let rec is_case x = match EConstr.kind sigma x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if equal_stacks sigma (x, app_sk) (tm', sk') + || Stack.will_expose_iota sk' + || is_case tm' + then fold () + else whrec cst_l' (tm', sk' @ sk) + | UnfoldWhen { recargs } -> (* maybe unfolds *) + begin match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) + whrec cst_l (body, stack) + |curr::remains -> match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') + end + end + end | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> let kargs = CPrimitives.kind p in let (kargs,o) = Stack.get_next_primitive_args kargs stack in @@ -1015,41 +1006,45 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let npars = Projection.npars p in - if not tactic_mode then - let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in - whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with - | None -> + if not tactic_mode then + let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in + whrec Cst_stack.empty stack' + else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with + | None -> let stack' = (c, Stack.Proj (p, cst_l) :: stack) in - let stack'', csts = whrec Cst_stack.empty stack' in - if equal_stacks sigma stack' stack'' then fold () - else stack'', csts - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < (nargs - (npars + 1)))) - then fold () - else - let recargs = List.map_filter (fun x -> - let idx = x - npars in - if idx < 0 then None else Some idx) recargs - in - match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) + let stack'', csts = whrec Cst_stack.empty stack' in + if equal_stacks sigma stack' stack'' then fold () + else stack'', csts + | Some behavior -> + begin match behavior with + | NeverUnfold -> fold () + | (UnfoldWhen { nargs = Some n } + | UnfoldWhenNoMatch { nargs = Some n }) + when Stack.args_size stack < n - (npars + 1) -> fold () + | UnfoldWhen { recargs } + | UnfoldWhenNoMatch { recargs }-> (* maybe unfolds *) + let recargs = List.map_filter (fun x -> + let idx = x - npars in + if idx < 0 then None else Some idx) recargs + in + match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) let stack' = (c, Stack.Proj (p, cst_l) :: stack) in - whrec Cst_stack.empty(* cst_l *) stack' - | curr::remains -> - if curr == 0 then (* Try to reduce the record argument *) - whrec Cst_stack.empty - (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) - else - match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, - Stack.append_app [|c|] bef,cst_l)::s')) + whrec Cst_stack.empty(* cst_l *) stack' + | curr::remains -> + if curr == 0 then (* Try to reduce the record argument *) + whrec Cst_stack.empty + (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) + else + match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, + Stack.append_app [|c|] bef,cst_l)::s') + end) | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index b5d3ff7627..aa39921ea2 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -21,13 +21,12 @@ exception Elimconst (** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig - type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] -(** [set is_local ref (recargs, nargs, flags)] *) - val set : - bool -> GlobRef.t -> (int list * int * flag list) -> unit - val get : - GlobRef.t -> (int list * int * flag list) option + type t = NeverUnfold | UnfoldWhen of when_flags | UnfoldWhenNoMatch of when_flags + and when_flags = { recargs : int list ; nargs : int option } + + val set : local:bool -> GlobRef.t -> t -> unit + val get : GlobRef.t -> t option val print : GlobRef.t -> Pp.t end diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index bcc20a41b4..231219c9de 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -664,18 +664,38 @@ let whd_nothing_for_iota env sigma s = it fails if no redex is around *) let rec red_elim_const env sigma ref u largs = + let open ReductionBehaviour in let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim, nocase = match recargs ref with | None -> largs, false, false, false - | Some (_,n,f) when nargs < n || List.mem `ReductionNeverUnfold f -> raise Redelimination - | Some (x::l,_,_) when nargs <= List.fold_left max x l -> raise Redelimination - | Some (l,n,f) -> - let is_empty = match l with [] -> true | _ -> false in - reduce_params env sigma largs l, - n >= 0 && is_empty && nargs >= n, - n >= 0 && not is_empty && nargs >= n, - List.mem `ReductionDontExposeCase f + | Some NeverUnfold -> raise Redelimination + | Some (UnfoldWhen { nargs = Some n } | UnfoldWhenNoMatch { nargs = Some n }) + when nargs < n -> raise Redelimination + | Some (UnfoldWhen { recargs = x::l } | UnfoldWhenNoMatch { recargs = x::l }) + when nargs <= List.fold_left max x l -> raise Redelimination + | Some (UnfoldWhen { recargs; nargs = None }) -> + reduce_params env sigma largs recargs, + false, + false, + false + | Some (UnfoldWhenNoMatch { recargs; nargs = None }) -> + reduce_params env sigma largs recargs, + false, + false, + true + | Some (UnfoldWhen { recargs; nargs = Some n }) -> + let is_empty = List.is_empty recargs in + reduce_params env sigma largs recargs, + is_empty && nargs >= n, + not is_empty && nargs >= n, + false + | Some (UnfoldWhenNoMatch { recargs; nargs = Some n }) -> + let is_empty = List.is_empty recargs in + reduce_params env sigma largs recargs, + is_empty && nargs >= n, + not is_empty && nargs >= n, + true in try match reference_eval env sigma ref with | EliminationCases n when nargs >= n -> @@ -737,6 +757,7 @@ and reduce_params env sigma stack l = a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_stack env sigma = + let open ReductionBehaviour in let rec redrec s = let (x, stack) = decompose_app_vect sigma s in let stack = Array.to_list stack in @@ -761,30 +782,30 @@ and whd_simpl_stack env sigma = with Redelimination -> s') | Proj (p, c) -> - (try - let unf = Projection.unfolded p in - if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then - let npars = Projection.npars p in - (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with - | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> - (* simpl never *) s' - | false, Some (l, n, f) when not (List.is_empty l) -> - let l' = List.map_filter (fun i -> - let idx = (i - (npars + 1)) in - if idx < 0 then None else Some idx) l in - let stack = reduce_params env sigma stack l' in - (match reduce_projection env sigma p ~npars - (whd_construct_stack env sigma c) stack - with - | Reduced s' -> redrec (applist s') - | NotReducible -> s') - | _ -> - match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with - | Reduced s' -> redrec (applist s') - | NotReducible -> s') - else s' - with Redelimination -> s') - + (try + let unf = Projection.unfolded p in + if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then + let npars = Projection.npars p in + (match unf, get (ConstRef (Projection.constant p)) with + | false, Some NeverUnfold -> s' + | false, Some (UnfoldWhen { recargs } | UnfoldWhenNoMatch { recargs }) + when not (List.is_empty recargs) -> + let l' = List.map_filter (fun i -> + let idx = (i - (npars + 1)) in + if idx < 0 then None else Some idx) recargs in + let stack = reduce_params env sigma stack l' in + (match reduce_projection env sigma p ~npars + (whd_construct_stack env sigma c) stack + with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + | _ -> + match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + else s' + with Redelimination -> s') + | _ -> match match_eval_ref env sigma x stack with | Some (ref, u) -> diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 7074ad2d41..3c1e27ba9d 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -27,7 +27,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and - 2nd arguments evaluate to a constructor and when applied to 2 arguments + 2nd arguments evaluate to a constructor and when applied to 2 arguments Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat @@ -35,7 +35,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and - 2nd arguments evaluate to a constructor + 2nd arguments evaluate to a constructor Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub pf : @@ -54,7 +54,7 @@ fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] -The reduction tactics unfold fcomp when applied to 6 arguments +The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Arguments.fcomp volatile : nat -> nat @@ -75,7 +75,7 @@ f : T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 3rd, 4th and - 5th arguments evaluate to a constructor + 5th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat @@ -84,7 +84,7 @@ f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 4th, 5th and - 6th arguments evaluate to a constructor + 6th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat @@ -93,7 +93,7 @@ f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 5th, 6th and - 7th arguments evaluate to a constructor + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.f = forall v : unit, f 0 0 5 v 3 = 2 @@ -104,7 +104,7 @@ f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic The reduction tactics unfold f when the 5th, 6th and - 7th arguments evaluate to a constructor + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.f forall w : r, w 3 true = tt @@ -115,3 +115,13 @@ w 3 true = tt : Prop The command has indeed failed with message: Extra arguments: _, _. +volatilematch : nat -> nat + +volatilematch is not universe polymorphic +Argument scope is [nat_scope] +The reduction tactics always unfold volatilematch + but avoid exposing match constructs +volatilematch is transparent +Expands to: Constant Arguments.volatilematch + = fun n : nat => volatilematch n + : nat -> nat diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 844f96aaa1..b909f1b64c 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -55,3 +55,12 @@ Arguments w x%F y%B : extra scopes. Check (w $ $ = tt). Fail Arguments w _%F _%B. +Definition volatilematch (n : nat) := + match n with + | O => O + | S p => p + end. + +Arguments volatilematch / n : simpl nomatch. +About volatilematch. +Eval simpl in fun n => volatilematch n. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 3f0717666c..65c902202d 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -62,7 +62,7 @@ Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The reduction tactics unfold myplus when the 2nd and - 3rd arguments evaluate to a constructor + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Arguments_renaming.Test1.myplus @myplus @@ -101,7 +101,7 @@ Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The reduction tactics unfold myplus when the 2nd and - 3rd arguments evaluate to a constructor + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Arguments_renaming.myplus @myplus diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 388f6957cf..279d4f0935 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1231,16 +1231,13 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let clear_implicits_flag = List.mem `ClearImplicits flags in let default_implicits_flag = List.mem `DefaultImplicits flags in let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + let nomatch_flag = List.mem `ReductionDontExposeCase flags in let err_incompat x y = user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in if assert_flag && rename_flag then err_incompat "assert" "rename"; - if Option.has_some nargs_for_red && never_unfold_flag then - err_incompat "simpl never" "/"; - if never_unfold_flag && List.mem `ReductionDontExposeCase flags then - err_incompat "simpl never" "simpl nomatch"; if clear_scopes_flag && extra_scopes_flag then err_incompat "clear scopes" "extra scopes"; if clear_implicits_flag && default_implicits_flag then @@ -1385,19 +1382,24 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) in - let rec narrow = function - | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl - | [] -> [] | _ :: tl -> narrow tl - in - let red_flags = narrow flags in - let red_modifiers_specified = - not (List.is_empty rargs) || Option.has_some nargs_for_red - || not (List.is_empty red_flags) + let red_behavior = + let open Reductionops.ReductionBehaviour in + match never_unfold_flag, nomatch_flag, rargs, nargs_for_red with + | true, false, [], None -> Some NeverUnfold + | true, true, _, _ -> err_incompat "simpl never" "simpl nomatch" + | true, _, _::_, _ -> err_incompat "simpl never" "!" + | true, _, _, Some _ -> err_incompat "simpl never" "/" + | false, false, [], None -> None + | false, false, _, _ -> Some (UnfoldWhen { nargs = nargs_for_red; + recargs = rargs; + }) + | false, true, _, _ -> Some (UnfoldWhenNoMatch { nargs = nargs_for_red; + recargs = rargs; + }) in - if not (List.is_empty rargs) && never_unfold_flag then - err_incompat "simpl never" "!"; + let red_modifiers_specified = Option.has_some red_behavior in (* Actions *) @@ -1424,8 +1426,8 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - section_local c - (rargs, Option.default ~-1 nargs_for_red, red_flags) + ~local:section_local c (Option.get red_behavior) + | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ strbrk "are relevant for constants only.") -- cgit v1.2.3 From 067dc98d6395b5041680aa137909d9d5519908c9 Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Sat, 19 Jan 2019 16:22:12 -0800 Subject: Simplify dispose_implicits --- interp/impargs.ml | 35 ++++++++++------------------------- 1 file changed, 10 insertions(+), 25 deletions(-) diff --git a/interp/impargs.ml b/interp/impargs.ml index d83a0ce918..6a0fa6f238 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -554,31 +554,16 @@ let add_section_impls vars extra_impls (cond,impls) = let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None - | ImplInteractive (ref,flags,exp) -> - (try - let vars = variable_section_segment_of_reference ref in - let extra_impls = impls_of_context vars in - let l' = [ref, List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in - Some (ImplInteractive (ref,flags,exp),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) - | ImplConstant (con,flags) -> - (try - let vars = variable_section_segment_of_reference (ConstRef con) in - let extra_impls = impls_of_context vars in - let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in - let l' = [ConstRef con,newimpls] in - Some (ImplConstant (con,flags),l') - with Not_found -> (* con not defined in this section *) Some (req,l)) - | ImplMutualInductive (kn,flags) -> - (try - let l' = List.map (fun (gr, l) -> - let vars = variable_section_segment_of_reference gr in - let extra_impls = impls_of_context vars in - (gr, - List.map (add_section_impls vars extra_impls) l)) l - in - Some (ImplMutualInductive (kn,flags),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) + | ImplMutualInductive _ | ImplInteractive _ | ImplConstant _ -> + let l' = + try + List.map (fun (gr, l) -> + let vars = variable_section_segment_of_reference gr in + let extra_impls = impls_of_context vars in + let newimpls = List.map (add_section_impls vars extra_impls) l in + (gr, newimpls)) l + with Not_found -> l in + Some (req,l') let rebuild_implicits (req,l) = match req with -- cgit v1.2.3 From 2c94706d810e371a416b8c2893eb88c40a09b75c Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Sat, 19 Jan 2019 20:41:24 -0800 Subject: Remove ref from some implicit_discharge_request --- interp/impargs.ml | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/interp/impargs.ml b/interp/impargs.ml index 6a0fa6f238..cb0f561c4c 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -499,9 +499,9 @@ type implicit_interactive_request = type implicit_discharge_request = | ImplLocal - | ImplConstant of Constant.t * implicits_flags + | ImplConstant of implicits_flags | ImplMutualInductive of MutInd.t * implicits_flags - | ImplInteractive of GlobRef.t * implicits_flags * + | ImplInteractive of implicits_flags * implicit_interactive_request let implicits_table = Summary.ref GlobRef.Map.empty ~name:"implicits" @@ -568,10 +568,10 @@ let discharge_implicits (_,(req,l)) = let rebuild_implicits (req,l) = match req with | ImplLocal -> assert false - | ImplConstant (con,flags) -> - let oldimpls = snd (List.hd l) in - let newimpls = compute_constant_implicits flags con in - req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] + | ImplConstant flags -> + let ref,oldimpls = List.hd l in + let newimpls = compute_global_implicits flags ref in + req, [ref, List.map2 merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags kn in let rec aux olds news = @@ -582,15 +582,14 @@ let rebuild_implicits (req,l) = | _, _ -> assert false in req, aux l newimpls - | ImplInteractive (ref,flags,o) -> + | ImplInteractive (flags,o) -> + let ref,oldimpls = List.hd l in (if isVarRef ref && is_in_section ref then ImplLocal else req), match o with | ImplAuto -> - let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags ref in [ref,List.map2 merge_impls oldimpls newimpls] | ImplManual userimplsize -> - let oldimpls = snd (List.hd l) in if flags.auto then let newimpls = List.hd (compute_global_implicits flags ref) in let p = List.length (snd newimpls) - userimplsize in @@ -625,7 +624,7 @@ let declare_implicits_gen req flags ref = let declare_implicits local ref = let flags = { !implicit_args with auto = true } in let req = - if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in + if is_local local ref then ImplLocal else ImplInteractive(flags,ImplAuto) in declare_implicits_gen req flags ref let declare_var_implicits id = @@ -634,7 +633,7 @@ let declare_var_implicits id = let declare_constant_implicits con = let flags = !implicit_args in - declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) + declare_implicits_gen (ImplConstant flags) flags (ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in @@ -684,7 +683,7 @@ let declare_manual_implicits local ref ?enriching l = let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l])) let maybe_declare_manual_implicits local ref ?enriching l = @@ -743,7 +742,7 @@ let set_implicits local ref l = compute_implicit_statuses autoimpls imps)) l in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) let extract_impargs_data impls = -- cgit v1.2.3 From 4785156d31eb513b6e7fcb8dbab1c219da83612b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 24 Apr 2019 15:42:45 +0200 Subject: Cleanup of Logic.convert_hyp. --- proofs/logic.ml | 40 ++++++++++++++++------------------------ 1 file changed, 16 insertions(+), 24 deletions(-) diff --git a/proofs/logic.ml b/proofs/logic.ml index a01ddf2388..f51f2ea5bc 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -78,14 +78,6 @@ let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoS let check = ref false let with_check = Flags.with_option check -(* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and - returns [tail::(f head (id,_,_) (rev tail))] *) -let apply_to_hyp env sigma check sign id f = - try apply_to_hyp sign id f - with Hyp_not_found -> - if check then error_no_such_hypothesis env sigma id - else sign - let check_typability env sigma c = if !check then let _ = unsafe_type_of env sigma (EConstr.of_constr c) in () @@ -559,22 +551,22 @@ and treat_case sigma goal ci lbrty lf acc' = let convert_hyp check sign sigma d = let id = NamedDecl.get_id d in let b = NamedDecl.get_value d in - let env = Global.env () in - let reorder = ref [] in - let sign' = - apply_to_hyp env sigma check sign id - (fun _ d' _ -> - let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in - let env = Global.env_of_context sign in - if check && not (is_conv env sigma (NamedDecl.get_type d) (EConstr.of_constr (NamedDecl.get_type d'))) then - user_err ~hdr:"Logic.convert_hyp" - (str "Incorrect change of the type of " ++ Id.print id ++ str "."); - if check && not (Option.equal (is_conv env sigma) b c) then - user_err ~hdr:"Logic.convert_hyp" - (str "Incorrect change of the body of "++ Id.print id ++ str "."); - if check then reorder := check_decl_position env sigma sign d; - map_named_decl EConstr.Unsafe.to_constr d) in - reorder_val_context env sigma sign' !reorder + let env = Global.env_of_context sign in + match lookup_named_ctxt id sign with + | exception Not_found -> + if check then error_no_such_hypothesis env sigma id + else sign + | d' -> + let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in + if check && not (is_conv env sigma (NamedDecl.get_type d) (EConstr.of_constr (NamedDecl.get_type d'))) then + user_err ~hdr:"Logic.convert_hyp" + (str "Incorrect change of the type of " ++ Id.print id ++ str "."); + if check && not (Option.equal (is_conv env sigma) b c) then + user_err ~hdr:"Logic.convert_hyp" + (str "Incorrect change of the body of "++ Id.print id ++ str "."); + let sign' = apply_to_hyp sign id (fun _ _ _ -> EConstr.Unsafe.to_named_decl d) in + if check then reorder_val_context env sigma sign' (check_decl_position env sigma sign d) + else sign' (************************************************************************) (************************************************************************) -- cgit v1.2.3 From a5a89e8b623cd5822f59b854a45efc8236ae0087 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 24 Apr 2019 16:03:06 +0200 Subject: Logic.convert_hyp now takes an environment as an argument. This prevents having to call global functions, for no good reason. We also seize the opportunity to name the check argument. --- proofs/logic.ml | 4 ++-- proofs/logic.mli | 2 +- tactics/tactics.ml | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/proofs/logic.ml b/proofs/logic.ml index f51f2ea5bc..3fcde56e76 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -548,10 +548,10 @@ and treat_case sigma goal ci lbrty lf acc' = (lacc,sigma,fi::bacc)) (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags -let convert_hyp check sign sigma d = +let convert_hyp ~check env sigma d = let id = NamedDecl.get_id d in let b = NamedDecl.get_value d in - let env = Global.env_of_context sign in + let sign = Environ.named_context_val env in match lookup_named_ctxt id sign with | exception Not_found -> if check then error_no_such_hypothesis env sigma id diff --git a/proofs/logic.mli b/proofs/logic.mli index f99076db23..163d71f69c 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -62,7 +62,7 @@ type 'id move_location = val pr_move_location : ('a -> Pp.t) -> 'a move_location -> Pp.t -val convert_hyp : bool -> Environ.named_context_val -> evar_map -> +val convert_hyp : check:bool -> Environ.env -> evar_map -> EConstr.named_declaration -> Environ.named_context_val val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t move_location -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5e8869f9b0..5a19f95f90 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -168,7 +168,7 @@ let convert_hyp ?(check=true) d = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in - let sign = convert_hyp check (named_context_val env) sigma d in + let sign = convert_hyp ~check env sigma d in let env = reset_with_named_context sign env in Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ty @@ -728,7 +728,7 @@ let e_change_in_hyps ?(check=true) f args = raise (RefinerError (env, sigma, NoSuchHyp id)) in let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in - let sign = Logic.convert_hyp check (named_context_val env) sigma d in + let sign = Logic.convert_hyp ~check env sigma d in let env = reset_with_named_context sign env in (env, sigma) in -- cgit v1.2.3 From f7c55014aabb0d607449868e2522515db0b40568 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 1 May 2019 17:00:55 +0200 Subject: Make the check flag of conversion functions mandatory. The current situation is a mess, some functions set it by default, but other no. Making it mandatory ensures that the expected value is the correct one. --- plugins/funind/recdef.ml | 2 +- plugins/ltac/rewrite.ml | 4 +-- plugins/setoid_ring/newring.ml | 4 +-- plugins/ssr/ssrcommon.ml | 12 +++---- plugins/ssr/ssrcommon.mli | 2 +- plugins/ssr/ssrequality.ml | 10 +++--- plugins/ssr/ssrfwd.ml | 6 ++-- plugins/ssrmatching/ssrmatching.ml | 2 +- tactics/eauto.ml | 2 +- tactics/equality.ml | 4 +-- tactics/tactics.ml | 72 +++++++++++++++++++------------------- tactics/tactics.mli | 18 +++++----- user-contrib/Ltac2/tac2tactics.ml | 2 +- 13 files changed, 70 insertions(+), 70 deletions(-) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 3c2b03dfe0..3dd3a430e8 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -701,7 +701,7 @@ let mkDestructEq : let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in - Proofview.V82.of_tactic (change_in_concl None changefun) g2); + Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 99a9c1ab9a..355c16bfd0 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1574,8 +1574,8 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (* For compatibility *) - let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in + let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp ~check:false Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 3f69701bd3..b02b97f656 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -89,10 +89,10 @@ let protect_red map env sigma c0 = EConstr.of_constr (eval 0 c) let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) None let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) (****************************************************************************) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index a4caeb403c..56f17703ff 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -427,7 +427,7 @@ let mk_anon_id t gl_ids = Id.of_string_soft (Bytes.to_string (loop (n - 1))) let convert_concl_no_check t = Tactics.convert_concl ~check:false t DEFAULTcast -let convert_concl t = Tactics.convert_concl t DEFAULTcast +let convert_concl ~check t = Tactics.convert_concl ~check t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with @@ -799,7 +799,7 @@ let discharge_hyp (id', (id, mode)) gl = | NamedDecl.LocalDef (_, v, t), _ -> let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in Proofview.V82.of_tactic - (convert_concl (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl + (convert_concl ~check:true (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl (* wildcard names *) let clear_wilds wilds gl = @@ -1170,7 +1170,7 @@ let gentac gen gl = ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); let gl = pf_merge_uc ucst gl in if conv - then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (old_cleartac clr) gl + then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl else genclrtac cl [c] clr gl let genstac (gens, clr) = @@ -1215,7 +1215,7 @@ let unprotecttac gl = let prot, _ = EConstr.destConst (project gl) c in Tacticals.onClause (fun idopt -> let hyploc = Option.map (fun id -> id, InHyp) idopt in - Proofview.V82.of_tactic (Tactics.reduct_option + Proofview.V82.of_tactic (Tactics.reduct_option ~check:false (Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA; @@ -1282,10 +1282,10 @@ let clr_of_wgen gen clrs = match gen with | clr, _ -> old_cleartac clr :: clrs -let reduct_in_concl t = Tactics.reduct_in_concl (t, DEFAULTcast) +let reduct_in_concl ~check t = Tactics.reduct_in_concl ~check (t, DEFAULTcast) let unfold cl = let module R = Reductionops in let module F = CClosure.RedFlags in - reduct_in_concl (R.clos_norm_flags (F.mkflags + reduct_in_concl ~check:false (R.clos_norm_flags (F.mkflags (List.map (fun c -> F.fCONST (fst (destConst (EConstr.Unsafe.to_constr c)))) cl @ [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 58ce84ecb3..575f016014 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -252,7 +252,7 @@ val ssrevaltac : Tacinterp.interp_sign -> Tacinterp.Value.t -> unit Proofview.tactic val convert_concl_no_check : EConstr.t -> unit Proofview.tactic -val convert_concl : EConstr.t -> unit Proofview.tactic +val convert_concl : check:bool -> EConstr.t -> unit Proofview.tactic val red_safe : Reductionops.reduction_function -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ad20113320..e349031952 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -118,7 +118,7 @@ let newssrcongrtac arg ist gl = match try Some (pf_unify_HO gl_c (pf_concl gl) c) with exn when CErrors.noncritical exn -> None with | Some gl_c -> - tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true (fs gl_c c))) (t_ok (proj gl_c)) gl | None -> t_fail () gl in let mk_evar gl ty = @@ -276,7 +276,7 @@ let unfoldintac occ rdx t (kt,_) gl = try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl concl) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl) gl ;; let foldtac occ rdx ft gl = @@ -303,7 +303,7 @@ let foldtac occ rdx ft gl = let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl (EConstr.of_constr concl)) gl + Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.of_constr concl)) gl ;; let converse_dir = function L2R -> R2L | R2L -> L2R @@ -406,7 +406,7 @@ let rwcltac ?under ?map_redex cl rdx dir sr gl = let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in - Proofview.V82.of_tactic (convert_concl cl'), rewritetac ?under dir r', gl + Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl else let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = @@ -644,7 +644,7 @@ let unfoldtac occ ko t kt gl = let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic - (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + (convert_concl ~check:true (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl let unlocktac ist args gl = let utac (occ, gt) gl = diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 01d71aa96a..4d4400a0f8 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -56,7 +56,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in - Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl')) (introid id) gl open Util @@ -161,7 +161,7 @@ let havetac ist let gl, ty = pfe_type_of gl t in let ctx, _ = EConstr.decompose_prod_n_assum (project gl) 1 ty in let assert_is_conv gl = - try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl + try Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c @@ -471,7 +471,7 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = if hint = nohint then Proofview.tclUNIT () else - let betaiota = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in + let betaiota = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in (* Usefulness of check_numgoals: tclDISPATCH would be enough, except for the error message w.r.t. the number of provided/expected tactics, as the last one is implied *) diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1deb935d5c..4e0866a0c5 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -1299,7 +1299,7 @@ let ssrpatterntac _ist arg gl = let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) let () = diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 70854e6e3c..0857c05968 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -514,7 +514,7 @@ let autounfold_one db cl = in if did then match cl with - | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | Some hyp -> change_in_hyp ~check:true None (make_change_arg c') hyp | None -> convert_concl ~check:false c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end diff --git a/tactics/equality.ml b/tactics/equality.ml index 3d760f1c3d..f049f8c568 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1613,10 +1613,10 @@ let cutSubstInHyp l2r eqn id = tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENFIRST (tclTHENLIST [ - (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); + (change_in_hyp ~check:true None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) - (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))) + (change_in_hyp ~check:true None (make_change_arg expected) (id,InHypTypeOnly))) end let try_rewrite tac = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5a19f95f90..78e7ce2321 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -145,7 +145,7 @@ let introduction id = let error msg = CErrors.user_err Pp.(str msg) -let convert_concl ?(check=true) ty k = +let convert_concl ~check ty k = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let conclty = Proofview.Goal.concl gl in @@ -163,7 +163,7 @@ let convert_concl ?(check=true) ty k = end end -let convert_hyp ?(check=true) d = +let convert_hyp ~check d = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -701,7 +701,7 @@ let bind_red_expr_occurrences occs nbcl redexp = (** Tactic reduction modulo evars (for universes essentially) *) -let e_change_in_concl ?(check = false) (redfun, sty) = +let e_change_in_concl ~check (redfun, sty) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in @@ -709,7 +709,7 @@ let e_change_in_concl ?(check = false) (redfun, sty) = (convert_concl ~check c' sty) end -let e_change_in_hyp ?(check = false) redfun (id,where) = +let e_change_in_hyp ~check redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id gl in @@ -718,7 +718,7 @@ let e_change_in_hyp ?(check = false) redfun (id,where) = (convert_hyp ~check c) end -let e_change_in_hyps ?(check=true) f args = +let e_change_in_hyps ~check f args = Proofview.Goal.enter begin fun gl -> let fold (env, sigma) arg = let (redfun, id, where) = f arg in @@ -745,26 +745,26 @@ let e_change_in_hyps ?(check=true) f args = let e_reduct_in_concl = e_change_in_concl -let reduct_in_concl ?(check = false) (redfun, sty) = +let reduct_in_concl ~check (redfun, sty) = let redfun env sigma c = (sigma, redfun env sigma c) in e_change_in_concl ~check (redfun, sty) -let e_reduct_in_hyp ?(check=false) redfun (id, where) = +let e_reduct_in_hyp ~check redfun (id, where) = let redfun _ env sigma c = redfun env sigma c in e_change_in_hyp ~check redfun (id, where) -let reduct_in_hyp ?(check = false) redfun (id, where) = +let reduct_in_hyp ~check redfun (id, where) = let redfun _ env sigma c = (sigma, redfun env sigma c) in e_change_in_hyp ~check redfun (id, where) let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r -let e_reduct_option ?(check=false) redfun = function +let e_reduct_option ~check redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id | None -> e_change_in_concl ~check (revert_cast redfun) -let reduct_option ?(check = false) (redfun, sty) where = +let reduct_option ~check (redfun, sty) where = let redfun env sigma c = (sigma, redfun env sigma c) in e_reduct_option ~check (redfun, sty) where @@ -802,7 +802,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = | Some sigma -> (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm check cv_pb deep t where env sigma c = +let change_on_subterm ~check cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in let (sigma, c) = match where with | None -> @@ -825,15 +825,15 @@ let change_on_subterm check cv_pb deep t where env sigma c = end; (sigma, c) -let change_in_concl ?(check=true) occl t = +let change_in_concl ~check occl t = (* No need to check in e_change_in_concl, the check is done in change_on_subterm *) - e_change_in_concl ~check:false ((change_on_subterm check Reduction.CUMUL false t occl),DEFAULTcast) + e_change_in_concl ~check:false ((change_on_subterm ~check Reduction.CUMUL false t occl),DEFAULTcast) -let change_in_hyp ?(check=true) occl t id = +let change_in_hyp ~check occl t id = (* FIXME: we set the [check] flag only to reorder hypotheses in case of introduction of dependencies in new variables. We should separate this check from the conversion function. *) - e_change_in_hyp ~check (fun x -> change_on_subterm check Reduction.CONV x t occl) id + e_change_in_hyp ~check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -842,7 +842,7 @@ let concrete_clause_of enum_hyps cl = match cl.onhyps with | Some l -> List.map (fun ((occs, id), w) -> (id, occs, w)) l -let change ?(check=true) chg c cls = +let change ~check chg c cls = Proofview.Goal.enter begin fun gl -> let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in begin match cls.concl_occs with @@ -852,7 +852,7 @@ let change ?(check=true) chg c cls = <*> let f (id, occs, where) = let occl = bind_change_occurrences occs chg in - let redfun deep env sigma t = change_on_subterm check Reduction.CONV deep c occl env sigma t in + let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in e_change_in_hyps ~check f hyps @@ -862,23 +862,23 @@ let change_concl t = change_in_concl ~check:true None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) -let red_in_concl = reduct_in_concl (red_product,REVERTcast) -let red_in_hyp = reduct_in_hyp red_product -let red_option = reduct_option (red_product,REVERTcast) -let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) -let hnf_in_hyp = reduct_in_hyp hnf_constr -let hnf_option = reduct_option (hnf_constr,REVERTcast) -let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) -let simpl_in_hyp = reduct_in_hyp simpl -let simpl_option = reduct_option (simpl,REVERTcast) -let normalise_in_concl = reduct_in_concl (compute,REVERTcast) -let normalise_in_hyp = reduct_in_hyp compute -let normalise_option = reduct_option (compute,REVERTcast) -let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) -let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) -let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) -let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) -let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) +let red_in_concl = reduct_in_concl ~check:false (red_product,REVERTcast) +let red_in_hyp = reduct_in_hyp ~check:false red_product +let red_option = reduct_option ~check:false (red_product,REVERTcast) +let hnf_in_concl = reduct_in_concl ~check:false (hnf_constr,REVERTcast) +let hnf_in_hyp = reduct_in_hyp ~check:false hnf_constr +let hnf_option = reduct_option ~check:false (hnf_constr,REVERTcast) +let simpl_in_concl = reduct_in_concl ~check:false (simpl,REVERTcast) +let simpl_in_hyp = reduct_in_hyp ~check:false simpl +let simpl_option = reduct_option ~check:false (simpl,REVERTcast) +let normalise_in_concl = reduct_in_concl ~check:false (compute,REVERTcast) +let normalise_in_hyp = reduct_in_hyp ~check:false compute +let normalise_option = reduct_option ~check:false (compute,REVERTcast) +let normalise_vm_in_concl = reduct_in_concl ~check:false (Redexpr.cbv_vm,VMcast) +let unfold_in_concl loccname = reduct_in_concl ~check:false (unfoldn loccname,REVERTcast) +let unfold_in_hyp loccname = reduct_in_hyp ~check:false (unfoldn loccname) +let unfold_option loccname = reduct_option ~check:false (unfoldn loccname,DEFAULTcast) +let pattern_option l = e_reduct_option ~check:false (pattern_occs l,DEFAULTcast) (* The main reduction function *) @@ -3061,8 +3061,8 @@ let unfold_body x = Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in - let reducth h = reduct_in_hyp rfun h in - let reductc = reduct_in_concl (rfun, DEFAULTcast) in + let reducth h = reduct_in_hyp ~check:false rfun h in + let reductc = reduct_in_concl ~check:false (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index b3914816ac..3bb9a34509 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -33,8 +33,8 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) val introduction : Id.t -> unit Proofview.tactic -val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic +val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic +val convert_hyp : check:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic [@@ocaml.deprecated "use [Tactics.convert_concl]"] val convert_hyp_no_check : named_declaration -> unit Proofview.tactic @@ -152,13 +152,13 @@ type e_tactic_reduction = Reductionops.e_reduction_function type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg -val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic -val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic -val reduct_in_concl : ?check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic -val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic -val change_in_concl : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic +val reduct_in_hyp : check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_option : check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic +val reduct_in_concl : check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic +val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val change_in_concl : check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic -val change_in_hyp : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> +val change_in_hyp : check:bool -> (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic val red_in_concl : unit Proofview.tactic val red_in_hyp : hyp_location -> unit Proofview.tactic @@ -180,7 +180,7 @@ val unfold_in_hyp : val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : - ?check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic + check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 603e00c815..a8c1a67f6f 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -167,7 +167,7 @@ let change pat c cl = delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma in let cl = mk_clause cl in - Tactics.change pat c cl + Tactics.change ~check:true pat c cl end let rewrite ev rw cl by = -- cgit v1.2.3 From d313bc5c1439f1881b4c77b9d92400579d2168ce Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 1 May 2019 17:22:42 +0200 Subject: Split the hypothesis conversion check in a conversion + ordering check. --- plugins/ltac/rewrite.ml | 4 ++-- plugins/omega/coq_omega.ml | 4 ++-- plugins/ssr/ssrtacticals.ml | 2 +- proofs/logic.ml | 4 ++-- proofs/logic.mli | 2 +- tactics/tactics.ml | 46 +++++++++++++++++++++++---------------------- tactics/tactics.mli | 4 ++-- 7 files changed, 34 insertions(+), 32 deletions(-) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 355c16bfd0..a68efa4713 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1575,7 +1575,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (* For compatibility *) let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp ~check:false Reductionops.nf_betaiota (id, InHyp) in + let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") @@ -1596,7 +1596,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp ~check:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> + convert_hyp ~check:false ~reorder:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index f3bc791b8d..ffc3506a1f 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1849,12 +1849,12 @@ let destructure_hyps = match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN - (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (tclTHEN - (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 17e4114958..91ff432364 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -110,7 +110,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic - (Tactics.convert_hyp ~check:false (NamedDecl.map_constr unmark hyp)) in + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic diff --git a/proofs/logic.ml b/proofs/logic.ml index 3fcde56e76..76eb79df39 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -548,7 +548,7 @@ and treat_case sigma goal ci lbrty lf acc' = (lacc,sigma,fi::bacc)) (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags -let convert_hyp ~check env sigma d = +let convert_hyp ~check ~reorder env sigma d = let id = NamedDecl.get_id d in let b = NamedDecl.get_value d in let sign = Environ.named_context_val env in @@ -565,7 +565,7 @@ let convert_hyp ~check env sigma d = user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the body of "++ Id.print id ++ str "."); let sign' = apply_to_hyp sign id (fun _ _ _ -> EConstr.Unsafe.to_named_decl d) in - if check then reorder_val_context env sigma sign' (check_decl_position env sigma sign d) + if reorder then reorder_val_context env sigma sign' (check_decl_position env sigma sign d) else sign' (************************************************************************) diff --git a/proofs/logic.mli b/proofs/logic.mli index 163d71f69c..406fe57985 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -62,7 +62,7 @@ type 'id move_location = val pr_move_location : ('a -> Pp.t) -> 'a move_location -> Pp.t -val convert_hyp : check:bool -> Environ.env -> evar_map -> +val convert_hyp : check:bool -> reorder:bool -> Environ.env -> evar_map -> EConstr.named_declaration -> Environ.named_context_val val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t move_location -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 78e7ce2321..077c9aa619 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -163,12 +163,12 @@ let convert_concl ~check ty k = end end -let convert_hyp ~check d = +let convert_hyp ~check ~reorder d = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in - let sign = convert_hyp ~check env sigma d in + let sign = convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ty @@ -176,7 +176,7 @@ let convert_hyp ~check d = end let convert_concl_no_check = convert_concl ~check:false -let convert_hyp_no_check = convert_hyp ~check:false +let convert_hyp_no_check = convert_hyp ~check:false ~reorder:false let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> @@ -709,16 +709,16 @@ let e_change_in_concl ~check (redfun, sty) = (convert_concl ~check c' sty) end -let e_change_in_hyp ~check redfun (id,where) = +let e_change_in_hyp ~check ~reorder redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id gl in let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp ~check c) + (convert_hyp ~check ~reorder c) end -let e_change_in_hyps ~check f args = +let e_change_in_hyps ~check ~reorder f args = Proofview.Goal.enter begin fun gl -> let fold (env, sigma) arg = let (redfun, id, where) = f arg in @@ -728,7 +728,7 @@ let e_change_in_hyps ~check f args = raise (RefinerError (env, sigma, NoSuchHyp id)) in let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in - let sign = Logic.convert_hyp ~check env sigma d in + let sign = Logic.convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in (env, sigma) in @@ -749,19 +749,19 @@ let reduct_in_concl ~check (redfun, sty) = let redfun env sigma c = (sigma, redfun env sigma c) in e_change_in_concl ~check (redfun, sty) -let e_reduct_in_hyp ~check redfun (id, where) = +let e_reduct_in_hyp ~check ~reorder redfun (id, where) = let redfun _ env sigma c = redfun env sigma c in - e_change_in_hyp ~check redfun (id, where) + e_change_in_hyp ~check ~reorder redfun (id, where) -let reduct_in_hyp ~check redfun (id, where) = +let reduct_in_hyp ~check ~reorder redfun (id, where) = let redfun _ env sigma c = (sigma, redfun env sigma c) in - e_change_in_hyp ~check redfun (id, where) + e_change_in_hyp ~check ~reorder redfun (id, where) let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r let e_reduct_option ~check redfun = function - | Some id -> e_reduct_in_hyp ~check (fst redfun) id + | Some id -> e_reduct_in_hyp ~check ~reorder:check (fst redfun) id | None -> e_change_in_concl ~check (revert_cast redfun) let reduct_option ~check (redfun, sty) where = @@ -833,7 +833,7 @@ let change_in_hyp ~check occl t id = (* FIXME: we set the [check] flag only to reorder hypotheses in case of introduction of dependencies in new variables. We should separate this check from the conversion function. *) - e_change_in_hyp ~check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id + e_change_in_hyp ~check ~reorder:check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -855,7 +855,8 @@ let change ~check chg c cls = let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in - e_change_in_hyps ~check f hyps + (* FIXME: don't check, we do it already *) + e_change_in_hyps ~check ~reorder:check f hyps end let change_concl t = @@ -863,20 +864,20 @@ let change_concl t = (* Pour usage interne (le niveau User est pris en compte par reduce) *) let red_in_concl = reduct_in_concl ~check:false (red_product,REVERTcast) -let red_in_hyp = reduct_in_hyp ~check:false red_product +let red_in_hyp = reduct_in_hyp ~check:false ~reorder:false red_product let red_option = reduct_option ~check:false (red_product,REVERTcast) let hnf_in_concl = reduct_in_concl ~check:false (hnf_constr,REVERTcast) -let hnf_in_hyp = reduct_in_hyp ~check:false hnf_constr +let hnf_in_hyp = reduct_in_hyp ~check:false ~reorder:false hnf_constr let hnf_option = reduct_option ~check:false (hnf_constr,REVERTcast) let simpl_in_concl = reduct_in_concl ~check:false (simpl,REVERTcast) -let simpl_in_hyp = reduct_in_hyp ~check:false simpl +let simpl_in_hyp = reduct_in_hyp ~check:false ~reorder:false simpl let simpl_option = reduct_option ~check:false (simpl,REVERTcast) let normalise_in_concl = reduct_in_concl ~check:false (compute,REVERTcast) -let normalise_in_hyp = reduct_in_hyp ~check:false compute +let normalise_in_hyp = reduct_in_hyp ~check:false ~reorder:false compute let normalise_option = reduct_option ~check:false (compute,REVERTcast) let normalise_vm_in_concl = reduct_in_concl ~check:false (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl ~check:false (unfoldn loccname,REVERTcast) -let unfold_in_hyp loccname = reduct_in_hyp ~check:false (unfoldn loccname) +let unfold_in_hyp loccname = reduct_in_hyp ~check:false ~reorder:false (unfoldn loccname) let unfold_option loccname = reduct_option ~check:false (unfoldn loccname,DEFAULTcast) let pattern_option l = e_reduct_option ~check:false (pattern_occs l,DEFAULTcast) @@ -907,7 +908,8 @@ let reduce redexp cl = let redfun _ env sigma c = redfun env sigma c in (redfun, id, where) in - e_change_in_hyps ~check f hyps + (* FIXME: sort out which flag is which *) + e_change_in_hyps ~check ~reorder:check f hyps end end @@ -2654,7 +2656,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = [ Proofview.Unsafe.tclEVARS sigma; convert_concl ~check:false newcl DEFAULTcast; intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; - Tacticals.New.tclMAP (convert_hyp ~check:false) depdecls; + Tacticals.New.tclMAP (convert_hyp ~check:false ~reorder:false) depdecls; eq_tac ] end @@ -3061,7 +3063,7 @@ let unfold_body x = Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in - let reducth h = reduct_in_hyp ~check:false rfun h in + let reducth h = reduct_in_hyp ~check:false ~reorder:false rfun h in let reductc = reduct_in_concl ~check:false (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 3bb9a34509..9eb8196280 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -34,7 +34,7 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool val introduction : Id.t -> unit Proofview.tactic val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : check:bool -> named_declaration -> unit Proofview.tactic +val convert_hyp : check:bool -> reorder:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic [@@ocaml.deprecated "use [Tactics.convert_concl]"] val convert_hyp_no_check : named_declaration -> unit Proofview.tactic @@ -152,7 +152,7 @@ type e_tactic_reduction = Reductionops.e_reduction_function type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg -val reduct_in_hyp : check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_in_hyp : check:bool -> reorder:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic val reduct_option : check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic val reduct_in_concl : check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic -- cgit v1.2.3 From 4f3c70ad2deb8382130972c513cb19f0974580a8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 1 May 2019 17:30:46 +0200 Subject: Take advantage of the ordering / conversion check split. --- tactics/tactics.ml | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 077c9aa619..806c955591 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -829,11 +829,9 @@ let change_in_concl ~check occl t = (* No need to check in e_change_in_concl, the check is done in change_on_subterm *) e_change_in_concl ~check:false ((change_on_subterm ~check Reduction.CUMUL false t occl),DEFAULTcast) -let change_in_hyp ~check occl t id = - (* FIXME: we set the [check] flag only to reorder hypotheses in case of - introduction of dependencies in new variables. We should separate this - check from the conversion function. *) - e_change_in_hyp ~check ~reorder:check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id +let change_in_hyp ~check occl t id = + (* Same as above *) + e_change_in_hyp ~check:false ~reorder:check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -855,8 +853,8 @@ let change ~check chg c cls = let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in - (* FIXME: don't check, we do it already *) - e_change_in_hyps ~check ~reorder:check f hyps + (* Don't check, we do it already in [change_on_subterm] *) + e_change_in_hyps ~check:false ~reorder:check f hyps end let change_concl t = @@ -894,6 +892,7 @@ let reduce redexp cl = let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in + let reorder = match redexp with Fold _ | Pattern _ -> true | _ -> false in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> @@ -908,8 +907,7 @@ let reduce redexp cl = let redfun _ env sigma c = redfun env sigma c in (redfun, id, where) in - (* FIXME: sort out which flag is which *) - e_change_in_hyps ~check ~reorder:check f hyps + e_change_in_hyps ~check ~reorder f hyps end end -- cgit v1.2.3 From 1c4a11ee8b5b48b85911689e1bb93757359cdfca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 1 May 2019 17:55:04 +0200 Subject: Fast-path for reordering of a single closed variable. Doesn't seem to matter in practice, but it doesn't hurt either. --- proofs/logic.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/proofs/logic.ml b/proofs/logic.ml index 76eb79df39..b79e1e6024 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -153,12 +153,14 @@ let reorder_context env sigma sign ord = step ord ords sign mt_q [] let reorder_val_context env sigma sign ord = +match ord with +| [] | [_] -> + (* Single variable-free definitions need not be reordered *) + sign +| _ :: _ :: _ -> let open EConstr in val_of_named_context (reorder_context env sigma (named_context_of_val sign) ord) - - - let check_decl_position env sigma sign d = let open EConstr in let x = NamedDecl.get_id d in -- cgit v1.2.3 From 1b4c0a1e52286d4957f6c79c8ff14868a6f3e838 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 6 May 2019 22:10:57 +0200 Subject: Add overlays for coq/coq#10052. --- dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh diff --git a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh new file mode 100644 index 0000000000..9f9cc19e83 --- /dev/null +++ b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10052" ] || [ "$CI_BRANCH" = "cleanup-logic-convert-hyp" ]; then + + relation_algebra_CI_REF=cleanup-logic-convert-hyp + relation_algebra_CI_GITURL=https://github.com/ppedrot/relation-algebra + +fi -- cgit v1.2.3 From a17626eb716b8a7b0ae5c1387f485223ba1c2de5 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 10 May 2019 16:48:40 +0200 Subject: [ltac2] Add primitive integers --- user-contrib/Ltac2/Constr.v | 1 + user-contrib/Ltac2/Init.v | 1 + user-contrib/Ltac2/tac2core.ml | 7 +++++-- user-contrib/Ltac2/tac2ffi.ml | 23 ++++++++++++++++++----- user-contrib/Ltac2/tac2ffi.mli | 6 ++++++ 5 files changed, 31 insertions(+), 7 deletions(-) diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index d8d222730e..1701bf4365 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -38,6 +38,7 @@ Ltac2 Type kind := [ | Fix (int array, int, ident option array, constr array, constr array) | CoFix (int, ident option array, constr array, constr array) | Proj (projection, constr) +| Uint63 (uint63) ]. Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v index 16e7d7a6f9..dc1690bdfb 100644 --- a/user-contrib/Ltac2/Init.v +++ b/user-contrib/Ltac2/Init.v @@ -14,6 +14,7 @@ Ltac2 Type int. Ltac2 Type string. Ltac2 Type char. Ltac2 Type ident. +Ltac2 Type uint63. (** Constr-specific built-in types *) Ltac2 Type meta. diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index d7e7b91ee6..da8600109e 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -424,8 +424,8 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_projection p; Value.of_constr c; |] - | Int _ -> - assert false + | Int n -> + v_blk 17 [|Value.of_uint63 n|] end end @@ -503,6 +503,9 @@ let () = define1 "constr_make" valexpr begin fun knd -> let p = Value.to_ext Value.val_projection p in let c = Value.to_constr c in EConstr.mkProj (p, c) + | (17, [|n|]) -> + let n = Value.to_uint63 n in + EConstr.mkInt n | _ -> assert false in return (Value.of_constr c) diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index e3127ab9df..1043d25a75 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -30,6 +30,8 @@ type valexpr = (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) +| ValUint63 of Uint63.t + (** Primitive integers *) and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure @@ -47,21 +49,21 @@ type t = valexpr let is_int = function | ValInt _ -> true -| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> false let tag v = match v with | ValBlk (n, _) -> n -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let field v n = match v with | ValBlk (_, v) -> v.(n) -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let set_field v n w = match v with | ValBlk (_, v) -> v.(n) <- w -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let make_block tag v = ValBlk (tag, v) @@ -192,7 +194,7 @@ let of_closure cls = ValCls cls let to_closure = function | ValCls cls -> cls -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ | ValUint63 _ -> assert false let closure = { r_of = of_closure; @@ -318,6 +320,17 @@ let open_ = { r_id = false; } +let of_uint63 n = ValUint63 n +let to_uint63 = function +| ValUint63 n -> n +| _ -> assert false + +let uint63 = { + r_of = of_uint63; + r_to = to_uint63; + r_id = false; +} + let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c let constant = repr_ext val_constant diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli index bfc93d99e6..f8581061a0 100644 --- a/user-contrib/Ltac2/tac2ffi.mli +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -28,6 +28,8 @@ type valexpr = (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) +| ValUint63 of Uint63.t + (** Primitive integers *) type 'a arity @@ -143,6 +145,10 @@ val of_open : KerName.t * valexpr array -> valexpr val to_open : valexpr -> KerName.t * valexpr array val open_ : (KerName.t * valexpr array) repr +val of_uint63 : Uint63.t -> valexpr +val to_uint63 : valexpr -> Uint63.t +val uint63 : Uint63.t repr + type ('a, 'b) fun1 val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic -- cgit v1.2.3 From 4e760a40f22e2d76a3d246b225d290eb5d15e9e8 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Mon, 6 May 2019 14:05:09 +0000 Subject: [Canonical structures] Some projections may not be canonical --- interp/constrextern.ml | 4 ++-- interp/constrintern.ml | 2 +- pretyping/recordops.ml | 57 ++++++++++++++++++++++++++++++++----------------- pretyping/recordops.mli | 12 +++++++++-- vernac/record.ml | 2 +- vernac/record.mli | 2 +- 6 files changed, 52 insertions(+), 27 deletions(-) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e5bf52571c..bb66658a37 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -850,10 +850,10 @@ let rec extern inctx scopes vars r = | Some c :: q -> match locs with | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") - | (_, false) :: locs' -> + | { Recordops.pk_true_proj = false } :: locs' -> (* we don't want to print locals *) ip q locs' args acc - | (_, true) :: locs' -> + | { Recordops.pk_true_proj = true } :: locs' -> match args with | [] -> raise No_match (* we give up since the constructor is not complete *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c0801067ce..f06493b374 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1368,7 +1368,7 @@ let sort_fields ~complete loc fields completer = let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in begin match proj_kinds with | [] -> anomaly (Pp.str "Number of projections mismatch.") - | (_, regular) :: proj_kinds -> + | { Recordops.pk_true_proj = regular } :: proj_kinds -> (* "regular" is false when the field is defined by a let-in in the record declaration (its value is fixed from other fields). *) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index d69824a256..331fa2d288 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -27,16 +27,30 @@ open Reductionops (*s A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) -(* Table des structures: le nom de la structure (un [inductive]) donne - le nom du constructeur, le nombre de paramètres et pour chaque - argument réel du constructeur, le nom de la projection - correspondante, si valide, et un booléen disant si c'est une vraie - projection ou bien une fonction constante (associée à un LetIn) *) +(* Table of structures. + It maps to each structure name (of type [inductive]): + - the name of its constructor; + - the number of parameters; + - for each true argument, some data about the corresponding projection: + * its name (may be anonymous); + * whether it is a true projection (as opposed to a constant function, LetIn); + * whether it should be used as a canonical hint; + * the constant realizing this projection (if any). +*) + +type proj_kind = { + pk_name: Name.t; + pk_true_proj: bool; + pk_canonical: bool; +} + +let mk_proj_kind pk_name pk_true_proj : proj_kind = + { pk_name ; pk_true_proj ; pk_canonical = true } type struc_typ = { s_CONST : constructor; s_EXPECTEDPARAM : int; - s_PROJKIND : (Name.t * bool) list; + s_PROJKIND : proj_kind list; s_PROJ : Constant.t option list } let structure_table = @@ -47,7 +61,7 @@ let projection_table = (* TODO: could be unify struc_typ and struc_tuple ? *) type struc_tuple = - constructor * (Name.t * bool) list * Constant.t option list + constructor * proj_kind list * Constant.t option list let register_structure env (id,kl,projs) = let open Declarations in @@ -161,7 +175,7 @@ let canonical_projections () = !object_table [] let keep_true_projections projs kinds = - let filter (p, (_, b)) = if b then Some p else None in + let filter (p, { pk_true_proj ; pk_canonical }) = if pk_true_proj then Some (p, pk_canonical) else None in List.map_filter filter (List.combine projs kinds) let rec cs_pattern_of_constr env t = @@ -206,17 +220,20 @@ let compute_canonical_projections env ~warn (con,ind) = let o_NPARAMS = List.length o_TPARAMS in let lpj = keep_true_projections lpj kl in let nenv = Termops.push_rels_assum sign env in - List.fold_left2 (fun acc spopt t -> - Option.cata (fun proji_sp -> - match cs_pattern_of_constr nenv t with - | patt, o_INJ, o_TCOMPS -> - ((ConstRef proji_sp, (patt, t)), - { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) - :: acc - | exception Not_found -> - if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); - acc - ) acc spopt + List.fold_left2 (fun acc (spopt, canonical) t -> + if canonical + then + Option.cata (fun proji_sp -> + match cs_pattern_of_constr nenv t with + | patt, o_INJ, o_TCOMPS -> + ((ConstRef proji_sp, (patt, t)), + { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) + :: acc + | exception Not_found -> + if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); + acc + ) acc spopt + else acc ) [] lpj projs let pr_cs_pattern = function @@ -288,7 +305,7 @@ let check_and_decompose_canonical_structure env sigma ref = with Not_found -> error_not_structure ref (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in - let ntrue_projs = List.count snd s.s_PROJKIND in + let ntrue_projs = List.count (fun { pk_true_proj } -> pk_true_proj) s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (sp,indsp) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index f0594d513a..565454d3b3 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -17,14 +17,22 @@ open Constr (** A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) +type proj_kind = { + pk_name: Name.t; + pk_true_proj: bool; + pk_canonical: bool; +} + +val mk_proj_kind : Name.t -> bool -> proj_kind + type struc_typ = { s_CONST : constructor; s_EXPECTEDPARAM : int; - s_PROJKIND : (Name.t * bool) list; + s_PROJKIND : proj_kind list; s_PROJ : Constant.t option list } type struc_tuple = - constructor * (Name.t * bool) list * Constant.t option list + constructor * proj_kind list * Constant.t option list val register_structure : Environ.env -> struc_tuple -> unit val subst_structure : Mod_subst.substitution -> struc_tuple -> struc_tuple diff --git a/vernac/record.ml b/vernac/record.ml index f489707eb3..9b0fbea148 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -368,7 +368,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,i,NoProjection fi::subst) in - (nfi-1,i,(fi, is_local_assum decl)::kinds,sp_projs,subst)) + (nfi - 1, i, Recordops.mk_proj_kind fi (is_local_assum decl) :: kinds, sp_projs, subst)) (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) diff --git a/vernac/record.mli b/vernac/record.mli index d6e63901cd..51ab7487d7 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -22,7 +22,7 @@ val declare_projections : bool list -> Impargs.manual_implicits list -> Constr.rel_context -> - (Name.t * bool) list * Constant.t option list + Recordops.proj_kind list * Constant.t option list val declare_structure_entry : Recordops.struc_tuple -> unit -- cgit v1.2.3 From 6e0467e746e40c10bdc110e8d21e26846219d510 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Mon, 6 May 2019 15:36:49 +0000 Subject: [Canonical structures] “not_canonical” annotation to field declarations --- pretyping/recordops.ml | 3 --- pretyping/recordops.mli | 2 -- vernac/attributes.ml | 3 +++ vernac/attributes.mli | 1 + vernac/g_vernac.mlg | 9 ++++++--- vernac/record.ml | 26 ++++++++++++++++++-------- vernac/record.mli | 7 ++++++- vernac/vernacentries.ml | 2 +- vernac/vernacexpr.ml | 1 + 9 files changed, 36 insertions(+), 18 deletions(-) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 331fa2d288..a23c58c062 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -44,9 +44,6 @@ type proj_kind = { pk_canonical: bool; } -let mk_proj_kind pk_name pk_true_proj : proj_kind = - { pk_name ; pk_true_proj ; pk_canonical = true } - type struc_typ = { s_CONST : constructor; s_EXPECTEDPARAM : int; diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 565454d3b3..25b6cd0751 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -23,8 +23,6 @@ type proj_kind = { pk_canonical: bool; } -val mk_proj_kind : Name.t -> bool -> proj_kind - type struc_typ = { s_CONST : constructor; s_EXPECTEDPARAM : int; diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 9b8c4efb37..31b0b7e49a 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -219,3 +219,6 @@ let only_polymorphism atts = parse polymorphic atts let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmpty] let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] + +let canonical = + bool_attribute ~name:"Canonical projection" ~on:"canonical" ~off:"not_canonical" diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 3cb4d69ca0..2559941354 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -52,6 +52,7 @@ val program : bool attribute val template : bool option attribute val locality : bool option attribute val deprecation : deprecation option attribute +val canonical : bool option attribute val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 59d2a66259..cc74121064 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -43,6 +43,7 @@ let query_command = Entry.create "vernac:query_command" let subprf = Entry.create "vernac:subprf" +let quoted_attributes = Entry.create "vernac:quoted_attributes" let class_rawexpr = Entry.create "vernac:class_rawexpr" let thm_token = Entry.create "vernac:thm_token" let def_body = Entry.create "vernac:def_body" @@ -75,7 +76,7 @@ let parse_compat_version = let open Flags in function } GRAMMAR EXTEND Gram - GLOBAL: vernac_control gallina_ext noedit_mode subprf; + GLOBAL: vernac_control quoted_attributes gallina_ext noedit_mode subprf; vernac_control: FIRST [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } @@ -447,10 +448,12 @@ GRAMMAR EXTEND Gram *) (* ... with coercions *) record_field: - [ [ bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; + [ [ attr = LIST0 quoted_attributes ; + bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; rf_notation = decl_notation -> { + let rf_canonical = attr |> List.flatten |> parse canonical |> Option.default true in let rf_subclass, rf_decl = bd in - rf_decl, { rf_subclass ; rf_priority ; rf_notation } } ] ] + rf_decl, { rf_subclass ; rf_priority ; rf_notation ; rf_canonical } } ] ] ; record_fields: [ [ f = record_field; ";"; fs = record_fields -> { f :: fs } diff --git a/vernac/record.ml b/vernac/record.ml index 9b0fbea148..f737a8c524 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -276,8 +276,13 @@ let instantiate_possibly_recursive_type ind u ntypes paramdecls fields = let subst' = List.init ntypes (fun i -> mkIndU ((ind, ntypes - i - 1), u)) in Termops.substl_rel_context (subst @ subst') fields +type projection_flags = { + pf_subclass: bool; + pf_canonical: bool; +} + (* We build projections *) -let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers fieldimpls fields = +let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in @@ -299,7 +304,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f in let (_,_,kinds,sp_projs,_) = List.fold_left3 - (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> + (fun (nfi,i,kinds,sp_projs,subst) flags decl impls -> let fi = RelDecl.get_name decl in let ti = RelDecl.get_type decl in let (sp_projs,i,subst) = @@ -359,17 +364,17 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f in let refi = ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; - if coe then begin + if flags.pf_subclass then begin let cl = Class.class_of_global (IndRef indsp) in Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl end; let i = if is_local_assum decl then i+1 else i in (Some kn::sp_projs, i, Projection term::subst) with NotDefinable why -> - warning_or_error coe indsp why; + warning_or_error flags.pf_subclass indsp why; (None::sp_projs,i,NoProjection fi::subst) in - (nfi - 1, i, Recordops.mk_proj_kind fi (is_local_assum decl) :: kinds, sp_projs, subst)) - (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) + (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) + (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) open Typeclasses @@ -525,7 +530,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity in [cref, [Name proj_name, sub, Some proj_cst]] | _ -> - let record_data = [id, idbuild, arity, fieldimpls, fields, false, List.map (fun _ -> false) fields] in + let record_data = [id, idbuild, arity, fieldimpls, fields, false, + List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in let inds = declare_structure ~cum Declarations.BiFinite ubinders univs paramimpls params template ~kind:Method ~name:[|binder_name|] record_data in @@ -699,7 +705,11 @@ let definition_structure udecl kind ~template cum poly finite records = let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = - let coe = List.map (fun (_, { rf_subclass }) -> not (Option.is_empty rf_subclass)) cfs in + let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> + { pf_subclass = not (Option.is_empty rf_subclass); + pf_canonical = rf_canonical }) + cfs + in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in diff --git a/vernac/record.mli b/vernac/record.mli index 51ab7487d7..24bb27e107 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -14,12 +14,17 @@ open Constrexpr val primitive_flag : bool ref +type projection_flags = { + pf_subclass: bool; + pf_canonical: bool; +} + val declare_projections : inductive -> Entries.universes_entry -> ?kind:Decl_kinds.definition_object_kind -> Id.t -> - bool list -> + projection_flags list -> Impargs.manual_implicits list -> Constr.rel_context -> Recordops.proj_kind list * Constant.t option list diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 279d4f0935..208210217a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -744,7 +744,7 @@ let vernac_inductive ~atts cum lo finite indl = let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), - { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] } in + { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 34a9b9394a..7267def362 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -148,6 +148,7 @@ type record_field_attr = { rf_subclass: instance_flag; (* the projection is an implicit coercion or an instance *) rf_priority: int option; (* priority of the instance, if relevant *) rf_notation: decl_notation list; + rf_canonical: bool; (* use this projection in the search for canonical instances *) } type constructor_expr = (lident * constr_expr) with_coercion type constructor_list_or_record_decl_expr = -- cgit v1.2.3 From 4c642b5c27d4f9c355044cb585a645b50dd844f2 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Mon, 6 May 2019 17:38:39 +0000 Subject: [User manual] Fix two warnings related to canonical structures --- doc/sphinx/addendum/canonical-structures.rst | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index dd21ea09bd..d81dafa4db 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -209,7 +209,7 @@ We need to define a new class that inherits from both ``EQ`` and ``LE``. LE_class : LE.class T; extra : mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class) }. - Structure type := _Pack { obj : Type; class_of : class obj }. + Structure type := _Pack { obj : Type; #[not_canonical] class_of : class obj }. Arguments Mixin {e le} _. @@ -219,6 +219,9 @@ The mixin component of the ``LEQ`` class contains all the extra content we are adding to ``EQ`` and ``LE``. In particular it contains the requirement that the two relations we are combining are compatible. +The `class_of` projection of the `type` structure is annotated as *not canonical*; +it plays no role in the search for instances. + Unfortunately there is still an obstacle to developing the algebraic theory of this new class. @@ -313,9 +316,7 @@ constructor ``*``. It also tests that they work as expected. Unfortunately, these declarations are very verbose. In the following subsection we show how to make them more compact. -.. FIXME shouldn't warn - -.. coqtop:: all warn +.. coqtop:: all Module Add_instance_attempt. @@ -420,9 +421,7 @@ the reader can refer to :cite:`CSwcu`. The declaration of canonical instances can now be way more compact: -.. FIXME should not warn - -.. coqtop:: all warn +.. coqtop:: all Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx. -- cgit v1.2.3 From e73c09a35c1aa5bc36b73ce555194752b9e6e25d Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 9 May 2019 06:57:09 +0000 Subject: Changelog for PR #10076 --- .../02-specification-language/10076-not-canonical-projection.rst | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 doc/changelog/02-specification-language/10076-not-canonical-projection.rst diff --git a/doc/changelog/02-specification-language/10076-not-canonical-projection.rst b/doc/changelog/02-specification-language/10076-not-canonical-projection.rst new file mode 100644 index 0000000000..0a902079b9 --- /dev/null +++ b/doc/changelog/02-specification-language/10076-not-canonical-projection.rst @@ -0,0 +1,4 @@ +- Record fields can be annotated to prevent them from being used as canonical projections; + see :ref:`canonicalstructures` for details + (`#10076 `_, + by Vincent Laporte). -- cgit v1.2.3 From ba62d040b8ff53ce66c2dbaa83a44b0037cb620f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 7 May 2019 10:14:07 +0000 Subject: Add overlay for elpi --- dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh diff --git a/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh b/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh new file mode 100644 index 0000000000..2015935dd9 --- /dev/null +++ b/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10076" ] || [ "$CI_BRANCH" = "canonical-disable-hint" ]; then + + elpi_CI_REF=canonical-disable-hint + elpi_CI_GITURL=https://github.com/vbgl/coq-elpi + +fi -- cgit v1.2.3 From 34e84eafe6615055071fbdc4aaee70c4c161a0fb Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 9 May 2019 13:39:25 +0000 Subject: [Attributes] Allow explicit value for two-valued attributes Attributes that enable/disable a feature can have an explicit value (default is enable when the attribute is present). Three-valued boolean attributes do not support this: what would `#[local(false)]` mean? --- doc/sphinx/addendum/canonical-structures.rst | 2 +- test-suite/success/attribute_syntax.v | 4 ++++ vernac/attributes.ml | 32 ++++++++++++++++++++++------ vernac/attributes.mli | 2 +- vernac/g_vernac.mlg | 2 +- 5 files changed, 32 insertions(+), 10 deletions(-) diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index d81dafa4db..b593b0cef1 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -209,7 +209,7 @@ We need to define a new class that inherits from both ``EQ`` and ``LE``. LE_class : LE.class T; extra : mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class) }. - Structure type := _Pack { obj : Type; #[not_canonical] class_of : class obj }. + Structure type := _Pack { obj : Type; #[canonical(false)] class_of : class obj }. Arguments Mixin {e le} _. diff --git a/test-suite/success/attribute_syntax.v b/test-suite/success/attribute_syntax.v index f4f59a3c16..4717759dec 100644 --- a/test-suite/success/attribute_syntax.v +++ b/test-suite/success/attribute_syntax.v @@ -20,6 +20,10 @@ Check ι _ ι. Fixpoint f (n: nat) {wf lt n} : nat := _. Reset f. +#[program(true)] +Fixpoint f (n: nat) {wf lt n} : nat := _. +Reset f. + #[deprecated(since="8.9.0")] Ltac foo := foo. diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 31b0b7e49a..1ad5862d5d 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -82,9 +82,12 @@ let assert_empty k v = if v <> VernacFlagEmpty then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") +let error_twice ~name : 'a = + user_err Pp.(str "Attribute for " ++ str name ++ str " specified twice.") + let assert_once ~name prev = if Option.has_some prev then - user_err Pp.(str "Attribute for " ++ str name ++ str " specified twice.") + error_twice ~name let attribute_of_list (l:(string * 'a key_parser) list) : 'a option attribute = let rec p extra v = function @@ -107,6 +110,24 @@ let bool_attribute ~name ~on ~off : bool option attribute = attribute_of_list [(on, single_key_parser ~name ~key:on true); (off, single_key_parser ~name ~key:off false)] +(* Variant of the [bool] attribute with only two values (bool has three). *) +let get_bool_value ~key ~default = + function + | VernacFlagEmpty -> default + | VernacFlagList [ "true", VernacFlagEmpty ] -> true + | VernacFlagList [ "false", VernacFlagEmpty ] -> false + | _ -> user_err Pp.(str "Attribute " ++ str key ++ str " only accepts boolean values.") + +let enable_attribute ~key ~default : bool attribute = + fun atts -> + let default = default () in + let this, extra = List.partition (fun (k, _) -> String.equal key k) atts in + extra, + match this with + | [] -> default + | [ _, value ] -> get_bool_value ~key ~default:true value + | _ -> error_twice ~name:key + let qualify_attribute qual (parser:'a attribute) : 'a attribute = fun atts -> let rec extract extra qualified = function @@ -139,11 +160,8 @@ let () = let open Goptions in optread = (fun () -> !program_mode); optwrite = (fun b -> program_mode:=b) } -let program_opt = bool_attribute ~name:"Program mode" ~on:"program" ~off:"noprogram" - -let program = program_opt >>= function - | Some b -> return b - | None -> return (!program_mode) +let program = + enable_attribute ~key:"program" ~default:(fun () -> !program_mode) let locality = bool_attribute ~name:"Locality" ~on:"local" ~off:"global" @@ -221,4 +239,4 @@ let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmp let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] let canonical = - bool_attribute ~name:"Canonical projection" ~on:"canonical" ~off:"not_canonical" + enable_attribute ~key:"canonical" ~default:(fun () -> true) diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 2559941354..44688ddafc 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -52,7 +52,7 @@ val program : bool attribute val template : bool option attribute val locality : bool option attribute val deprecation : deprecation option attribute -val canonical : bool option attribute +val canonical : bool attribute val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index cc74121064..17675a15e1 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -451,7 +451,7 @@ GRAMMAR EXTEND Gram [ [ attr = LIST0 quoted_attributes ; bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; rf_notation = decl_notation -> { - let rf_canonical = attr |> List.flatten |> parse canonical |> Option.default true in + let rf_canonical = attr |> List.flatten |> parse canonical in let rf_subclass, rf_decl = bd in rf_decl, { rf_subclass ; rf_priority ; rf_notation ; rf_canonical } } ] ] ; -- cgit v1.2.3 From 4895bf8bb5d0acfaee499991973fc6537657427d Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 10 May 2019 08:48:54 +0000 Subject: [refman] Mention the `#[canonical(false)]` attribute --- doc/sphinx/language/gallina-extensions.rst | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 5308330820..ba766c8c3d 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2048,6 +2048,21 @@ in :ref:`canonicalstructures`; here only a simple example is given. If a same field occurs in several canonical structures, then only the structure declared first as canonical is considered. + .. note:: + To prevent a field from being involved in the inference of canonical instances, + its declaration can be annotated with the :g:`#[canonical(false)]` attribute. + + .. example:: + + For instance, when declaring the :g:`Setoid` structure above, the + :g:`Prf_equiv` field declaration could be written as follows. + + .. coqdoc:: + + #[canonical(false)] Prf_equiv : equivalence Carrier Equal + + See :ref:`canonicalstructures` for a more realistic example. + .. cmdv:: Canonical {? Structure } @ident {? : @type } := @term This is equivalent to a regular definition of :token:`ident` followed by the @@ -2067,6 +2082,10 @@ in :ref:`canonicalstructures`; here only a simple example is given. Print Canonical Projections. + .. note:: + + The last line would not show up if the corresponding projection (namely + :g:`Prf_equiv`) were annotated as not canonical, as described above. Implicit types of variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- cgit v1.2.3 From beb5bdec79ff371f48a478df3c24f2cf9d68aa1f Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Tue, 7 May 2019 15:04:04 -0700 Subject: Use Print Custom Grammar to inspect custom entries --- doc/changelog/03-notations/10061-print-custom-grammar.rst | 4 ++++ doc/sphinx/user-extensions/syntax-extensions.rst | 7 ++++--- test-suite/output/Notations4.out | 10 ++++++++++ test-suite/output/Notations4.v | 1 + test-suite/success/Notations2.v | 4 ++-- vernac/g_vernac.mlg | 3 +++ vernac/metasyntax.ml | 8 +++++--- vernac/metasyntax.mli | 1 + vernac/ppvernac.ml | 2 ++ vernac/vernacentries.ml | 1 + vernac/vernacexpr.ml | 1 + 11 files changed, 34 insertions(+), 8 deletions(-) create mode 100644 doc/changelog/03-notations/10061-print-custom-grammar.rst diff --git a/doc/changelog/03-notations/10061-print-custom-grammar.rst b/doc/changelog/03-notations/10061-print-custom-grammar.rst new file mode 100644 index 0000000000..8786c7ce6b --- /dev/null +++ b/doc/changelog/03-notations/10061-print-custom-grammar.rst @@ -0,0 +1,4 @@ +- Allow inspecting custom grammar entries by :cmd:`Print Custom Grammar` + (`#10061 `_, + fixes `#9681 `_, + by Jasper Hugunin, review by Pierre-Marie Pédrot and Hugo Herbelin). diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index ac079ea7d5..edec13f681 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -840,10 +840,11 @@ gives a way to let any arbitrary expression which is not handled by the custom entry ``expr`` be parsed or printed by the main grammar of term up to the insertion of a pair of curly brackets. -.. cmd:: Print Grammar @ident. +.. cmd:: Print Custom Grammar @ident. + :name: Print Custom Grammar - This displays the state of the grammar for terms and grammar for - patterns associated to the custom entry :token:`ident`. + This displays the state of the grammar for terms associated to + the custom entry :token:`ident`. Summary ~~~~~~~ diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 9d972a68f7..c1b9a2b1c6 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -1,5 +1,15 @@ [< 0 > + < 1 > * < 2 >] : nat +Entry constr:myconstr is +[ "6" RIGHTA + [ ] +| "5" RIGHTA + [ SELF; "+"; NEXT ] +| "4" RIGHTA + [ SELF; "*"; NEXT ] +| "3" RIGHTA + [ "<"; constr:operconstr LEVEL "10"; ">" ] ] + [< b > + < b > * < 2 >] : nat [<< # 0 >>] diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 81c64418cb..d1063bfd04 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -9,6 +9,7 @@ Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5). Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4). Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10). Check [ < 0 > + < 1 > * < 2 >]. +Print Custom Grammar myconstr. Axiom a : nat. Notation b := a. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 2533a39cc4..d047f7560e 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -151,8 +151,8 @@ Module M16. Local Notation "##" := 0 (in custom foo2). (* Test Print Grammar *) - Print Grammar foo. - Print Grammar foo2. + Print Custom Grammar foo. + Print Custom Grammar foo2. End M16. (* Example showing the need for strong evaluation of diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 59d2a66259..94d4ed80d1 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -1003,6 +1003,9 @@ GRAMMAR EXTEND Gram | IDENT "Grammar"; ent = IDENT -> (* This should be in "syntax" section but is here for factorization*) { PrintGrammar ent } + | IDENT "Custom"; IDENT "Grammar"; ent = IDENT -> + (* Should also be in "syntax" section *) + { PrintCustomGrammar ent } | IDENT "LoadPath"; dir = OPT dirpath -> { PrintLoadPath dir } | IDENT "Modules" -> { user_err Pp.(str "Print Modules is obsolete; use Print Libraries instead") } diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 843296d24e..50914959dc 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -50,10 +50,10 @@ let pr_entry e = str (Buffer.contents entry_buf) let pr_registered_grammar name = - let gram = try Some (Pcoq.find_grammars_by_name name) with Not_found -> None in + let gram = Pcoq.find_grammars_by_name name in match gram with - | None -> user_err Pp.(str "Unknown or unprintable grammar entry.") - | Some entries -> + | [] -> user_err Pp.(str "Unknown or unprintable grammar entry.") + | entries -> let pr_one (Pcoq.AnyEntry e) = str "Entry " ++ str (Pcoq.Entry.name e) ++ str " is" ++ fnl () ++ pr_entry e @@ -85,6 +85,8 @@ let pr_grammar = function pr_entry Pvernac.Vernac_.gallina_ext | name -> pr_registered_grammar name +let pr_custom_grammar name = pr_registered_grammar ("constr:"^name) + (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single quote (except a single quote alone) must be quoted) *) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 38dbdf7e41..6435df23c7 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -57,6 +57,7 @@ val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr -> (** Print the Camlp5 state of a grammar *) val pr_grammar : string -> Pp.t +val pr_custom_grammar : string -> Pp.t val check_infix_modifiers : syntax_modifier list -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 889dbafabd..f2332bab8b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -476,6 +476,8 @@ open Pputils keyword "Print Section" ++ spc() ++ Libnames.pr_qualid s | PrintGrammar ent -> keyword "Print Grammar" ++ spc() ++ str ent + | PrintCustomGrammar ent -> + keyword "Print Custom Grammar" ++ spc() ++ str ent | PrintLoadPath dir -> keyword "Print LoadPath" ++ pr_opt DirPath.print dir | PrintModules -> diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 388f6957cf..b7d5e1c543 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1883,6 +1883,7 @@ let vernac_print ~(pstate : Proof_global.t option) ~atts = | PrintSectionContext qid -> print_sec_context_typ env sigma qid | PrintInspect n -> inspect env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent + | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir | PrintModules -> print_modules () | PrintModule qid -> print_module qid diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 34a9b9394a..6a51fdfe59 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -29,6 +29,7 @@ type printable = | PrintSectionContext of qualid | PrintInspect of int | PrintGrammar of string + | PrintCustomGrammar of string | PrintLoadPath of DirPath.t option | PrintModules | PrintModule of qualid -- cgit v1.2.3 From 15d4547b977e96ed2bc26cea683f5f4f3c9ee137 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 3 May 2019 00:34:21 +0200 Subject: Abstract the Tactic.e_change_hyps function over the reduction function. --- tactics/tactics.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 806c955591..869e3039ab 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -614,7 +614,7 @@ let cofix id = mutual_cofix id [] 0 type tactic_reduction = Reductionops.reduction_function type e_tactic_reduction = Reductionops.e_reduction_function -let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = +let e_pf_change_decl (redfun : bool -> e_reduction_function) where env sigma decl = let open Context.Named.Declaration in match decl with | LocalAssum (id,ty) -> @@ -713,7 +713,7 @@ let e_change_in_hyp ~check ~reorder redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id gl in - let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + let (sigma, c) = e_pf_change_decl redfun where (Proofview.Goal.env gl) sigma hyp in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (convert_hyp ~check ~reorder c) end @@ -721,13 +721,13 @@ let e_change_in_hyp ~check ~reorder redfun (id,where) = let e_change_in_hyps ~check ~reorder f args = Proofview.Goal.enter begin fun gl -> let fold (env, sigma) arg = - let (redfun, id, where) = f arg in + let (id, redfun) = f arg in let hyp = try lookup_named id env with Not_found -> raise (RefinerError (env, sigma, NoSuchHyp id)) in - let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in + let (sigma, d) = redfun env sigma hyp in let sign = Logic.convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in (env, sigma) @@ -851,7 +851,8 @@ let change ~check chg c cls = let f (id, occs, where) = let occl = bind_change_occurrences occs chg in let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in - (redfun, id, where) + let redfun env sigma d = e_pf_change_decl redfun where env sigma d in + (id, redfun) in (* Don't check, we do it already in [change_on_subterm] *) e_change_in_hyps ~check:false ~reorder:check f hyps @@ -905,7 +906,8 @@ let reduce redexp cl = let redexp = bind_red_expr_occurrences occs nbcl redexp in let (redfun, _) = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in let redfun _ env sigma c = redfun env sigma c in - (redfun, id, where) + let redfun env sigma d = e_pf_change_decl redfun where env sigma d in + (id, redfun) in e_change_in_hyps ~check ~reorder f hyps end -- cgit v1.2.3 From 3c6ed7485293c7eb80f9c4d415af0ee0b977f157 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 3 May 2019 00:41:55 +0200 Subject: Generalize map_named_val to handle whole declarations. --- engine/evd.ml | 2 +- engine/proofview.ml | 2 +- kernel/environ.ml | 2 +- kernel/environ.mli | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index b89222cf8e..96c2719f8f 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -222,7 +222,7 @@ let map_evar_body f = function let map_evar_info f evi = {evi with evar_body = map_evar_body f evi.evar_body; - evar_hyps = map_named_val f evi.evar_hyps; + evar_hyps = map_named_val (fun d -> NamedDecl.map_constr f d) evi.evar_hyps; evar_concl = f evi.evar_concl; evar_candidates = Option.map (List.map f) evi.evar_candidates } diff --git a/engine/proofview.ml b/engine/proofview.ml index f278c83912..6992d15fcb 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -46,7 +46,7 @@ let compact el ({ solution } as pv) = let apply_subst_einfo _ ei = Evd.({ ei with evar_concl = nf ei.evar_concl; - evar_hyps = Environ.map_named_val nf0 ei.evar_hyps; + evar_hyps = Environ.map_named_val (fun d -> map_constr nf0 d) ei.evar_hyps; evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in diff --git a/kernel/environ.ml b/kernel/environ.ml index 97c9f8654a..617519a038 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -187,7 +187,7 @@ let match_named_context_val c = match c.env_named_ctx with let map_named_val f ctxt = let open Context.Named.Declaration in let fold accu d = - let d' = map_constr f d in + let d' = f d in let accu = if d == d' then accu else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu diff --git a/kernel/environ.mli b/kernel/environ.mli index 8c6bc105c7..4e6dbbe206 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -134,9 +134,9 @@ val ids_of_named_context_val : named_context_val -> Id.Set.t (** [map_named_val f ctxt] apply [f] to the body and the type of each declarations. - *** /!\ *** [f t] should be convertible with t *) + *** /!\ *** [f t] should be convertible with t, and preserve the name *) val map_named_val : - (constr -> constr) -> named_context_val -> named_context_val + (named_declaration -> named_declaration) -> named_context_val -> named_context_val val push_named : Constr.named_declaration -> env -> env val push_named_context : Constr.named_context -> env -> env -- cgit v1.2.3 From ec6c11c67a01122f52f615691f120bde9da9a61e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 3 May 2019 00:38:25 +0200 Subject: Introducing a local flag to hypothesis conversion function. If the reduction function is known not to depend on the named context, then we can perform it in parallel on the various variables. --- tactics/tactics.ml | 62 ++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 49 insertions(+), 13 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 869e3039ab..ecb8c9dc1f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -718,23 +718,56 @@ let e_change_in_hyp ~check ~reorder redfun (id,where) = (convert_hyp ~check ~reorder c) end +type hyp_conversion = +| AnyHypConv (** Arbitrary conversion *) +| StableHypConv (** Does not introduce new dependencies on variables *) +| LocalHypConv (** Same as above plus no dependence on the named environment *) + let e_change_in_hyps ~check ~reorder f args = Proofview.Goal.enter begin fun gl -> - let fold (env, sigma) arg = - let (id, redfun) = f arg in - let hyp = - try lookup_named id env - with Not_found -> - raise (RefinerError (env, sigma, NoSuchHyp id)) + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (env, sigma) = match reorder with + | LocalHypConv -> + (* If the reduction function is known not to depend on the named + context, then we can perform it in parallel. *) + let fold accu arg = + let (id, redfun) = f arg in + let old = try Id.Map.find id accu with Not_found -> [] in + Id.Map.add id (redfun :: old) accu + in + let reds = List.fold_left fold Id.Map.empty args in + let evdref = ref sigma in + let map d = + let id = NamedDecl.get_id d in + match Id.Map.find id reds with + | reds -> + let d = EConstr.of_named_decl d in + let fold redfun (sigma, d) = redfun env sigma d in + let (sigma, d) = List.fold_right fold reds (sigma, d) in + let () = evdref := sigma in + EConstr.Unsafe.to_named_decl d + | exception Not_found -> d in - let (sigma, d) = redfun env sigma hyp in - let sign = Logic.convert_hyp ~check ~reorder env sigma d in + let sign = Environ.map_named_val map (Environ.named_context_val env) in let env = reset_with_named_context sign env in - (env, sigma) + (env, !evdref) + | StableHypConv | AnyHypConv -> + let reorder = reorder == AnyHypConv in + let fold (env, sigma) arg = + let (id, redfun) = f arg in + let hyp = + try lookup_named id env + with Not_found -> + raise (RefinerError (env, sigma, NoSuchHyp id)) + in + let (sigma, d) = redfun env sigma hyp in + let sign = Logic.convert_hyp ~check ~reorder env sigma d in + let env = reset_with_named_context sign env in + (env, sigma) + in + List.fold_left fold (env, sigma) args in - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let (env, sigma) = List.fold_left fold (env, sigma) args in let ty = Proofview.Goal.concl gl in Proofview.Unsafe.tclEVARS sigma <*> @@ -854,8 +887,9 @@ let change ~check chg c cls = let redfun env sigma d = e_pf_change_decl redfun where env sigma d in (id, redfun) in + let reorder = if check then AnyHypConv else StableHypConv in (* Don't check, we do it already in [change_on_subterm] *) - e_change_in_hyps ~check:false ~reorder:check f hyps + e_change_in_hyps ~check:false ~reorder f hyps end let change_concl t = @@ -909,6 +943,8 @@ let reduce redexp cl = let redfun env sigma d = e_pf_change_decl redfun where env sigma d in (id, redfun) in + (* FIXME: use local flag *) + let reorder = if reorder then AnyHypConv else StableHypConv in e_change_in_hyps ~check ~reorder f hyps end end -- cgit v1.2.3 From 076932d4bf602560b24c14dc3397e51db5114244 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 3 May 2019 01:05:05 +0200 Subject: Actually use the conversion locality flag. Fixes #9919. --- tactics/tactics.ml | 33 ++++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ecb8c9dc1f..03b628dca3 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -916,6 +916,22 @@ let pattern_option l = e_reduct_option ~check:false (pattern_occs l,DEFAULTcast) (* The main reduction function *) +let is_local_flag env flags = + if flags.rDelta then false + else + let check = function + | EvalVarRef _ -> false + | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (ConstRef c)) + in + List.for_all check flags.rConst + +let is_local_unfold env flags = + let check (_, c) = match c with + | EvalVarRef _ -> false + | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (ConstRef c)) + in + List.for_all check flags + let reduce redexp cl = let trace env sigma = let open Printer in @@ -924,27 +940,34 @@ let reduce redexp cl = in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in - let reorder = match redexp with Fold _ | Pattern _ -> true | _ -> false in + let reorder = match redexp with + | Fold _ | Pattern _ -> AnyHypConv + | Simpl (flags, _) | Cbv flags | Cbn flags | Lazy flags -> + if is_local_flag env flags then LocalHypConv else StableHypConv + | Unfold flags -> + if is_local_unfold env flags then LocalHypConv else StableHypConv + | Red _ | Hnf | CbvVm _ | CbvNative _ -> StableHypConv + | ExtraRedExpr _ -> StableHypConv (* Should we be that lenient ?*) + in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> let redexp = bind_red_expr_occurrences occs nbcl redexp in - let redfun = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + let redfun = Redexpr.reduction_of_red_expr env redexp in e_change_in_concl ~check (revert_cast redfun) end <*> let f (id, occs, where) = let redexp = bind_red_expr_occurrences occs nbcl redexp in - let (redfun, _) = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in let redfun _ env sigma c = redfun env sigma c in let redfun env sigma d = e_pf_change_decl redfun where env sigma d in (id, redfun) in - (* FIXME: use local flag *) - let reorder = if reorder then AnyHypConv else StableHypConv in e_change_in_hyps ~check ~reorder f hyps end end -- cgit v1.2.3 From b83c29a099bde1ea71161c994bbf69b931e6d0f6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 11 May 2019 14:20:23 +0200 Subject: Code factorization in elim tactics. This is just moving code around, so it should not change the semantics. --- tactics/tactics.ml | 103 ++++++++++++++++++++++------------------------------- 1 file changed, 42 insertions(+), 61 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 806c955591..44ca9958fa 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1360,22 +1360,25 @@ let rec contract_letin_in_lam_header sigma c = | LetIn (x,b,t,c) -> contract_letin_in_lam_header sigma (subst1 b c) | _ -> c -let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) - rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header sigma elim in - let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = - (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with - | Meta mv -> mv - | _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.")) +let elimination_in_clause_scheme env sigma with_evars ~flags + id hypmv elimclause = + let hyp = mkVar id in + let hyp_typ = Retyping.get_type_of env sigma hyp in + let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in + let elimclause'' = + (* The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags hypmv elimclause hypclause + with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> + (* Set the hypothesis name in the message *) + raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) in - let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags - end + let new_hyp_typ = clenv_type elimclause'' in + if EConstr.eq_constr sigma hyp_typ new_hyp_typ then + user_err ~hdr:"general_rewrite_in" + (str "Nothing to rewrite in " ++ Id.print id ++ str"."); + clenv_refine_in with_evars id id sigma elimclause'' + (fun id -> Proofview.tclUNIT ()) (* * Elimination tactic with bindings and using an arbitrary @@ -1391,7 +1394,7 @@ type eliminator = { elimbody : EConstr.constr with_bindings } -let general_elim_clause_gen elimtac indclause elim = +let general_elim_clause with_evars flags where indclause elim = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1399,7 +1402,27 @@ let general_elim_clause_gen elimtac indclause elim = let elimt = Retyping.get_type_of env sigma elimc in let i = match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in - elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause + let elimc = contract_letin_in_lam_header sigma elimc in + let elimclause = make_clenv_binding env sigma (elimc, elimt) lbindelimc in + let indmv = + (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with + | Meta mv -> mv + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.")) + in + match where with + | None -> + let elimclause = clenv_fchain ~flags indmv elimclause indclause in + Clenvtac.res_pf elimclause ~with_evars ~with_classes:true ~flags + | Some id -> + let hypmv = + match List.remove Int.equal indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.") + in + let elimclause = clenv_fchain ~flags indmv elimclause indclause in + elimination_in_clause_scheme env sigma with_evars ~flags id hypmv elimclause end let general_elim with_evars clear_flag (c, lbindc) elim = @@ -1408,12 +1431,12 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in - let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in + let flags = elim_flags () in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN - (general_elim_clause_gen elimtac indclause elim) + (general_elim_clause with_evars flags None indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) end @@ -1515,48 +1538,6 @@ let simplest_elim c = default_elim false None (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) -let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - (* The evarmap of elimclause is assumed to be an extension of hypclause, so - we do not need to merge the universes coming from hypclause. *) - try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause - with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> - (* Set the hypothesis name in the message *) - raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) - -let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) - id rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header sigma elim in - let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in - let hypmv = - match List.remove Int.equal indmv (clenv_independent elimclause) with - | [a] -> a - | _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.") - in - let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - let hyp = mkVar id in - let hyp_typ = Retyping.get_type_of env sigma hyp in - let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in - let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in - let new_hyp_typ = clenv_type elimclause'' in - if EConstr.eq_constr sigma hyp_typ new_hyp_typ then - user_err ~hdr:"general_rewrite_in" - (str "Nothing to rewrite in " ++ Id.print id ++ str"."); - clenv_refine_in with_evars id id sigma elimclause'' - (fun id -> Proofview.tclUNIT ()) - end - -let general_elim_clause with_evars flags id c e = - let elim = match id with - | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags - | Some id -> elimination_in_clause_scheme with_evars ~flags id - in - general_elim_clause_gen elim c e - (* Apply a tactic below the products of the conclusion of a lemma *) type conjunction_status = -- cgit v1.2.3 From 150fd1b6a50aff5e2476888eead3d33dc2f3d1fd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 11 May 2019 15:35:46 +0200 Subject: Remove the elimrename field from Tactics.eliminator. This is actually dead code, we never observe it. --- tactics/equality.ml | 2 +- tactics/tactics.ml | 20 +++++++------------- tactics/tactics.mli | 1 - 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index f049f8c568..45a4799ea1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -417,7 +417,7 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d find_elim hdcncl lft2rgt dep cls (Some t) >>= fun elim -> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) - {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} + {elimindex = None; elimbody = (elim,NoBindings) } end let adjust_rewriting_direction args lft2rgt = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 44ca9958fa..7dd8a7a7c1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1390,7 +1390,6 @@ let elimination_in_clause_scheme env sigma with_evars ~flags type eliminator = { elimindex : int option; (* None = find it automatically *) - elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : EConstr.constr with_bindings } @@ -1459,8 +1458,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let elim = EConstr.of_constr elim in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) - {elimindex = None; elimbody = (elim,NoBindings); - elimrename = Some (false, constructors_nrealdecls env (fst mind))}) + {elimindex = None; elimbody = (elim,NoBindings); }) end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1491,8 +1489,7 @@ let find_eliminator c gl = let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in - evd, {elimindex = None; elimbody = (c,NoBindings); - elimrename = Some (true, constructors_nrealdecls (Global.env()) ind)} + evd, { elimindex = None; elimbody = (c,NoBindings) } let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE @@ -1512,7 +1509,7 @@ let default_elim with_evars clear_flag (c,_ as cx) = let elim_in_context with_evars clear_flag c = function | Some elim -> general_elim with_evars clear_flag c - {elimindex = Some (-1); elimbody = elim; elimrename = None} + { elimindex = Some (-1); elimbody = elim } | None -> default_elim with_evars clear_flag c let elim with_evars clear_flag (c,lbindc as cx) elim = @@ -4164,7 +4161,7 @@ let find_induction_type isrec elim hyp0 gl = let scheme = compute_elim_sig sigma ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in - let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in + let elim = ({ elimindex = Some(-1); elimbody = elimc },elimt) in scheme, ElimUsing (elim,indsign) in match scheme.indref with @@ -4191,10 +4188,7 @@ let get_eliminator elim dep s gl = | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) - (List.rev s.branches) - in - evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l + evd, isrec, ({ elimindex = None; elimbody = elimc }, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are @@ -4238,7 +4232,7 @@ let recolle_clenv i params args elimclause gl = let induction_tac with_evars params indvars elim = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in + let ({ elimindex=i;elimbody=(elimc,lbindelimc) },elimt) = elim in let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header sigma elimc in @@ -4343,7 +4337,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* FIXME: Tester ca avec un principe dependant et non-dependant *) induction_tac with_evars params realindvars elim; ] in - let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in + let elim = ElimUsing (({ elimindex = Some (-1); elimbody = Option.get scheme.elimc }, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9eb8196280..32c64bacf6 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -282,7 +282,6 @@ val compute_elim_sig : evar_map -> ?elimc:constr with_bindings -> types -> elim_ (** elim principle with the index of its inductive arg *) type eliminator = { elimindex : int option; (** None = find it automatically *) - elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : constr with_bindings } -- cgit v1.2.3 From c9761554f223a031026c984a4515f6a2703cc6ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 11 May 2019 17:38:50 +0200 Subject: Remove the sidecond_first flag of apply-related tactics. This was dead code. --- tactics/tactics.ml | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 7dd8a7a7c1..2bdfc85d6d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1302,14 +1302,11 @@ let do_replace id = function [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) -let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) - targetid id sigma0 clenv tac = +let clenv_refine_in with_evars targetid id sigma0 clenv tac = let clenv = Clenvtac.clenv_pose_dependent_evars ~with_evars clenv in let clenv = - if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } - else clenv in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; @@ -1321,11 +1318,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) - (if sidecond_first then - Tacticals.New.tclTHENFIRST - (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac - else - Tacticals.New.tclTHENLAST + (Tacticals.New.tclTHENLAST (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac) (********************************************) @@ -1806,7 +1799,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = in aux (make_clenv_binding env sigma (d,thm) lbind) -let apply_in_once ?(respect_opaque = false) sidecond_first with_delta +let apply_in_once ?(respect_opaque = false) with_delta with_destruct with_evars naming id (clear_flag,{ CAst.loc; v= d,lbind}) tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> @@ -1827,7 +1820,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in try let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in - clenv_refine_in ~sidecond_first with_evars targetid id sigma clause + clenv_refine_in with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ apply_clear_request clear_flag false c; @@ -1844,14 +1837,14 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta aux [] with_destruct d end -let apply_in_delayed_once ?(respect_opaque = false) sidecond_first with_delta +let apply_in_delayed_once ?(respect_opaque = false) with_delta with_destruct with_evars naming id (clear_flag,{CAst.loc;v=f}) tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars - (apply_in_once ~respect_opaque sidecond_first with_delta with_destruct with_evars + (apply_in_once ~respect_opaque with_delta with_destruct with_evars naming id (clear_flag,CAst.(make ?loc c)) tac) sigma end @@ -2471,7 +2464,7 @@ and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = clear [id] in let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) in - apply_in_delayed_once false true true with_evars naming id (None,CAst.make ?loc:loc' f) + apply_in_delayed_once true true with_evars naming id (None,CAst.make ?loc:loc' f) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros ?loc with_evars dft destopt = function @@ -2539,10 +2532,10 @@ let assert_as first hd ipat t = (* apply in as *) -let general_apply_in ?(respect_opaque=false) sidecond_first with_delta +let general_apply_in ?(respect_opaque=false) with_delta with_destruct with_evars id lemmas ipat = let tac (naming,lemma) tac id = - apply_in_delayed_once ~respect_opaque sidecond_first with_delta + apply_in_delayed_once ~respect_opaque with_delta with_destruct with_evars naming id lemma tac in Proofview.Goal.enter begin fun gl -> let destopt = @@ -2571,10 +2564,10 @@ let general_apply_in ?(respect_opaque=false) sidecond_first with_delta let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in - general_apply_in false simple simple with_evars id lemmas ipat + general_apply_in simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = - general_apply_in ~respect_opaque:true false simple simple with_evars id lemmas ipat + general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) -- cgit v1.2.3 From a101fdc131bd5d7a8ed1470cd7fa705ad6979e92 Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Fri, 10 May 2019 09:47:02 -0400 Subject: [refman] Use 'flag' instead of 'opt' for 'Ltac2 Debug' --- doc/sphinx/proof-engine/ltac2.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 6e33862b39..945ffd6307 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -823,9 +823,9 @@ Ltac2 features a toplevel loop that can be used to evaluate expressions. Debug ----- -.. opt:: Ltac2 Backtrace +.. flag:: Ltac2 Backtrace - When this option is set, toplevel failures will be printed with a backtrace. + When this flag is set, toplevel failures will be printed with a backtrace. Compatibility layer with Ltac1 ------------------------------ -- cgit v1.2.3 From f3f758896b82d34acd0e42a65f08a5cb80aa0da9 Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Fri, 10 May 2019 22:26:22 -0400 Subject: [refman] Raise an error when a notation doesn't parse --- doc/tools/coqrst/coqdomain.py | 41 ++++++++++++++++++++++++----------- doc/tools/coqrst/notations/parsing.py | 18 +++++++++++++-- 2 files changed, 44 insertions(+), 15 deletions(-) diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 0ade9fdbf5..1784519f5f 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -39,14 +39,29 @@ from sphinx.ext import mathbase from . import coqdoc from .repl import ansicolors from .repl.coqtop import CoqTop, CoqTopError +from .notations.parsing import ParseError from .notations.sphinx import sphinxify from .notations.plain import stringify_with_ellipses -def parse_notation(notation, source, line, rawtext=None): +PARSE_ERROR = """Parse error in notation! +Offending notation: {} +Error message: {}""" + +def notation_to_sphinx(notation, source, line, rawtext=None): """Parse notation and wrap it in an inline node""" - node = nodes.inline(rawtext or notation, '', *sphinxify(notation), classes=['notation']) - node.source, node.line = source, line - return node + try: + node = nodes.inline(rawtext or notation, '', *sphinxify(notation), classes=['notation']) + node.source, node.line = source, line + return node + except ParseError as e: + raise ExtensionError(PARSE_ERROR.format(notation, e.msg)) from e + +def notation_to_string(notation): + """Parse notation and format it as a string with ellipses.""" + try: + return stringify_with_ellipses(notation) + except ParseError as e: + raise ExtensionError(PARSE_ERROR.format(notation, e.msg)) from e def highlight_using_coqdoc(sentence): """Lex sentence using coqdoc, and yield inline nodes for each token""" @@ -136,7 +151,7 @@ class CoqObject(ObjectDescription): self._render_signature(signature, signode) name = self._names.get(signature) if name is None: - name = self._name_from_signature(signature) + name = self._name_from_signature(signature) # pylint: disable=assignment-from-none # remove trailing ‘.’ found in commands, but not ‘...’ (ellipsis) if name is not None and name.endswith(".") and not name.endswith("..."): name = name[:-1] @@ -241,7 +256,7 @@ class NotationObject(DocumentableObject): """ def _render_signature(self, signature, signode): position = self.state_machine.get_source_and_line(self.lineno) - tacn_node = parse_notation(signature, *position) + tacn_node = notation_to_sphinx(signature, *position) signode += addnodes.desc_name(signature, '', tacn_node) class GallinaObject(PlainObject): @@ -346,7 +361,7 @@ class OptionObject(NotationObject): annotation = "Option" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class FlagObject(NotationObject): @@ -365,7 +380,7 @@ class FlagObject(NotationObject): annotation = "Flag" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class TableObject(NotationObject): @@ -383,7 +398,7 @@ class TableObject(NotationObject): annotation = "Table" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class ProductionObject(CoqObject): r"""A grammar production. @@ -432,7 +447,7 @@ class ProductionObject(CoqObject): lhs_node = nodes.literal(lhs_op, lhs_op) position = self.state_machine.get_source_and_line(self.lineno) - rhs_node = parse_notation(rhs, *position) + rhs_node = notation_to_sphinx(rhs, *position) signode += addnodes.desc_name(signature, '', lhs_node, rhs_node) return ('token', lhs) if op == '::=' else None @@ -475,7 +490,7 @@ class ExceptionObject(NotationObject): # Generate names automatically def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class WarningObject(NotationObject): """An warning raised by a Coq command or tactic.. @@ -497,7 +512,7 @@ class WarningObject(NotationObject): # Generate names automatically def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) def NotationRole(role, rawtext, text, lineno, inliner, options={}, content=[]): #pylint: disable=unused-argument, dangerous-default-value @@ -516,7 +531,7 @@ def NotationRole(role, rawtext, text, lineno, inliner, options={}, content=[]): """ notation = utils.unescape(text, 1) position = inliner.reporter.get_source_and_line(lineno) - return [nodes.literal(rawtext, '', parse_notation(notation, *position, rawtext=rawtext))], [] + return [nodes.literal(rawtext, '', notation_to_sphinx(notation, *position, rawtext=rawtext))], [] def coq_code_role(role, rawtext, text, lineno, inliner, options={}, content=[]): #pylint: disable=dangerous-default-value diff --git a/doc/tools/coqrst/notations/parsing.py b/doc/tools/coqrst/notations/parsing.py index 506240d907..2312e09090 100644 --- a/doc/tools/coqrst/notations/parsing.py +++ b/doc/tools/coqrst/notations/parsing.py @@ -11,10 +11,22 @@ from .TacticNotationsLexer import TacticNotationsLexer from .TacticNotationsParser import TacticNotationsParser from antlr4 import CommonTokenStream, InputStream +from antlr4.error.ErrorListener import ErrorListener SUBSTITUTIONS = [#("@bindings_list", "{+ (@id := @val) }"), ("@qualid_or_string", "@id|@string")] +class ParseError(Exception): + def __init__(self, msg): + super().__init__() + self.msg = msg + +class ExceptionRaisingErrorListener(ErrorListener): + def syntaxError(self, recognizer, offendingSymbol, line, column, msg, e): + raise ParseError("{}:{}: {}".format(line, column, msg)) + +ERROR_LISTENER = ExceptionRaisingErrorListener() + def substitute(notation): """Perform common substitutions in the notation string. @@ -27,11 +39,13 @@ def substitute(notation): return notation def parse(notation): - """Parse a notation string. + """Parse a notation string, optionally reporting errors to `error_listener`. :return: An ANTLR AST. Use one of the supplied visitors (or write your own) to turn it into useful output. """ substituted = substitute(notation) lexer = TacticNotationsLexer(InputStream(substituted)) - return TacticNotationsParser(CommonTokenStream(lexer)).top() + parser = TacticNotationsParser(CommonTokenStream(lexer)) + parser.addErrorListener(ERROR_LISTENER) + return parser.top() -- cgit v1.2.3 From cf9f4e566b87d2875f757bb7d54ee4421988e315 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 10 May 2019 12:32:07 +0200 Subject: Make detyping robust w.r.t. indexed anonymous variables I don't think there's a reason to treat such variables more severely than unbound variables. This anomaly is often raised by debug printers (e.g. when studying complex scenarios using `Set Unification Debug`), and so makes debugging less convenient. Fixes #3754, fixes #10026. --- dev/top_printers.ml | 1 - pretyping/detyping.ml | 13 +- pretyping/detyping.mli | 3 - test-suite/bugs/closed/bug_10026.v | 3 + test-suite/bugs/closed/bug_3754.v | 287 +++++++++++++++++++++++++++++++++++++ test-suite/bugs/opened/bug_3754.v | 285 ------------------------------------ 6 files changed, 296 insertions(+), 296 deletions(-) create mode 100644 test-suite/bugs/closed/bug_10026.v create mode 100644 test-suite/bugs/closed/bug_3754.v delete mode 100644 test-suite/bugs/opened/bug_3754.v diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 816316487c..2cd8cc3a74 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -27,7 +27,6 @@ open Clenv let _ = Detyping.print_evar_arguments := true let _ = Detyping.print_universes := true let _ = Goptions.set_bool_option_value ["Printing";"Matching"] false -let _ = Detyping.set_detype_anonymous (fun ?loc _ -> raise Not_found) (* std_ppcmds *) let pp x = Pp.pp_with !Topfmt.std_ft x diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 062e3ca8b2..82726eccf0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -708,9 +708,6 @@ type binder_kind = BProd | BLambda | BLetIn (**********************************************************************) (* Main detyping function *) -let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable.")) -let set_detype_anonymous f = detype_anonymous := f - let detype_level sigma l = let l = hack_qualid_of_univ_level sigma l in GType (UNamed l) @@ -732,11 +729,13 @@ and detype_r d flags avoid env sigma t = match EConstr.kind sigma (collapse_appl sigma t) with | Rel n -> (try match lookup_name_of_rel n (fst env) with - | Name id -> GVar id - | Anonymous -> GVar (!detype_anonymous n) + | Name id -> GVar id + | Anonymous -> + let s = "_ANONYMOUS_REL_"^(string_of_int n) in + GVar (Id.of_string s) with Not_found -> - let s = "_UNBOUND_REL_"^(string_of_int n) - in GVar (Id.of_string s)) + let s = "_UNBOUND_REL_"^(string_of_int n) + in GVar (Id.of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) if n = Constr_matching.special_meta then diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 1a8e97efb8..00b0578a52 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -68,9 +68,6 @@ val detype_closed_glob : ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> clo val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option -(* XXX: This is a hack and should go away *) -val set_detype_anonymous : (?loc:Loc.t -> int -> Id.t) -> unit - val force_wildcard : unit -> bool val synthetize_type : unit -> bool diff --git a/test-suite/bugs/closed/bug_10026.v b/test-suite/bugs/closed/bug_10026.v new file mode 100644 index 0000000000..0d3142d0f2 --- /dev/null +++ b/test-suite/bugs/closed/bug_10026.v @@ -0,0 +1,3 @@ +Require Import Coq.Lists.List. +Set Debug RAKAM. +Check fun _ => fold_right (fun A B => prod A B) unit _. diff --git a/test-suite/bugs/closed/bug_3754.v b/test-suite/bugs/closed/bug_3754.v new file mode 100644 index 0000000000..7031cbf132 --- /dev/null +++ b/test-suite/bugs/closed/bug_3754.v @@ -0,0 +1,287 @@ +Unset Strict Universe Declaration. +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) +(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 + coqtop version trunk (October 2014) *) + +Notation Type0 := Set. + +Notation idmap := (fun x => x). + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. + +Notation pr1 := projT1. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := + fun x => g (f x). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. +admit. +Defined. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. + +Notation "p @' q" := (concat p q) (at level 21, left associativity, + format "'[v' p '/' '@'' q ']'") : long_path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. +exact (match p with idpath => u end). +Defined. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. +exact (match p with idpath => idpath end). +Defined. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Local Open Scope trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. +Notation IsHProp := (IsTrunc -1). + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Local Open Scope path_scope. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + (p @ q) @ r = p @ (q @ r) := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : + r^ @ q = p -> q = r @ p. +admit. +Defined. + +Ltac with_rassoc tac := + repeat rewrite concat_pp_p; + tac; + + repeat rewrite concat_p_pp. + +Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp). + +Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A} + (r : w = f x) (p : x = y) (q : y = z) : + r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q). +admit. +Defined. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : + (ap f q) @ (p y) = (p x) @ (ap g q) + := + match q with + | idpath => concat_1p _ @ ((concat_p1 _) ^) + end. + +Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type) + {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) + : D x2 (p # y) (p # z) + := + match p with idpath => w end. +Local Open Scope equiv_scope. + +Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2) + : (transport (fun x => B x -> C) p f) y = f (p^ # y). +admit. +Defined. + +Definition transport_arrow_fromconst {A B : Type} {C : A -> Type} + {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B) + : (transport (fun x => B -> C x) p f) y = p # (f y). +admit. +Defined. + +Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2) + : ap (transport (fun x => B x -> C) p f) q + @ transport_arrow_toconst p f y2 + = transport_arrow_toconst p f y1 + @ ap (fun y => f (p^ # y)) q. +admit. +Defined. + +Class Univalence. +Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B). +admit. +Defined. +Definition transport_path_universe + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) + : transport (fun X:Type => X) (path_universe f) z = f z. +admit. +Defined. +Definition transport_path_universe_V `{Funext} + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B) + : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z. +admit. +Defined. + +Ltac simpl_do_clear tac term := + let H := fresh in + assert (H := term); + simpl in H |- *; + tac H; + clear H. + +Tactic Notation "simpl" "rewrite" constr(term) := simpl_do_clear ltac:(fun H => rewrite H) term. + +Global Instance Univalence_implies_Funext `{Univalence} : Funext. +Admitted. + +Section Factorization. + + Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)} + {A B : Type@{i}} {f : A -> B}. + + Record Factorization := + { intermediate : Type ; + factor1 : A -> intermediate ; + factor2 : intermediate -> B ; + fact_factors : factor2 o factor1 == f ; + inclass1 : class1 _ _ factor1 ; + inclass2 : class2 _ _ factor2 + }. + + Record PathFactorization {fact fact' : Factorization} := + { path_intermediate : intermediate fact <~> intermediate fact' ; + path_factor1 : path_intermediate o factor1 fact == factor1 fact' ; + path_factor2 : factor2 fact == factor2 fact' o path_intermediate ; + path_fact_factors : forall a, path_factor2 (factor1 fact a) + @ ap (factor2 fact') (path_factor1 a) + @ fact_factors fact' a + = fact_factors fact a + }. + Context `{Univalence} {fact fact' : Factorization} + (pf : @PathFactorization fact fact'). + + Let II := path_intermediate pf. + Let ff1 := path_factor1 pf. + Let ff2 := path_factor2 pf. +Local Definition II' : intermediate fact = intermediate fact'. +admit. +Defined. + + Local Definition fff' (a : A) + : (transportD2 (fun X => A -> X) (fun X => X -> B) + (fun X g h => {_ : forall a : A, h (g a) = f a & + {_ : class1 A X g & class2 X B h}}) + II' (factor1 fact) (factor2 fact) + (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a = + ap (transport (fun X => X -> B) II' (factor2 fact)) + (transport_arrow_fromconst II' (factor1 fact) a + @ transport_path_universe II (factor1 fact a) + @ ff1 a) + @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a) + @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a)) + @ ff2 (II^-1 (factor1 fact' a)) + @ ap (factor2 fact') (eisretr II (factor1 fact' a)) + @ fact_factors fact' a. + Proof. + + Open Scope long_path_scope. + + rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)). + + simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^) + (factor2 fact)). + rewrite <- ap_p_pp; rewrite_moveL_Mp_p. + Set Debug Tactic Unification. + rewrite (concat_Ap ff2). + Abort. + +End Factorization. diff --git a/test-suite/bugs/opened/bug_3754.v b/test-suite/bugs/opened/bug_3754.v deleted file mode 100644 index 18820b1a4c..0000000000 --- a/test-suite/bugs/opened/bug_3754.v +++ /dev/null @@ -1,285 +0,0 @@ -Unset Strict Universe Declaration. -Require Import TestSuite.admit. -(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) -(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 - coqtop version trunk (October 2014) *) - -Notation Type0 := Set. - -Notation idmap := (fun x => x). - -Notation "( x ; y )" := (existT _ x y) : fibration_scope. -Open Scope fibration_scope. - -Notation pr1 := projT1. - -Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. - -Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := - fun x => g (f x). - -Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. -Open Scope function_scope. - -Inductive paths {A : Type} (a : A) : A -> Type := - idpath : paths a a. - -Arguments idpath {A a} , [A] a. - -Notation "x = y :> A" := (@paths A x y) : type_scope. -Notation "x = y" := (x = y :>_) : type_scope. -Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. -admit. -Defined. - -Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := - match p, q with idpath, idpath => idpath end. - -Notation "1" := idpath : path_scope. - -Notation "p @ q" := (concat p q) (at level 20) : path_scope. - -Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. - -Notation "p @' q" := (concat p q) (at level 21, left associativity, - format "'[v' p '/' '@'' q ']'") : long_path_scope. -Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. -exact (match p with idpath => u end). -Defined. - -Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. -Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. -exact (match p with idpath => idpath end). -Defined. - -Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) - := forall x:A, f x = g x. - -Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. - -Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := - forall x : A, r (s x) = x. - -Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { - equiv_inv : B -> A ; - eisretr : Sect equiv_inv f; - eissect : Sect f equiv_inv; - eisadj : forall x : A, eisretr (f x) = ap f (eissect x) -}. - -Arguments eisretr {A B} f {_} _. - -Record Equiv A B := BuildEquiv { - equiv_fun : A -> B ; - equiv_isequiv : IsEquiv equiv_fun -}. - -Coercion equiv_fun : Equiv >-> Funclass. - -Global Existing Instance equiv_isequiv. - -Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. - -Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. - -Class Contr_internal (A : Type) := BuildContr { - center : A ; - contr : (forall y : A, center = y) -}. - -Inductive trunc_index : Type := -| minus_two : trunc_index -| trunc_S : trunc_index -> trunc_index. - -Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. -Local Open Scope trunc_scope. -Notation "-2" := minus_two (at level 0) : trunc_scope. -Notation "-1" := (-2.+1) (at level 0) : trunc_scope. - -Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := - match n with - | -2 => Contr_internal A - | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) - end. - -Class IsTrunc (n : trunc_index) (A : Type) : Type := - Trunc_is_trunc : IsTrunc_internal n A. -Notation IsHProp := (IsTrunc -1). - -Monomorphic Axiom dummy_funext_type : Type0. -Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. - -Local Open Scope path_scope. - -Definition concat_p1 {A : Type} {x y : A} (p : x = y) : - p @ 1 = p - := - match p with idpath => 1 end. - -Definition concat_1p {A : Type} {x y : A} (p : x = y) : - 1 @ p = p - := - match p with idpath => 1 end. - -Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : - p @ (q @ r) = (p @ q) @ r := - match r with idpath => - match q with idpath => - match p with idpath => 1 - end end end. - -Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : - (p @ q) @ r = p @ (q @ r) := - match r with idpath => - match q with idpath => - match p with idpath => 1 - end end end. - -Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : - r^ @ q = p -> q = r @ p. -admit. -Defined. - -Ltac with_rassoc tac := - repeat rewrite concat_pp_p; - tac; - - repeat rewrite concat_p_pp. - -Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp). - -Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A} - (r : w = f x) (p : x = y) (q : y = z) : - r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q). -admit. -Defined. - -Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : - ap (g o f) p = ap g (ap f p) - := - match p with idpath => 1 end. - -Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : - (ap f q) @ (p y) = (p x) @ (ap g q) - := - match q with - | idpath => concat_1p _ @ ((concat_p1 _) ^) - end. - -Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type) - {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) - : D x2 (p # y) (p # z) - := - match p with idpath => w end. -Local Open Scope equiv_scope. - -Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} - {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2) - : (transport (fun x => B x -> C) p f) y = f (p^ # y). -admit. -Defined. - -Definition transport_arrow_fromconst {A B : Type} {C : A -> Type} - {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B) - : (transport (fun x => B -> C x) p f) y = p # (f y). -admit. -Defined. - -Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} - {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2) - : ap (transport (fun x => B x -> C) p f) q - @ transport_arrow_toconst p f y2 - = transport_arrow_toconst p f y1 - @ ap (fun y => f (p^ # y)) q. -admit. -Defined. - -Class Univalence. -Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B). -admit. -Defined. -Definition transport_path_universe - {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) - : transport (fun X:Type => X) (path_universe f) z = f z. -admit. -Defined. -Definition transport_path_universe_V `{Funext} - {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B) - : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z. -admit. -Defined. - -Ltac simpl_do_clear tac term := - let H := fresh in - assert (H := term); - simpl in H |- *; - tac H; - clear H. - -Tactic Notation "simpl" "rewrite" constr(term) := simpl_do_clear ltac:(fun H => rewrite H) term. - -Global Instance Univalence_implies_Funext `{Univalence} : Funext. -Admitted. - -Section Factorization. - - Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}} - `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)} - `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)} - {A B : Type@{i}} {f : A -> B}. - - Record Factorization := - { intermediate : Type ; - factor1 : A -> intermediate ; - factor2 : intermediate -> B ; - fact_factors : factor2 o factor1 == f ; - inclass1 : class1 _ _ factor1 ; - inclass2 : class2 _ _ factor2 - }. - - Record PathFactorization {fact fact' : Factorization} := - { path_intermediate : intermediate fact <~> intermediate fact' ; - path_factor1 : path_intermediate o factor1 fact == factor1 fact' ; - path_factor2 : factor2 fact == factor2 fact' o path_intermediate ; - path_fact_factors : forall a, path_factor2 (factor1 fact a) - @ ap (factor2 fact') (path_factor1 a) - @ fact_factors fact' a - = fact_factors fact a - }. - Context `{Univalence} {fact fact' : Factorization} - (pf : @PathFactorization fact fact'). - - Let II := path_intermediate pf. - Let ff1 := path_factor1 pf. - Let ff2 := path_factor2 pf. -Local Definition II' : intermediate fact = intermediate fact'. -admit. -Defined. - - Local Definition fff' (a : A) - : (transportD2 (fun X => A -> X) (fun X => X -> B) - (fun X g h => {_ : forall a : A, h (g a) = f a & - {_ : class1 A X g & class2 X B h}}) - II' (factor1 fact) (factor2 fact) - (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a = - ap (transport (fun X => X -> B) II' (factor2 fact)) - (transport_arrow_fromconst II' (factor1 fact) a - @ transport_path_universe II (factor1 fact a) - @ ff1 a) - @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a) - @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a)) - @ ff2 (II^-1 (factor1 fact' a)) - @ ap (factor2 fact') (eisretr II (factor1 fact' a)) - @ fact_factors fact' a. - Proof. - - Open Scope long_path_scope. - - rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)). - - simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^) - (factor2 fact)). - rewrite <- ap_p_pp; rewrite_moveL_Mp_p. - Set Debug Tactic Unification. - Fail rewrite (concat_Ap ff2). - Abort. -- cgit v1.2.3 From 96f31931743c950f006682a398c501c30e96fda0 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 13 May 2019 11:40:03 +0200 Subject: Add overlay for Unicoq --- dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh diff --git a/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh b/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh new file mode 100644 index 0000000000..bc8aa33565 --- /dev/null +++ b/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10135" ] || [ "$CI_BRANCH" = "detype-anonymous" ]; then + + unicoq_CI_REF=detype-anonymous + unicoq_CI_GITURL=https://github.com/maximedenes/unicoq + +fi -- cgit v1.2.3 From d0f2961b1e4c4f8153d1deb3ea7a3e5fc1eb22cc Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 13 May 2019 15:36:43 +0200 Subject: Move last changelog entries for 8.10+beta1. --- .../03-notations/10061-print-custom-grammar.rst | 4 -- doc/changelog/04-tactics/09996-hint-mode.rst | 5 --- doc/changelog/04-tactics/10059-change-no-check.rst | 7 --- doc/changelog/06-ssreflect/09995-notations.rst | 8 ---- .../09984-pairusualdecidabletypefull.rst | 3 -- doc/changelog/12-misc/09964-changes.rst | 14 ------ doc/sphinx/changes.rst | 50 +++++++++++++++++++++- 7 files changed, 49 insertions(+), 42 deletions(-) delete mode 100644 doc/changelog/03-notations/10061-print-custom-grammar.rst delete mode 100644 doc/changelog/04-tactics/09996-hint-mode.rst delete mode 100644 doc/changelog/04-tactics/10059-change-no-check.rst delete mode 100644 doc/changelog/06-ssreflect/09995-notations.rst delete mode 100644 doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst delete mode 100644 doc/changelog/12-misc/09964-changes.rst diff --git a/doc/changelog/03-notations/10061-print-custom-grammar.rst b/doc/changelog/03-notations/10061-print-custom-grammar.rst deleted file mode 100644 index 8786c7ce6b..0000000000 --- a/doc/changelog/03-notations/10061-print-custom-grammar.rst +++ /dev/null @@ -1,4 +0,0 @@ -- Allow inspecting custom grammar entries by :cmd:`Print Custom Grammar` - (`#10061 `_, - fixes `#9681 `_, - by Jasper Hugunin, review by Pierre-Marie Pédrot and Hugo Herbelin). diff --git a/doc/changelog/04-tactics/09996-hint-mode.rst b/doc/changelog/04-tactics/09996-hint-mode.rst deleted file mode 100644 index 06e9059b45..0000000000 --- a/doc/changelog/04-tactics/09996-hint-mode.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Modes are now taken into account by :tacn:`typeclasses eauto` for - local hypotheses - (`#9996 `_, - fixes `#5752 `_, - by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/10059-change-no-check.rst b/doc/changelog/04-tactics/10059-change-no-check.rst deleted file mode 100644 index 987b2a8ccd..0000000000 --- a/doc/changelog/04-tactics/10059-change-no-check.rst +++ /dev/null @@ -1,7 +0,0 @@ -- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a - documented replacement of :tacn:`convert_concl_no_check` - (`#10012 `_, - `#10017 `_, - `#10053 `_, and - `#10059 `_, - by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/06-ssreflect/09995-notations.rst b/doc/changelog/06-ssreflect/09995-notations.rst deleted file mode 100644 index 3dfc45242d..0000000000 --- a/doc/changelog/06-ssreflect/09995-notations.rst +++ /dev/null @@ -1,8 +0,0 @@ -- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. - New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion - class, simplified `predType` interface: `pred_class` and `mkPredType` - deprecated, `{pred T}` and `PredType` should be used instead. - `if c return t then ...` now expects `c` to be a variable bound in `t`. - New `nonPropType` interface matching types that do _not_ have sort `Prop`. - New `relpre R f` definition for the preimage of a relation R under f - (`#9995 `_, by Georges Gonthier). diff --git a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst deleted file mode 100644 index 732c088f45..0000000000 --- a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` - (`#9984 `_, - by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/12-misc/09964-changes.rst b/doc/changelog/12-misc/09964-changes.rst deleted file mode 100644 index dd873cfdd5..0000000000 --- a/doc/changelog/12-misc/09964-changes.rst +++ /dev/null @@ -1,14 +0,0 @@ -- Changelog has been moved from a specific file `CHANGES.md` to the - reference manual; former Credits chapter of the reference manual has - been split in two parts: a History chapter which was enriched with - additional historical information about Coq versions 1 to 5, and a - Changes chapter which was enriched with the content formerly in - `CHANGES.md` and `COMPATIBILITY` - (`#9133 `_, - `#9668 `_, - `#9939 `_, - `#9964 `_, - and `#10085 `_, - by Théo Zimmermann, - with help and ideas from Emilio Jesús Gallego Arias, Gaëtan - Gilbert, Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 574b943a78..be22071f66 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -355,6 +355,11 @@ Other changes in 8.10+beta1 that will do it automatically, using the output of ``coqc`` (`#8638 `_, by Jason Gross). + - Allow inspecting custom grammar entries by :cmd:`Print Custom Grammar` + (`#10061 `_, + fixes `#9681 `_, + by Jasper Hugunin, review by Pierre-Marie Pédrot and Hugo Herbelin). + - The `quote plugin `_ was removed. If some users are interested in maintaining this plugin @@ -400,7 +405,23 @@ Other changes in 8.10+beta1 closes `#7632 `_, by Théo Zimmermann). - - SSReflect clear discipline made consistent across the entire proof language. + - Modes are now taken into account by :tacn:`typeclasses eauto` for + local hypotheses + (`#9996 `_, + fixes `#5752 `_, + by Maxime Dénès, review by Pierre-Marie Pédrot). + + - New variant :tacn:`change_no_check` of :tacn:`change`, usable as a + documented replacement of :tacn:`convert_concl_no_check` + (`#10012 `_, + `#10017 `_, + `#10053 `_, and + `#10059 `_, + by Hugo Herbelin and Paolo G. Giarrusso). + +- SSReflect: + + - Clear discipline made consistent across the entire proof language. Whenever a clear switch `{x..}` comes immediately before an existing proof context entry (used as a view, as a rewrite rule or as name for a new context entry) then such entry is cleared too. @@ -414,6 +435,15 @@ Other changes in 8.10+beta1 (`#9341 `_, by Enrico Tassi). + - `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + `if c return t then ...` now expects `c` to be a variable bound in `t`. + New `nonPropType` interface matching types that do _not_ have sort `Prop`. + New `relpre R f` definition for the preimage of a relation R under f + (`#9995 `_, by Georges Gonthier). + - Vernacular commands: - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. @@ -535,10 +565,28 @@ Other changes in 8.10+beta1 `fset` database (`#9725 `_, by Frédéric Besson). + - Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` + (`#9984 `_, + by Jean-Christophe Léchenet and Oliver Nash). + - Some error messages that show problems with a pair of non-matching values will now highlight the differences (`#8669 `_, by Jim Fehrle). +- Changelog has been moved from a specific file `CHANGES.md` to the + reference manual; former Credits chapter of the reference manual has + been split in two parts: a History chapter which was enriched with + additional historical information about Coq versions 1 to 5, and a + Changes chapter which was enriched with the content formerly in + `CHANGES.md` and `COMPATIBILITY` + (`#9133 `_, + `#9668 `_, + `#9939 `_, + `#9964 `_, + and `#10085 `_, + by Théo Zimmermann, + with help and ideas from Emilio Jesús Gallego Arias, Gaëtan + Gilbert, Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). Version 8.9 ----------- -- cgit v1.2.3 From 5a172d9afaddf44e702af66f80bd5649031c9e4a Mon Sep 17 00:00:00 2001 From: Théo Zimmermann Date: Mon, 13 May 2019 16:38:40 +0200 Subject: Missing change entry for #9854. --- doc/sphinx/changes.rst | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index be22071f66..cca3b2e06b 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -419,6 +419,15 @@ Other changes in 8.10+beta1 `#10059 `_, by Hugo Herbelin and Paolo G. Giarrusso). + - The simplified value returned by :tacn:`field_simplify` is not + always a fraction anymore. When the denominator is :g:`1`, it + returns :g:`x` while previously it was returning :g:`x/1`. This + change could break codes that were post-processing application of + :tacn:`field_simplify` to get rid of these :g:`x/1` + (`#9854 `_, + by Laurent Théry, + with help from Michael Soegtrop, Maxime Dénès, and Vincent Laporte). + - SSReflect: - Clear discipline made consistent across the entire proof language. -- cgit v1.2.3 From 6211fd6e067e781a160db8765dd87067428048f2 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 1 Nov 2018 23:26:06 +0100 Subject: Moving Evd.evars_of_term from constr to econstr + consequences. This impacts a lot of code, apparently in the good, removing several conversions back and forth constr. --- engine/evarutil.ml | 6 +++--- engine/evd.mli | 2 +- engine/proofview.ml | 2 +- engine/termops.ml | 2 +- plugins/ssr/ssrview.ml | 2 +- plugins/ssrmatching/ssrmatching.ml | 4 ++-- stm/proofBlockDelimiter.ml | 2 +- vernac/classes.ml | 7 ++++--- vernac/comDefinition.ml | 7 ++++--- vernac/comProgramFixpoint.ml | 17 +++++------------ vernac/obligations.ml | 34 ++++++++++++++++------------------ vernac/obligations.mli | 4 ++-- 12 files changed, 41 insertions(+), 48 deletions(-) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index be0318fbde..6888526f5b 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -657,7 +657,7 @@ let clear_hyps2_in_evi env sigma hyps t concl ids = let queue_set q is_dependent set = Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set let queue_term q is_dependent c = - queue_set q is_dependent (evars_of_term (EConstr.Unsafe.to_constr c)) + queue_set q is_dependent (evars_of_term c) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in @@ -675,7 +675,7 @@ let process_dependent_evar q acc evm is_dependent e = | Evar_empty -> if is_dependent then Evar.Map.add e None acc else acc | Evar_defined b -> - let subevars = evars_of_term (EConstr.Unsafe.to_constr b) in + let subevars = evars_of_term b in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another @@ -795,7 +795,7 @@ let filtered_undefined_evars_of_evar_info ?cache sigma evi = in let accu = match evi.evar_body with | Evar_empty -> Evar.Set.empty - | Evar_defined b -> evars_of_term (EConstr.Unsafe.to_constr b) + | Evar_defined b -> evars_of_term b in let accu = Evar.Set.union (undefined_evars_of_term sigma evi.evar_concl) accu in let ctxt = EConstr.Unsafe.to_named_context (evar_filtered_context evi) in diff --git a/engine/evd.mli b/engine/evd.mli index 29235050b0..3cb4031f11 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -495,7 +495,7 @@ val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t option contained in the object; need the term to be evar-normal otherwise defined evars are returned too. *) -val evars_of_term : constr -> Evar.Set.t +val evars_of_term : econstr -> Evar.Set.t (** including evars in instances of evars *) val evars_of_named_context : (econstr, etypes) Context.Named.pt -> Evar.Set.t diff --git a/engine/proofview.ml b/engine/proofview.ml index ecea637947..b77839c28e 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1253,7 +1253,7 @@ module V82 = struct let top_evars initial = let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term (EConstr.Unsafe.to_constr c)) + Evar.Set.elements (Evd.evars_of_term c) in CList.flatten (CList.map evars_of_initial initial) diff --git a/engine/termops.ml b/engine/termops.ml index 8a6bd17948..67fc8edf6e 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -187,7 +187,7 @@ let compute_evar_dependency_graph sigma = in match evar_body evi with | Evar_empty -> acc - | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term (EConstr.Unsafe.to_constr c)) acc + | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc in Evd.fold fold sigma EvMap.empty diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 075ebf006a..57a068f82a 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -290,7 +290,7 @@ let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in + let evars_of_p = Evd.evars_of_term p in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 4e0866a0c5..e421b31227 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -544,7 +544,7 @@ let dont_impact_evars_in cl = (* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) (* match a head let rigidly. *) let match_upats_FO upats env sigma0 ise orig_c = - let dont_impact_evars = dont_impact_evars_in orig_c in + let dont_impact_evars = dont_impact_evars_in (EConstr.of_constr orig_c) in let rec loop c = let f, a = splay_app ise c in let i0 = ref (-1) in let fpats = @@ -586,7 +586,7 @@ let match_upats_FO upats env sigma0 ise orig_c = let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in c in + let dont_impact_evars = dont_impact_evars_in (EConstr.of_constr c) in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 2b32838964..74a3ee035c 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -41,7 +41,7 @@ let simple_goal sigma g gs = let open Evd in let open Evarutil in let evi = Evd.find sigma g in - Set.is_empty (evars_of_term (EConstr.Unsafe.to_constr evi.evar_concl)) && + Set.is_empty (evars_of_term evi.evar_concl) && Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && not (List.exists (Proofview.depends_on sigma g) gs) diff --git a/vernac/classes.ml b/vernac/classes.ml index 9f233a2551..ece9fc8937 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -374,6 +374,7 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po let obls, constr, typ = match term with | Some t -> + let termtype = EConstr.of_constr termtype in let obls, _, constr, typ = Obligations.eterm_obligations env id sigma 0 t termtype in obls, Some constr, typ @@ -400,7 +401,7 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); + Refine.refine ~typecheck:false (fun sigma -> (sigma, Option.get term)); Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); Tactics.New.reduce_after_refine; ] @@ -497,10 +498,10 @@ let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program (* Check that the type is free of evars now. *) Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in - let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in let pstate = if not (Evd.has_undefined sigma) && not (Option.is_empty props) then - (declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype; + let term = to_constr sigma (Option.get term) in + (declare_instance_constant k pri global imps ?hook id decl poly sigma term termtype; None) else if program_mode || refine || Option.is_empty props then declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 12df3215ad..d2c986fe5c 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -88,11 +88,12 @@ let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ct let (c,ctx), sideff = Future.force ce.const_entry_body in assert(Safe_typing.empty_private_constants = sideff); assert(Univ.ContextSet.is_empty ctx); + Obligations.check_evars env evd; + let c = EConstr.of_constr c in let typ = match ce.const_entry_type with - | Some t -> t - | None -> EConstr.to_constr ~abort_on_undefined_evars:false evd (Retyping.get_type_of env evd (EConstr.of_constr c)) + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env evd c in - Obligations.check_evars env evd; let obls, _, c, cty = Obligations.eterm_obligations env ident evd 0 c typ in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 20a2db7ca2..3befdc5885 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -230,12 +230,9 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = Lemmas.mk_hook (hook sigma) in - (* XXX: Grounding non-ground terms here... bad bad *) - let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in - let fullctyp = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in Obligations.check_evars env sigma; let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname sigma 0 fullcoqc fullctyp + Obligations.eterm_obligations env recname sigma 0 def typ in let ctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl @@ -262,17 +259,13 @@ let do_program_recursive local poly fixkind fixl ntns = let evd = nf_evar_map_undefined evd in let collect_evars id def typ imps = (* Generalize by the recursive prototypes *) - let def = - EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) - and typ = - (* Worrying... *) - EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) - in + let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in + let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = Obligations.eterm_obligations env id evm - (List.length rec_sign) def typ - in (id, def, typ, imps, evars) + (List.length rec_sign) def typ in + (id, def, typ, imps, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 1b1c618dc7..771ae2053f 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -39,7 +39,7 @@ let check_evars env evm = type oblinfo = { ev_name: int * Id.t; - ev_hyps: Constr.named_context; + ev_hyps: EConstr.named_context; ev_status: bool * Evar_kinds.obligation_definition_status; ev_chop: int option; ev_src: Evar_kinds.t Loc.located; @@ -50,11 +50,11 @@ type oblinfo = (** Substitute evar references in t using de Bruijn indices, where n binders were passed through. *) -let subst_evar_constr evs n idf t = +let subst_evar_constr evm evs n idf t = let seen = ref Int.Set.empty in let transparent = ref Id.Set.empty in let evar_info id = List.assoc_f Evar.equal id evs in - let rec substrec (depth, fixrels) c = match Constr.kind c with + let rec substrec (depth, fixrels) c = match EConstr.kind evm c with | Evar (k, args) -> let { ev_name = (id, idstr) ; ev_hyps = hyps ; ev_chop = chop } = @@ -84,18 +84,18 @@ let subst_evar_constr evs n idf t = in aux hyps args [] in if List.exists - (fun x -> match Constr.kind x with + (fun x -> match EConstr.kind evm x with | Rel n -> Int.List.mem n fixrels | _ -> false) args then transparent := Id.Set.add idstr !transparent; - mkApp (idf idstr, Array.of_list args) + EConstr.mkApp (idf idstr, Array.of_list args) | Fix _ -> - Constr.map_with_binders succfix substrec (depth, 1 :: fixrels) c - | _ -> Constr.map_with_binders succfix substrec (depth, fixrels) c + EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c + | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c in let t' = substrec (0, []) t in - t', !seen, !transparent + EConstr.to_constr evm t', !seen, !transparent (** Substitute variable references in t using de Bruijn indices, @@ -112,18 +112,18 @@ let subst_vars acc n t = to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. *) -let etype_of_evar evs hyps concl = +let etype_of_evar evm evs hyps concl = let open Context.Named.Declaration in let rec aux acc n = function decl :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar (NamedDecl.get_type decl) in + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in let t'' = subst_vars acc 0 t' in let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in let s' = Int.Set.union s s' in let trans' = Id.Set.union trans trans' in (match decl with | LocalDef (id,c,_) -> - let c', s'', trans'' = subst_evar_constr evs n mkVar c in + let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, Int.Set.union s'' s', @@ -131,7 +131,7 @@ let etype_of_evar evs hyps concl = | LocalAssum (id,_) -> mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> - let t', s, trans = subst_evar_constr evs n mkVar concl in + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in subst_vars acc 0 t', s, trans in aux [] 0 (List.rev hyps) @@ -209,9 +209,7 @@ let eterm_obligations env name evm fs ?status t ty = (fun (id, (n, nstr), ev) l -> let hyps = Evd.evar_filtered_context ev in let hyps = trunc_named_context nc_len hyps in - let hyps = EConstr.Unsafe.to_named_context hyps in - let concl = EConstr.Unsafe.to_constr ev.evar_concl in - let evtyp, deps, transp = etype_of_evar l hyps concl in + let evtyp, deps, transp = etype_of_evar evm l hyps ev.evar_concl in let evtyp, hyps, chop = match chop_product fs evtyp with | Some t -> t, trunc_named_context fs hyps, fs @@ -237,9 +235,9 @@ let eterm_obligations env name evm fs ?status t ty = evn [] in let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evts 0 mkVar t + subst_evar_constr evm evts 0 EConstr.mkVar t in - let ty, _, _ = subst_evar_constr evts 0 mkVar ty in + let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in let evars = List.map (fun (ev, info) -> let { ev_name = (_, name); ev_status = force_status, status; @@ -252,7 +250,7 @@ let eterm_obligations env name evm fs ?status t ty = in name, typ, src, (force_status, status), deps, tac) evts in let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in - let evmap f c = pi1 (subst_evar_constr evts 0 f c) in + let evmap f c = pi1 (subst_evar_constr evm evts 0 f c) in Array.of_list (List.rev evars), (evnames, evmap), t', ty let hide_obligation () = diff --git a/vernac/obligations.mli b/vernac/obligations.mli index d25daeed9c..9214ddd4b9 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -26,14 +26,14 @@ val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar (* env, id, evars, number of function prototypes to try to clear from evars contexts, object and type *) val eterm_obligations : env -> Id.t -> evar_map -> int -> - ?status:Evar_kinds.obligation_definition_status -> constr -> types -> + ?status:Evar_kinds.obligation_definition_status -> EConstr.constr -> EConstr.types -> (Id.t * types * Evar_kinds.t Loc.located * (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array (* Existential key, obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) - * ((Evar.t * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * + * ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * constr * types (* Translations from existential identifiers to obligation identifiers and for terms with existentials to closed terms, given a -- cgit v1.2.3 From 6608f64f001f8f1a50b2dc41fefdf63c0b84b270 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 2 Nov 2018 00:17:47 +0100 Subject: Passing evar_map to evars_of_term rather than expecting the term to be evar-nf. --- engine/evarutil.ml | 14 +++++----- engine/evd.ml | 54 +++++++++++++++++++------------------- engine/evd.mli | 11 ++++---- engine/proofview.ml | 6 ++--- engine/proofview.mli | 2 +- engine/termops.ml | 2 +- plugins/ssr/ssrview.ml | 4 +-- plugins/ssrmatching/ssrmatching.ml | 8 +++--- proofs/proof.ml | 2 +- stm/proofBlockDelimiter.ml | 4 +-- vernac/comProgramFixpoint.ml | 2 +- vernac/obligations.ml | 2 +- 12 files changed, 55 insertions(+), 56 deletions(-) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 6888526f5b..0a5bba39b9 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -656,26 +656,26 @@ let clear_hyps2_in_evi env sigma hyps t concl ids = (* spiwack: a few functions to gather evars on which goals depend. *) let queue_set q is_dependent set = Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set -let queue_term q is_dependent c = - queue_set q is_dependent (evars_of_term c) +let queue_term evm q is_dependent c = + queue_set q is_dependent (evars_of_term evm c) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) - queue_term q true evi.evar_concl; + queue_term evm q true evi.evar_concl; List.iter begin fun decl -> let open NamedDecl in - queue_term q true (NamedDecl.get_type decl); + queue_term evm q true (NamedDecl.get_type decl); match decl with | LocalAssum _ -> () - | LocalDef (_,b,_) -> queue_term q true b + | LocalDef (_,b,_) -> queue_term evm q true b end (EConstr.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> if is_dependent then Evar.Map.add e None acc else acc | Evar_defined b -> - let subevars = evars_of_term b in + let subevars = evars_of_term evm b in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another @@ -795,7 +795,7 @@ let filtered_undefined_evars_of_evar_info ?cache sigma evi = in let accu = match evi.evar_body with | Evar_empty -> Evar.Set.empty - | Evar_defined b -> evars_of_term b + | Evar_defined b -> evars_of_term sigma b in let accu = Evar.Set.union (undefined_evars_of_term sigma evi.evar_concl) accu in let ctxt = EConstr.Unsafe.to_named_context (evar_filtered_context evi) in diff --git a/engine/evd.ml b/engine/evd.ml index d37b49e2dc..0f10a380d3 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -823,33 +823,6 @@ let loc_of_conv_pb evd (pbty,env,t1,t2) = | Evar (evk2,_) -> fst (evar_source evk2 evd) | _ -> None -(** The following functions return the set of evars immediately - contained in the object *) - -(* excluding defined evars *) - -let evars_of_term c = - let rec evrec acc c = - match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) - | _ -> Constr.fold evrec acc c - in - evrec Evar.Set.empty c - -let evars_of_named_context nc = - Context.Named.fold_outside - (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term constr))) - nc - ~init:Evar.Set.empty - -let evars_of_filtered_evar_info evi = - Evar.Set.union (evars_of_term evi.evar_concl) - (Evar.Set.union - (match evi.evar_body with - | Evar_empty -> Evar.Set.empty - | Evar_defined b -> evars_of_term b) - (evars_of_named_context (evar_filtered_context evi))) - (**********************************************************) (* Sort variables *) @@ -1404,3 +1377,30 @@ module MiniEConstr = struct let to_rel_decl sigma d = Context.Rel.Declaration.map_constr (to_constr sigma) d end + +(** The following functions return the set of evars immediately + contained in the object *) + +(* excluding defined evars *) + +let evars_of_term evd c = + let rec evrec acc c = + match MiniEConstr.kind evd c with + | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | _ -> Constr.fold evrec acc c + in + evrec Evar.Set.empty c + +let evars_of_named_context evd nc = + Context.Named.fold_outside + (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term evd constr))) + nc + ~init:Evar.Set.empty + +let evars_of_filtered_evar_info evd evi = + Evar.Set.union (evars_of_term evd evi.evar_concl) + (Evar.Set.union + (match evi.evar_body with + | Evar_empty -> Evar.Set.empty + | Evar_defined b -> evars_of_term evd b) + (evars_of_named_context evd (evar_filtered_context evi))) diff --git a/engine/evd.mli b/engine/evd.mli index 3cb4031f11..587a1de044 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -491,16 +491,15 @@ val extract_changed_conv_pbs : evar_map -> val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t option -(** The following functions return the set of evars immediately - contained in the object; need the term to be evar-normal otherwise - defined evars are returned too. *) +(** The following functions return the set of undefined evars + contained in the object. *) -val evars_of_term : econstr -> Evar.Set.t +val evars_of_term : evar_map -> econstr -> Evar.Set.t (** including evars in instances of evars *) -val evars_of_named_context : (econstr, etypes) Context.Named.pt -> Evar.Set.t +val evars_of_named_context : evar_map -> (econstr, etypes) Context.Named.pt -> Evar.Set.t -val evars_of_filtered_evar_info : evar_info -> Evar.Set.t +val evars_of_filtered_evar_info : evar_map -> evar_info -> Evar.Set.t (** Metas *) val meta_list : evar_map -> (metavariable * clbinding) list diff --git a/engine/proofview.ml b/engine/proofview.ml index b77839c28e..1fd8b5d50e 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -641,7 +641,7 @@ let shelve_goals l = [sigma]. *) let depends_on sigma src tgt = let evi = Evd.find sigma tgt in - Evar.Set.mem src (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) + Evar.Set.mem src (Evd.evars_of_filtered_evar_info sigma (Evarutil.nf_evar_info sigma evi)) let unifiable_delayed g l = CList.exists (fun (tgt, lazy evs) -> not (Evar.equal g tgt) && Evar.Set.mem g evs) l @@ -1251,9 +1251,9 @@ module V82 = struct let goals = CList.map (fun (t,_) -> fst (Constr.destEvar (EConstr.Unsafe.to_constr t))) initial in { Evd.it = goals ; sigma=solution; } - let top_evars initial = + let top_evars initial { solution=sigma; } = let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term c) + Evar.Set.elements (Evd.evars_of_term sigma c) in CList.flatten (CList.map evars_of_initial initial) diff --git a/engine/proofview.mli b/engine/proofview.mli index 92f8b86df5..b7ff3ac432 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -595,7 +595,7 @@ module V82 : sig val top_goals : entry -> proofview -> Evar.t list Evd.sigma (* returns the existential variable used to start the proof *) - val top_evars : entry -> Evar.t list + val top_evars : entry -> proofview -> Evar.t list (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as diff --git a/engine/termops.ml b/engine/termops.ml index 67fc8edf6e..fcacb53ac4 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -187,7 +187,7 @@ let compute_evar_dependency_graph sigma = in match evar_body evi with | Evar_empty -> acc - | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc + | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term sigma c) acc in Evd.fold fold sigma EvMap.empty diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 57a068f82a..0a5c85f4ab 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -290,7 +290,7 @@ let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term p in + let evars_of_p = Evd.evars_of_term sigma p in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in @@ -307,7 +307,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let und0 = (* Unassigned evars in the initial goal *) let sigma0 = Tacmach.project s0 in let g0info = Evd.find sigma0 (Tacmach.sig_it s0) in - let g0 = Evd.evars_of_filtered_evar_info g0info in + let g0 = Evd.evars_of_filtered_evar_info sigma0 g0info in List.filter (fun k -> Evar.Set.mem k g0) (List.map fst (Evar.Map.bindings (Evd.undefined_map sigma0))) in let rigid = rigid_of und0 in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index e421b31227..adbcfb8f3b 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -529,8 +529,8 @@ exception FoundUnif of (evar_map * UState.t * tpattern) (* Note: we don't update env as we descend into the term, as the primitive *) (* unification procedure always rejects subterms with bound variables. *) -let dont_impact_evars_in cl = - let evs_in_cl = Evd.evars_of_term cl in +let dont_impact_evars_in sigma0 cl = + let evs_in_cl = Evd.evars_of_term sigma0 cl in fun sigma -> Evar.Set.for_all (fun k -> try let _ = Evd.find_undefined sigma k in true with Not_found -> false) evs_in_cl @@ -544,7 +544,7 @@ let dont_impact_evars_in cl = (* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) (* match a head let rigidly. *) let match_upats_FO upats env sigma0 ise orig_c = - let dont_impact_evars = dont_impact_evars_in (EConstr.of_constr orig_c) in + let dont_impact_evars = dont_impact_evars_in sigma0 (EConstr.of_constr orig_c) in let rec loop c = let f, a = splay_app ise c in let i0 = ref (-1) in let fpats = @@ -586,7 +586,7 @@ let match_upats_FO upats env sigma0 ise orig_c = let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in (EConstr.of_constr c) in + let dont_impact_evars = dont_impact_evars_in sigma0 (EConstr.of_constr c) in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = diff --git a/proofs/proof.ml b/proofs/proof.ml index 778d98b2cd..567012c15f 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -425,7 +425,7 @@ module V82 = struct { Evd.it=List.hd gls ; sigma=sigma; } let top_evars p = - Proofview.V82.top_evars p.entry + Proofview.V82.top_evars p.entry p.proofview let grab_evars p = if not (is_done p) then diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 74a3ee035c..04f10e7399 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -41,8 +41,8 @@ let simple_goal sigma g gs = let open Evd in let open Evarutil in let evi = Evd.find sigma g in - Set.is_empty (evars_of_term evi.evar_concl) && - Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && + Set.is_empty (evars_of_term sigma evi.evar_concl) && + Set.is_empty (evars_of_filtered_evar_info sigma (nf_evar_info sigma evi)) && not (List.exists (Proofview.depends_on sigma g) gs) let is_focused_goal_simple ~doc id = diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3befdc5885..69e2a209eb 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -243,7 +243,7 @@ let out_def = function | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") let collect_evars_of_term evd c ty = - let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in + let evars = Evar.Set.union (Evd.evars_of_term evd c) (Evd.evars_of_term evd ty) in Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 771ae2053f..f768278dd7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -151,7 +151,7 @@ let evar_dependencies evm oev = let one_step deps = Evar.Set.fold (fun ev s -> let evi = Evd.find evm ev in - let deps' = evars_of_filtered_evar_info evi in + let deps' = evars_of_filtered_evar_info evm evi in if Evar.Set.mem oev deps' then invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print oev) else Evar.Set.union deps' s) -- cgit v1.2.3 From ce083774403b70d58c71c5a6ba104c337613add4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 12 Nov 2018 23:37:47 +0100 Subject: Adding overlay for Equations. --- .../08893-herbelin-master+moving-evars-of-term-on-econstr.sh | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh diff --git a/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh b/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh new file mode 100644 index 0000000000..dc39ea5ef0 --- /dev/null +++ b/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh @@ -0,0 +1,7 @@ +if [ "$CI_PULL_REQUEST" = "8893" ] || [ "$CI_BRANCH" = "master+moving-evars-of-term-on-econstr" ]; then + + equations_CI_BRANCH=master+fix-evars_of_term-pr8893 + equations_CI_REF=master+fix-evars_of_term-pr8893 + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + +fi -- cgit v1.2.3 From 5e1238260c32227f8568fb1328f922cdeaa8dfc8 Mon Sep 17 00:00:00 2001 From: Jim Fehrle Date: Sun, 12 May 2019 17:44:04 -0700 Subject: Handle tags shorter than "diff." without an exception --- vernac/topfmt.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 118c126970..bf2efb2542 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -201,7 +201,7 @@ let set_emacs_print_strings () = let diff = "diff." in List.iter (fun b -> let (name, attrs) = b in - if diff = (String.sub name 0 (String.length diff)) then + if CString.is_sub diff name 0 then tag_map := CString.Map.add name { attrs with prefix = Some (Printf.sprintf "<%s>" name); suffix = Some (Printf.sprintf "" name) } -- cgit v1.2.3 From d452f359566ec6593aad564acb281f5a49dd931a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 8 May 2019 21:12:09 +0200 Subject: Option -check-vio-tasks: fail gracefully when not finding expected integers. --- toplevel/coqcargs.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 7445619d26..c3f099869c 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -82,7 +82,14 @@ let set_vio_checking_j opts opt j = prerr_endline "setting the J variable like in 'make vio2vo J=3'"; exit 1 -let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) +let get_task_list s = + List.map (fun s -> + try int_of_string s + with Failure _ -> + prerr_endline "Option -check-vio-tasks expects a comma-separated list"; + prerr_endline "of integers followed by a list of files"; + exit 1) + (Str.split (Str.regexp ",") s) let is_not_dash_option = function | Some f when String.length f > 0 && f.[0] <> '-' -> true -- cgit v1.2.3 From 63a953ddc0db1ec1bf101ed6afdf9262d0d9f355 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 8 May 2019 21:28:25 +0200 Subject: Ensuring suffix of file to compile also for -vio2vo checking. We do it by consistently using variants of the "ensure_exists" policy in compilation modes: vo (default), vio (-quick), vio2vo (-vio2vo) and parallel vio2vo (schedule-vio2vo), vio checking (-check-vio-tasks) and parallel vio checking (schedule-vio-checking). For instance, coqc -vio2vo dir/file.vio now works, while before, dir/file was expected. Incidentally, this avoids the non-recommended Loadpath.locate_file. --- library/library.ml | 19 ++++++++---------- library/library.mli | 2 +- stm/vio_checking.ml | 31 ++++++++++++------------------ toplevel/ccompile.ml | 54 ++++++++++++++++++++++++++++------------------------ 4 files changed, 50 insertions(+), 56 deletions(-) diff --git a/library/library.ml b/library/library.ml index 04e38296d9..500e77f89b 100644 --- a/library/library.ml +++ b/library/library.ml @@ -612,8 +612,6 @@ let import_module export modl = (*s Initializing the compilation of a library. *) let load_library_todo f = - let longf = Loadpath.locate_file (f^".v") in - let f = longf^"io" in let ch = raw_intern_library f in let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in @@ -626,7 +624,7 @@ let load_library_todo f = if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); if pi3 (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); - longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 + s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) @@ -727,14 +725,13 @@ let save_library_to ?todo ~output_native_objects dir f otab = iraise reraise let save_library_raw f sum lib univs proofs = - let f' = f^"o" in - let ch = raw_extern_library f' in - System.marshal_out_segment f' ch (sum : seg_sum); - System.marshal_out_segment f' ch (lib : seg_lib); - System.marshal_out_segment f' ch (Some univs : seg_univ option); - System.marshal_out_segment f' ch (None : seg_discharge option); - System.marshal_out_segment f' ch (None : 'tasks option); - System.marshal_out_segment f' ch (proofs : seg_proofs); + let ch = raw_extern_library f in + System.marshal_out_segment f ch (sum : seg_sum); + System.marshal_out_segment f ch (lib : seg_lib); + System.marshal_out_segment f ch (Some univs : seg_univ option); + System.marshal_out_segment f ch (None : seg_discharge option); + System.marshal_out_segment f ch (None : 'tasks option); + System.marshal_out_segment f ch (proofs : seg_proofs); close_out ch module StringOrd = struct type t = string let compare = String.compare end diff --git a/library/library.mli b/library/library.mli index a976be0184..390299bf56 100644 --- a/library/library.mli +++ b/library/library.mli @@ -46,7 +46,7 @@ val save_library_to : DirPath.t -> string -> Opaqueproof.opaquetab -> unit val load_library_todo : - string -> string * seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs + string -> seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit (** {6 Interrogate the status of libraries } *) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 69c1d9bd23..0f78e0acf6 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -10,11 +10,11 @@ open Util -let check_vio (ts,f) = +let check_vio (ts,f_in) = Dumpglob.noglob (); - let long_f_dot_v, _, _, _, _, tasks, _ = Library.load_library_todo f in - Stm.set_compilation_hints long_f_dot_v; - List.fold_left (fun acc ids -> Stm.check_task f tasks ids && acc) true ts + let _, _, _, _, tasks, _ = Library.load_library_todo f_in in + Stm.set_compilation_hints f_in; + List.fold_left (fun acc ids -> Stm.check_task f_in tasks ids && acc) true ts module Worker = Spawn.Sync () @@ -28,15 +28,12 @@ module Pool = Map.Make(IntOT) let schedule_vio_checking j fs = if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in - List.iter (fun f -> - let f = - if Filename.check_suffix f ".vio" then Filename.chop_extension f - else f in - let long_f_dot_v, _,_,_,_, tasks, _ = Library.load_library_todo f in - Stm.set_compilation_hints long_f_dot_v; + List.iter (fun long_f_dot_vio -> + let _,_,_,_, tasks, _ = Library.load_library_todo long_f_dot_vio in + Stm.set_compilation_hints long_f_dot_vio; let infos = Stm.info_tasks tasks in let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in - if infos <> [] then jobs := (f, eta, infos) :: !jobs) + if infos <> [] then jobs := (long_f_dot_vio, eta, infos) :: !jobs) fs; let cmp_job (_,t1,_) (_,t2,_) = compare t2 t1 in jobs := List.sort cmp_job !jobs; @@ -103,16 +100,12 @@ let schedule_vio_checking j fs = let schedule_vio_compilation j fs = if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in - List.iter (fun f -> - let f = - if Filename.check_suffix f ".vio" then Filename.chop_extension f - else f in - let long_f_dot_v = Loadpath.locate_file (f^".v") in - let aux = Aux_file.load_aux_file_for long_f_dot_v in + List.iter (fun long_f_dot_vio -> + let aux = Aux_file.load_aux_file_for long_f_dot_vio in let eta = try float_of_string (Aux_file.get aux "vo_compile_time") with Not_found -> 0.0 in - jobs := (f, eta) :: !jobs) + jobs := (long_f_dot_vio, eta) :: !jobs) fs; let cmp_job (_,t1) (_,t2) = compare t2 t1 in jobs := List.sort cmp_job !jobs; @@ -146,7 +139,7 @@ let schedule_vio_compilation j fs = (* set the access and last modification time of all files to the same t * not to confuse make into thinking that some of them are outdated *) let t = Unix.gettimeofday () in - List.iter (fun (f,_) -> Unix.utimes (f^".vo") t t) all_jobs; + List.iter (fun (f,_) -> Unix.utimes (Filename.chop_extension f^".vo") t t) all_jobs; end; exit !rc diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 8934385091..2f63410761 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -73,14 +73,18 @@ let ensure_bname src tgt = let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt -let ensure_v v = ensure ".v" v v -let ensure_vo v vo = ensure ".vo" v vo -let ensure_vio v vio = ensure ".vio" v vio - let ensure_exists f = if not (Sys.file_exists f) then fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) +let ensure_exists_with_prefix f_in f_out src_suffix tgt_suffix = + let long_f_dot_src = ensure src_suffix f_in f_in in + ensure_exists long_f_dot_src; + let long_f_dot_tgt = match f_out with + | None -> chop_extension long_f_dot_src ^ tgt_suffix + | Some f -> ensure tgt_suffix long_f_dot_src f in + long_f_dot_src, long_f_dot_tgt + (* Compile a vernac file *) let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in @@ -102,12 +106,9 @@ let compile opts copts ~echo ~f_in ~f_out = match copts.compilation_mode with | BuildVo -> Flags.record_aux_file := true; - let long_f_dot_v = ensure_v f_in in - ensure_exists long_f_dot_v; - let long_f_dot_vo = - match f_out with - | None -> long_f_dot_v ^ "o" - | Some f -> ensure_vo long_f_dot_v f in + + let long_f_dot_v, long_f_dot_vo = + ensure_exists_with_prefix f_in f_out ".v" ".vo" in let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc @@ -138,13 +139,8 @@ let compile opts copts ~echo ~f_in ~f_out = Flags.record_aux_file := false; Dumpglob.noglob (); - let long_f_dot_v = ensure_v f_in in - ensure_exists long_f_dot_v; - - let long_f_dot_vio = - match f_out with - | None -> long_f_dot_v ^ "io" - | Some f -> ensure_vio long_f_dot_v f in + let long_f_dot_v, long_f_dot_vio = + ensure_exists_with_prefix f_in f_out ".v" ".vio" in (* We need to disable error resiliency, otherwise some errors will be ignored in batch mode. c.f. #6707 @@ -175,13 +171,15 @@ let compile opts copts ~echo ~f_in ~f_out = Stm.reset_task_queue () | Vio2Vo -> - let open Filename in + Flags.record_aux_file := false; Dumpglob.noglob (); - let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in - let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in - let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in - Library.save_library_raw lfdv sum lib univs proofs + let long_f_dot_vio, long_f_dot_vo = + ensure_exists_with_prefix f_in f_out ".vio" ".vo" in + let sum, lib, univs, disch, tasks, proofs = + Library.load_library_todo long_f_dot_vio in + let univs, proofs = Stm.finish_tasks long_f_dot_vo univs disch proofs tasks in + Library.save_library_raw long_f_dot_vo sum lib univs proofs let compile opts copts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); @@ -205,16 +203,22 @@ let compile_files opts copts = (******************************************************************************) let check_vio_tasks copts = let rc = - List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) + List.fold_left (fun acc (n,f) -> + let f_in = ensure ".vio" f f in + ensure_exists f_in; + Vio_checking.check_vio (n,f_in) && acc) true (List.rev copts.vio_tasks) in if not rc then fatal_error Pp.(str "VIO Task Check failed") (* vio files *) let schedule_vio copts = + let l = + List.map (fun f -> let f_in = ensure ".vio" f f in ensure_exists f_in; f_in) + copts.vio_files in if copts.vio_checking then - Vio_checking.schedule_vio_checking copts.vio_files_j copts.vio_files + Vio_checking.schedule_vio_checking copts.vio_files_j l else - Vio_checking.schedule_vio_compilation copts.vio_files_j copts.vio_files + Vio_checking.schedule_vio_compilation copts.vio_files_j l let do_vio opts copts = (* We must initialize the loadpath here as the vio scheduling -- cgit v1.2.3 From 879cacd0a7066a77f10f48f7e7c27e4380f43c9d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 10 May 2019 09:38:49 +0200 Subject: Usage: fixing indentation for set/unset options. --- toplevel/usage.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index da2094653b..3d15cb0274 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -74,9 +74,9 @@ let print_usage_common co command = \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ -\n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ -\n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ -\n -unset \"Foo Bar\" disable Foo Bar (as Unset Foo Bar. in a file)\ +\n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ +\n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ +\n -unset \"Foo Bar\" disable Foo Bar (as Unset Foo Bar. in a file)\ \n -time display the time taken by each command\ \n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ -- cgit v1.2.3 From 9a49153b2104e8d7ca0d7789b47299295272746c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 11 May 2019 01:45:42 +0200 Subject: Removing no more existing option -emacs-U. --- stm/asyncTaskQueue.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 2493b1fac4..8b455821af 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -125,7 +125,7 @@ module Make(T : Task) () = struct "-async-proofs-worker-priority"; CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] (* Options to discard: 0 arguments *) - | ("-emacs"|"-emacs-U"|"-batch")::tl -> + | ("-emacs"|"-batch")::tl -> set_slave_opt tl (* Options to discard: 1 argument *) | ( "-async-proofs" | "-vio2vo" | "-o" -- cgit v1.2.3 From df98a88a1e35213e994ec583f6ad4e0d3ccac868 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 11 May 2019 16:17:15 +0200 Subject: CoqIDE: Treat unknown arguments starting with dash as unknown options rather than files. --- ide/idetop.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ide/idetop.ml b/ide/idetop.ml index ce00ba6d8c..970d7cf650 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -537,7 +537,11 @@ let rec parse = function Xmlprotocol.document Xml_printer.to_string_fmt; exit 0 | "--xml_format=Ppcmds" :: rest -> msg_format := (fun () -> Xmlprotocol.Ppcmds); parse rest - | x :: rest -> x :: parse rest + | x :: rest -> + if String.length x > 0 && x.[0] = '-' then + (prerr_endline ("Unknown option " ^ x); exit 1) + else + x :: parse rest | [] -> [] let () = Usage.add_to_usage "coqidetop" -- cgit v1.2.3 From 00d05ff204108622d1f944d748103a98c0d6d088 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 14 May 2019 11:20:34 +0200 Subject: Adding missing newline in coqc usage. --- toplevel/usage.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 3d15cb0274..04b23f587f 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -107,7 +107,7 @@ coqtop specific options:\ exit 1 let print_usage_coqc () = - print_usage_common stderr "Usage: coqc file..."; + print_usage_common stderr "Usage: coqc file...\n\n"; output_string stderr "\n\ coqc specific options:\ \n\ -- cgit v1.2.3 From 44a5643416fbb0e224cf0031f176bd859ef2faf5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 11 May 2019 22:16:16 +0200 Subject: Usage: Fixing wrong description of load_vernac_object and similar. We also preventively add quoted around Load to suggest that the file can have "/" in it. We also fix a too far indentation. --- toplevel/usage.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 04b23f587f..29948d50b2 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -42,12 +42,12 @@ let print_usage_common co command = \n\ \n -load-ml-object f load ML object file f\ \n -load-ml-source f load ML file f\ -\n -load-vernac-source f load Coq file f.v (Load f.)\ +\n -load-vernac-source f load Coq file f.v (Load \"f\".)\ \n -l f (idem)\ -\n -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.)\ -\n -lv f (idem)\ -\n -load-vernac-object f load Coq object file f.vo\ \n -require path load Coq library path and import it (Require Import path.)\ +\n -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ +\n -lv f (idem)\ +\n -load-vernac-object path load Coq library path (Require path)\ \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ -- cgit v1.2.3 From d4bb58a66ebaa771216524c070a090e60d4fb7a9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 7 May 2019 09:11:30 +0200 Subject: Coqc: Ensure exclusiveness of options -quick and -vio2vo. --- toplevel/coqcargs.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index c3f099869c..0ccd68613f 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -82,6 +82,14 @@ let set_vio_checking_j opts opt j = prerr_endline "setting the J variable like in 'make vio2vo J=3'"; exit 1 +let set_compilation_mode opts mode = + match opts.compilation_mode with + | BuildVo -> { opts with compilation_mode = mode } + | mode' when mode <> mode' -> + prerr_endline "Options -quick and -vio2vo are exclusive"; + exit 1 + | _ -> opts + let get_task_list s = List.map (fun s -> try int_of_string s @@ -145,7 +153,7 @@ let parse arglist : t = | "-o" -> { oval with compilation_output_name = Some (next ()) } | "-quick" -> - { oval with compilation_mode = BuildVio } + set_compilation_mode oval BuildVio | "-check-vio-tasks" -> let tno = get_task_list (next ()) in let tfile = next () in @@ -164,7 +172,7 @@ let parse arglist : t = | "-vio2vo" -> let oval = add_compile ~echo:false oval (next ()) in - { oval with compilation_mode = Vio2Vo } + set_compilation_mode oval Vio2Vo | "-outputstate" -> set_outputstate oval (next ()) -- cgit v1.2.3 From eed3831a2cc32042fdee95767da00d7e52840371 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 7 May 2019 09:12:58 +0200 Subject: Coqc: Ensure that at most one file is given when -o is also given. --- toplevel/coqcargs.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 0ccd68613f..2279ce5505 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -56,6 +56,13 @@ let error_missing_arg s = prerr_endline "See -help for the syntax of supported options"; exit 1 +let check_compilation_output_name_consistency args = + match args.compilation_output_name, args.compile_list with + | Some _, _::_::_ -> + prerr_endline ("Error: option -o is not valid when more than one"); + prerr_endline ("file have to be compiled") + | _ -> () + let add_compile ?echo copts s = (* make the file name explicit; needed not to break up Coq loadpath stuff. *) let echo = Option.default copts.echo echo in @@ -185,5 +192,7 @@ let parse arglist : t = in try let opts, extra = parse default in - List.fold_left add_compile opts extra + let args = List.fold_left add_compile opts extra in + check_compilation_output_name_consistency args; + args with any -> fatal_error any -- cgit v1.2.3 From 367df34f8a7ee619c0eb1c40cfa9d2bb432027ec Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 14 May 2019 14:10:09 +0200 Subject: Add aucontext debug printer --- dev/include_printers | 1 + dev/top_printers.dbg | 1 + dev/top_printers.ml | 9 +++++++++ dev/top_printers.mli | 1 + 4 files changed, 12 insertions(+) diff --git a/dev/include_printers b/dev/include_printers index 90088e40bf..d077075eeb 100644 --- a/dev/include_printers +++ b/dev/include_printers @@ -11,6 +11,7 @@ #install_printer (* universes *) ppuniverses;; #install_printer (* univ level *) ppuni_level;; #install_printer (* univ context *) ppuniverse_context;; +#install_printer (* univ context *) ppaucontext;; #install_printer (* univ context future *) ppuniverse_context_future;; #install_printer (* univ context set *) ppuniverse_context_set;; #install_printer (* univ set *) ppuniverse_set;; diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index a6ecec7e33..82f2e79549 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -62,6 +62,7 @@ install_printer Top_printers.ppuni_level install_printer Top_printers.ppuniverse_set install_printer Top_printers.ppuniverse_instance install_printer Top_printers.ppuniverse_context +install_printer Top_printers.ppaucontext install_printer Top_printers.ppuniverse_context_set install_printer Top_printers.ppuniverse_subst install_printer Top_printers.ppuniverse_opt_subst diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 816316487c..90bb87d2ac 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -236,6 +236,15 @@ let ppnamedcontextval e = let sigma = Evd.from_env env in pp (pr_named_context env sigma (named_context_of_val e)) +let ppaucontext auctx = + let nas = AUContext.names auctx in + let prlev l = match Level.var_index l with + | Some n -> Name.print nas.(n) + | None -> prlev l + in + pp (pr_universe_context prlev (AUContext.repr auctx)) + + let ppenv e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]") diff --git a/dev/top_printers.mli b/dev/top_printers.mli index cb32d2294c..2aa1808322 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -137,6 +137,7 @@ val prlev : Univ.Level.t -> Pp.t (* with global names (does this work?) *) val ppuniverse_set : Univ.LSet.t -> unit val ppuniverse_instance : Univ.Instance.t -> unit val ppuniverse_context : Univ.UContext.t -> unit +val ppaucontext : Univ.AUContext.t -> unit val ppuniverse_context_set : Univ.ContextSet.t -> unit val ppuniverse_subst : Univ.universe_subst -> unit val ppuniverse_opt_subst : UnivSubst.universe_opt_subst -> unit -- cgit v1.2.3 From 682ec8fe694e37757d2cd6c98fb5e2e609a6f08f Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Thu, 9 May 2019 14:07:16 +0200 Subject: Allow run_tactic to return a value, remove hack from ltac2 --- plugins/derive/derive.ml | 5 +++-- proofs/pfedit.ml | 4 ++-- proofs/proof.ml | 8 ++++---- proofs/proof.mli | 2 +- proofs/proof_global.ml | 2 +- stm/stm.ml | 7 ++++--- tactics/leminv.ml | 5 +---- user-contrib/Ltac2/tac2entries.ml | 7 +------ vernac/lemmas.ml | 6 +++--- 9 files changed, 20 insertions(+), 26 deletions(-) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 4425e41652..4769c2dc53 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -102,6 +102,7 @@ let start_deriving f suchthat lemma = let terminator = Proof_global.make_terminator terminator in let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in - fst @@ Proof_global.with_current_proof begin fun _ p -> - Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p + Proof_global.simple_with_current_proof begin fun _ p -> + let p,_,() = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p in + p end pstate diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 4f36354f79..52e15f466f 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -98,7 +98,7 @@ let solve ?with_end_tac gi info_lvl tac pr = else tac in let env = Global.env () in - let (p,(status,info)) = Proof.run_tactic env tac pr in + let (p,(status,info),()) = Proof.run_tactic env tac pr in let env = Global.env () in let sigma = Evd.from_env env in let () = @@ -161,7 +161,7 @@ let refine_by_tactic ~name ~poly env sigma ty tac = let prev_future_goals = save_future_goals sigma in (* Start a proof *) let prf = Proof.start ~name ~poly sigma [env, ty] in - let (prf, _) = + let (prf, _, ()) = try Proof.run_tactic env tac prf with Logic_monad.TacticFailure e as src -> (* Catch the inner error of the monad tactic *) diff --git a/proofs/proof.ml b/proofs/proof.ml index 778d98b2cd..ce7354aa62 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -372,7 +372,7 @@ let run_tactic env tac pr = let sp = pr.proofview in let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in let tac = - tac >>= fun () -> + tac >>= fun result -> Proofview.tclEVARMAP >>= fun sigma -> (* Already solved goals are not to be counted as shelved. Nor are they to be marked as unresolvable. *) @@ -383,10 +383,10 @@ let run_tactic env tac pr = CErrors.anomaly Pp.(str "Evars generated outside of proof engine (e.g. V82, clear, ...) are not supposed to be explicitly given up."); let sigma = Proofview.Unsafe.mark_as_goals sigma retrieved in Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT retrieved + Proofview.tclUNIT (result,retrieved) in let { name; poly } = pr in - let (retrieved,proofview,(status,to_shelve,give_up),info_trace) = + let ((result,retrieved),proofview,(status,to_shelve,give_up),info_trace) = Proofview.apply ~name ~poly env tac sp in let sigma = Proofview.return proofview in @@ -400,7 +400,7 @@ let run_tactic env tac pr = in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in - { pr with proofview ; shelf ; given_up },(status,info_trace) + { pr with proofview ; shelf ; given_up },(status,info_trace),result (*** Commands ***) diff --git a/proofs/proof.mli b/proofs/proof.mli index 1f4748141a..248b9d921e 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -172,7 +172,7 @@ val no_focused_goal : t -> bool used. In which case it is [false]. *) val run_tactic : Environ.env - -> unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) + -> 'a Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) * 'a val maximal_unfocus : 'a focus_kind -> t -> t diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 08b98d702a..40ae4acc88 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -345,6 +345,6 @@ let update_global_env (pf : t) = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in + let (p,(status,info),()) = Proof.run_tactic (Global.env ()) tac p in (p, ()))) pf in res diff --git a/stm/stm.ml b/stm/stm.ml index 3eb6d03529..21618bc044 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2085,8 +2085,8 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> - ignore(TaskQueue.with_n_workers nworkers (fun queue -> - PG_compat.with_current_proof (fun _ p -> + TaskQueue.with_n_workers nworkers (fun queue -> + PG_compat.simple_with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2131,7 +2131,8 @@ end = struct (* {{{ *) if solve then Tacticals.New.tclSOLVE [] else tclUNIT () end) in - Proof.run_tactic (Global.env()) assign_tac p)))) ()) + let p,_,() = Proof.run_tactic (Global.env()) assign_tac p in + p))) ()) end (* }}} *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 4aa4d13e1e..6efa1ece9c 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -204,10 +204,7 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = (str"Computed inversion goal was not closed in initial signature."); *) let pf = Proof.start ~name ~poly (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in - let pf = - fst (Proof.run_tactic env ( - tclTHEN intro (onLastHypId inv_op)) pf) - in + let pf, _, () = Proof.run_tactic env (tclTHEN intro (onLastHypId inv_op)) pf in let pfterm = List.hd (Proof.partial_proof pf) in let global_named_context = Global.named_context_val () in let ownSign = ref begin diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 9fd01426de..254c2e5086 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -740,7 +740,6 @@ let register_redefinition ?(local = false) qid e = Lib.add_anonymous_leaf (inTac2Redefinition def) let perform_eval ~pstate e = - let open Proofview.Notations in let env = Global.env () in let (e, ty) = Tac2intern.intern ~strict:false e in let v = Tac2interp.interp Tac2interp.empty_environment e in @@ -761,12 +760,8 @@ let perform_eval ~pstate e = | Goal_select.SelectAll -> v | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) in - (* HACK: the API doesn't allow to return a value *) - let ans = ref None in - let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in - let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in + let (proof, _, ans) = Proof.run_tactic (Global.env ()) v proof in let sigma = Proof.in_proof proof (fun sigma -> sigma) in - let ans = match !ans with None -> assert false | Some r -> r in let name = int_name () in Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) ++ spc () ++ str "=" ++ spc () ++ diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 1c7cc5e636..2dae0ad125 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -395,10 +395,10 @@ let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms s maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in let pstate = start_proof ~ontop id ~pl:decl kind sigma t ~hook ~compute_guard:guard in - let pstate, _ = Proof_global.with_current_proof (fun _ p -> + let pstate = Proof_global.simple_with_current_proof (fun _ p -> match init_tac with - | None -> p,(true,[]) - | Some tac -> Proof.run_tactic Global.(env ()) tac p) pstate in + | None -> p + | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p) pstate in pstate let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = -- cgit v1.2.3 From 06b60655b98580baab98f35f6c89716e2381934c Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 14 May 2019 14:17:57 +0200 Subject: Overlay for value-returning run_tactic --- dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh diff --git a/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh b/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh new file mode 100644 index 0000000000..4032b1c6b5 --- /dev/null +++ b/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10125" ] || [ "$CI_BRANCH" = "run_tactic_gen" ]; then + + paramcoq_CI_REF=run_tactic_gen + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + +fi -- cgit v1.2.3 From 37a560eb48c982bc933837e10f1ae41a4322ca77 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 11 May 2019 14:20:23 +0200 Subject: Code factorization in elim tactics. This is just moving code around, so it should not change the semantics. --- tactics/tactics.ml | 103 ++++++++++++++++++++++------------------------------- 1 file changed, 42 insertions(+), 61 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 806c955591..44ca9958fa 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1360,22 +1360,25 @@ let rec contract_letin_in_lam_header sigma c = | LetIn (x,b,t,c) -> contract_letin_in_lam_header sigma (subst1 b c) | _ -> c -let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) - rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header sigma elim in - let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = - (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with - | Meta mv -> mv - | _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.")) +let elimination_in_clause_scheme env sigma with_evars ~flags + id hypmv elimclause = + let hyp = mkVar id in + let hyp_typ = Retyping.get_type_of env sigma hyp in + let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in + let elimclause'' = + (* The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags hypmv elimclause hypclause + with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> + (* Set the hypothesis name in the message *) + raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) in - let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags - end + let new_hyp_typ = clenv_type elimclause'' in + if EConstr.eq_constr sigma hyp_typ new_hyp_typ then + user_err ~hdr:"general_rewrite_in" + (str "Nothing to rewrite in " ++ Id.print id ++ str"."); + clenv_refine_in with_evars id id sigma elimclause'' + (fun id -> Proofview.tclUNIT ()) (* * Elimination tactic with bindings and using an arbitrary @@ -1391,7 +1394,7 @@ type eliminator = { elimbody : EConstr.constr with_bindings } -let general_elim_clause_gen elimtac indclause elim = +let general_elim_clause with_evars flags where indclause elim = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1399,7 +1402,27 @@ let general_elim_clause_gen elimtac indclause elim = let elimt = Retyping.get_type_of env sigma elimc in let i = match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in - elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause + let elimc = contract_letin_in_lam_header sigma elimc in + let elimclause = make_clenv_binding env sigma (elimc, elimt) lbindelimc in + let indmv = + (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with + | Meta mv -> mv + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.")) + in + match where with + | None -> + let elimclause = clenv_fchain ~flags indmv elimclause indclause in + Clenvtac.res_pf elimclause ~with_evars ~with_classes:true ~flags + | Some id -> + let hypmv = + match List.remove Int.equal indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.") + in + let elimclause = clenv_fchain ~flags indmv elimclause indclause in + elimination_in_clause_scheme env sigma with_evars ~flags id hypmv elimclause end let general_elim with_evars clear_flag (c, lbindc) elim = @@ -1408,12 +1431,12 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in - let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in + let flags = elim_flags () in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN - (general_elim_clause_gen elimtac indclause elim) + (general_elim_clause with_evars flags None indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) end @@ -1515,48 +1538,6 @@ let simplest_elim c = default_elim false None (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) -let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - (* The evarmap of elimclause is assumed to be an extension of hypclause, so - we do not need to merge the universes coming from hypclause. *) - try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause - with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> - (* Set the hypothesis name in the message *) - raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) - -let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) - id rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header sigma elim in - let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in - let hypmv = - match List.remove Int.equal indmv (clenv_independent elimclause) with - | [a] -> a - | _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.") - in - let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - let hyp = mkVar id in - let hyp_typ = Retyping.get_type_of env sigma hyp in - let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in - let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in - let new_hyp_typ = clenv_type elimclause'' in - if EConstr.eq_constr sigma hyp_typ new_hyp_typ then - user_err ~hdr:"general_rewrite_in" - (str "Nothing to rewrite in " ++ Id.print id ++ str"."); - clenv_refine_in with_evars id id sigma elimclause'' - (fun id -> Proofview.tclUNIT ()) - end - -let general_elim_clause with_evars flags id c e = - let elim = match id with - | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags - | Some id -> elimination_in_clause_scheme with_evars ~flags id - in - general_elim_clause_gen elim c e - (* Apply a tactic below the products of the conclusion of a lemma *) type conjunction_status = -- cgit v1.2.3 From cc1d9256b721b859d7a0dbe63a991f3e40aa67d3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 11 May 2019 15:35:46 +0200 Subject: Remove the elimrename field from Tactics.eliminator. This is actually dead code, we never observe it. --- tactics/equality.ml | 2 +- tactics/tactics.ml | 20 +++++++------------- tactics/tactics.mli | 1 - 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index f049f8c568..45a4799ea1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -417,7 +417,7 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d find_elim hdcncl lft2rgt dep cls (Some t) >>= fun elim -> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) - {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} + {elimindex = None; elimbody = (elim,NoBindings) } end let adjust_rewriting_direction args lft2rgt = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 44ca9958fa..7dd8a7a7c1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1390,7 +1390,6 @@ let elimination_in_clause_scheme env sigma with_evars ~flags type eliminator = { elimindex : int option; (* None = find it automatically *) - elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : EConstr.constr with_bindings } @@ -1459,8 +1458,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let elim = EConstr.of_constr elim in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) - {elimindex = None; elimbody = (elim,NoBindings); - elimrename = Some (false, constructors_nrealdecls env (fst mind))}) + {elimindex = None; elimbody = (elim,NoBindings); }) end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1491,8 +1489,7 @@ let find_eliminator c gl = let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in - evd, {elimindex = None; elimbody = (c,NoBindings); - elimrename = Some (true, constructors_nrealdecls (Global.env()) ind)} + evd, { elimindex = None; elimbody = (c,NoBindings) } let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE @@ -1512,7 +1509,7 @@ let default_elim with_evars clear_flag (c,_ as cx) = let elim_in_context with_evars clear_flag c = function | Some elim -> general_elim with_evars clear_flag c - {elimindex = Some (-1); elimbody = elim; elimrename = None} + { elimindex = Some (-1); elimbody = elim } | None -> default_elim with_evars clear_flag c let elim with_evars clear_flag (c,lbindc as cx) elim = @@ -4164,7 +4161,7 @@ let find_induction_type isrec elim hyp0 gl = let scheme = compute_elim_sig sigma ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in - let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in + let elim = ({ elimindex = Some(-1); elimbody = elimc },elimt) in scheme, ElimUsing (elim,indsign) in match scheme.indref with @@ -4191,10 +4188,7 @@ let get_eliminator elim dep s gl = | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) - (List.rev s.branches) - in - evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l + evd, isrec, ({ elimindex = None; elimbody = elimc }, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are @@ -4238,7 +4232,7 @@ let recolle_clenv i params args elimclause gl = let induction_tac with_evars params indvars elim = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in + let ({ elimindex=i;elimbody=(elimc,lbindelimc) },elimt) = elim in let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header sigma elimc in @@ -4343,7 +4337,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* FIXME: Tester ca avec un principe dependant et non-dependant *) induction_tac with_evars params realindvars elim; ] in - let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in + let elim = ElimUsing (({ elimindex = Some (-1); elimbody = Option.get scheme.elimc }, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9eb8196280..32c64bacf6 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -282,7 +282,6 @@ val compute_elim_sig : evar_map -> ?elimc:constr with_bindings -> types -> elim_ (** elim principle with the index of its inductive arg *) type eliminator = { elimindex : int option; (** None = find it automatically *) - elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : constr with_bindings } -- cgit v1.2.3 From 695990d2929e4026d13ec2acd95b3647c7bcc6e7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 11 May 2019 17:38:50 +0200 Subject: Remove the sidecond_first flag of apply-related tactics. This was dead code. --- tactics/tactics.ml | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 7dd8a7a7c1..2bdfc85d6d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1302,14 +1302,11 @@ let do_replace id = function [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) -let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) - targetid id sigma0 clenv tac = +let clenv_refine_in with_evars targetid id sigma0 clenv tac = let clenv = Clenvtac.clenv_pose_dependent_evars ~with_evars clenv in let clenv = - if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } - else clenv in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; @@ -1321,11 +1318,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) - (if sidecond_first then - Tacticals.New.tclTHENFIRST - (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac - else - Tacticals.New.tclTHENLAST + (Tacticals.New.tclTHENLAST (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac) (********************************************) @@ -1806,7 +1799,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = in aux (make_clenv_binding env sigma (d,thm) lbind) -let apply_in_once ?(respect_opaque = false) sidecond_first with_delta +let apply_in_once ?(respect_opaque = false) with_delta with_destruct with_evars naming id (clear_flag,{ CAst.loc; v= d,lbind}) tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> @@ -1827,7 +1820,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in try let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in - clenv_refine_in ~sidecond_first with_evars targetid id sigma clause + clenv_refine_in with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ apply_clear_request clear_flag false c; @@ -1844,14 +1837,14 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta aux [] with_destruct d end -let apply_in_delayed_once ?(respect_opaque = false) sidecond_first with_delta +let apply_in_delayed_once ?(respect_opaque = false) with_delta with_destruct with_evars naming id (clear_flag,{CAst.loc;v=f}) tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars - (apply_in_once ~respect_opaque sidecond_first with_delta with_destruct with_evars + (apply_in_once ~respect_opaque with_delta with_destruct with_evars naming id (clear_flag,CAst.(make ?loc c)) tac) sigma end @@ -2471,7 +2464,7 @@ and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = clear [id] in let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) in - apply_in_delayed_once false true true with_evars naming id (None,CAst.make ?loc:loc' f) + apply_in_delayed_once true true with_evars naming id (None,CAst.make ?loc:loc' f) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros ?loc with_evars dft destopt = function @@ -2539,10 +2532,10 @@ let assert_as first hd ipat t = (* apply in as *) -let general_apply_in ?(respect_opaque=false) sidecond_first with_delta +let general_apply_in ?(respect_opaque=false) with_delta with_destruct with_evars id lemmas ipat = let tac (naming,lemma) tac id = - apply_in_delayed_once ~respect_opaque sidecond_first with_delta + apply_in_delayed_once ~respect_opaque with_delta with_destruct with_evars naming id lemma tac in Proofview.Goal.enter begin fun gl -> let destopt = @@ -2571,10 +2564,10 @@ let general_apply_in ?(respect_opaque=false) sidecond_first with_delta let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in - general_apply_in false simple simple with_evars id lemmas ipat + general_apply_in simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = - general_apply_in ~respect_opaque:true false simple simple with_evars id lemmas ipat + general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) -- cgit v1.2.3 From 106a7c4a86e4c164a73cbc5a4c14f3c4ff527f30 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 12 May 2019 23:43:01 +0200 Subject: Reduce the attack surface of Opaqueproof. --- kernel/modops.ml | 6 +----- kernel/opaqueproof.ml | 29 +++++++++-------------------- kernel/opaqueproof.mli | 4 +--- 3 files changed, 11 insertions(+), 28 deletions(-) diff --git a/kernel/modops.ml b/kernel/modops.ml index 4f992d3972..4fdd7ab334 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -608,11 +608,7 @@ let clean_bounded_mod_expr sign = (** {6 Stm machinery } *) let join_constant_body except otab cb = match cb.const_body with - | OpaqueDef o -> - (match Opaqueproof.uuid_opaque otab o with - | Some uuid when not(Future.UUIDSet.mem uuid except) -> - Opaqueproof.join_opaque otab o - | _ -> ()) + | OpaqueDef o -> Opaqueproof.join_opaque ~except otab o | _ -> () let join_structure except otab s = diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 303cb06c55..57059300b8 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -87,19 +87,18 @@ let discharge_direct_opaque ~cook_constr ci = function | Direct (d,cu) -> Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) -let join_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> ignore(Future.join cu) +let join except cu = match except with +| None -> ignore (Future.join cu) +| Some except -> + if Future.UUIDSet.mem (Future.uuid cu) except then () + else ignore (Future.join cu) + +let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function + | Direct (_,cu) -> join except cu | Indirect (_,dp,i) -> if DirPath.equal dp odp then let fp = snd (Int.Map.find i prfs) in - ignore(Future.join fp) - -let uuid_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> Some (Future.uuid cu) - | Indirect (_,dp,i) -> - if DirPath.equal dp odp - then Some (Future.uuid (snd (Int.Map.find i prfs))) - else None + join except fp let force_proof { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> @@ -128,16 +127,6 @@ let get_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function then Some(Future.chain (snd (Int.Map.find i prfs)) snd) else !get_univ dp i -let get_proof { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> Future.chain cu fst - | Indirect (l,dp,i) -> - let pt = - if DirPath.equal dp odp - then Future.chain (snd (Int.Map.find i prfs)) fst - else !get_opaque dp i in - Future.chain pt (fun c -> - force_constr (List.fold_right subst_substituted l (from_val c))) - module FMap = Future.UUIDMap let a_constr = Future.from_val (mkRel 1) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 5ea6da649b..d47c0bbb3c 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -39,7 +39,6 @@ val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab indirect opaque accessor configured below. *) val force_proof : opaquetab -> opaque -> constr val force_constraints : opaquetab -> opaque -> Univ.ContextSet.t -val get_proof : opaquetab -> opaque -> constr Future.computation val get_constraints : opaquetab -> opaque -> Univ.ContextSet.t Future.computation option @@ -60,8 +59,7 @@ type cooking_info = { val discharge_direct_opaque : cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque -val uuid_opaque : opaquetab -> opaque -> Future.UUID.t option -val join_opaque : opaquetab -> opaque -> unit +val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit val dump : opaquetab -> Constr.t Future.computation array * -- cgit v1.2.3 From e74fce3090323b4d3734f84ee8cf6dc1f5e85953 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 13 May 2019 00:03:36 +0200 Subject: Abstract away the implementation of side-effects in Safe_typing. --- kernel/entries.ml | 14 -------------- kernel/safe_typing.ml | 29 ++++++++++++++++++++++------- kernel/safe_typing.mli | 8 +++----- proofs/refine.ml | 14 +------------- vernac/lemmas.ml | 8 +------- 5 files changed, 27 insertions(+), 46 deletions(-) diff --git a/kernel/entries.ml b/kernel/entries.ml index a3d32267a7..adb3f6bd29 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -108,21 +108,7 @@ type module_entry = | MExpr of module_params_entry * module_struct_entry * module_struct_entry option - -type seff_env = - [ `Nothing - (* The proof term and its universes. - Same as the constant_body's but not in an ephemeron *) - | `Opaque of Constr.t * Univ.ContextSet.t ] - (** Not used by the kernel. *) type side_effect_role = | Subproof | Schema of inductive * string - -type side_eff = { - seff_constant : Constant.t; - seff_body : Declarations.constant_body; - seff_env : seff_env; - seff_role : side_effect_role; -} diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 673f025c75..7b573e3146 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -228,6 +228,12 @@ let check_engagement env expected_impredicative_set = (** {6 Stm machinery } *) +type seff_env = + [ `Nothing + (* The proof term and its universes. + Same as the constant_body's but not in an ephemeron *) + | `Opaque of Constr.t * Univ.ContextSet.t ] + let get_opaque_body env cbo = match cbo.const_body with | Undef _ -> assert false @@ -238,9 +244,16 @@ let get_opaque_body env cbo = (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) +type side_eff = { + seff_constant : Constant.t; + seff_body : Declarations.constant_body; + seff_env : seff_env; + seff_role : Entries.side_effect_role; +} + type side_effect = { from_env : Declarations.structure_body CEphemeron.key; - eff : Entries.side_eff list; + eff : side_eff list; } module SideEffects : @@ -254,7 +267,6 @@ end = struct module SeffOrd = struct -open Entries type t = side_effect let compare e1 e2 = let cmp e1 e2 = Constant.CanOrd.compare e1.seff_constant e2.seff_constant in @@ -282,6 +294,14 @@ let side_effects_of_private_constants l = let ans = List.rev (SideEffects.repr l) in List.map_append (fun { eff; _ } -> eff) ans +let push_private_constants env eff = + let eff = side_effects_of_private_constants eff in + let add_if_undefined env eff = + try ignore(Environ.lookup_constant eff.seff_constant env); env + with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env + in + List.fold_left add_if_undefined env eff + let empty_private_constants = SideEffects.empty let add_private mb eff effs = let from_env = CEphemeron.create mb in @@ -289,7 +309,6 @@ let add_private mb eff effs = let concat_private = SideEffects.concat let make_eff env cst r = - let open Entries in let cbo = Environ.lookup_constant cst env.env in { seff_constant = cst; @@ -309,7 +328,6 @@ let private_con_of_scheme ~kind env cl = add_private env.revstruct eff empty_private_constants let universes_of_private eff = - let open Entries in let fold acc eff = let acc = match eff.seff_env with | `Nothing -> acc @@ -588,7 +606,6 @@ let add_constant_aux ~in_section senv (kn, cb) = let mk_pure_proof c = (c, Univ.ContextSet.empty), SideEffects.empty let inline_side_effects env body side_eff = - let open Entries in let open Constr in (** First step: remove the constants that are still in the environment *) let filter { eff = se; from_env = mb } = @@ -725,7 +742,6 @@ let constant_entry_of_side_effect cb u = const_entry_inline_code = cb.const_inline_code } let turn_direct orig = - let open Entries in let cb = orig.seff_body in if Declareops.is_opaque cb then let p = match orig.seff_env with @@ -738,7 +754,6 @@ let turn_direct orig = else orig let export_eff eff = - let open Entries in (eff.seff_constant, eff.seff_body, eff.seff_role) let export_side_effects mb env c = diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 46c97c1fb8..6fcdef9a10 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -43,11 +43,6 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment type private_constants -val side_effects_of_private_constants : - private_constants -> Entries.side_eff list -(** Return the list of individual side-effects in the order of their - creation. *) - val empty_private_constants : private_constants val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in @@ -62,6 +57,9 @@ val inline_private_constants_in_constr : val inline_private_constants_in_definition_entry : Environ.env -> private_constants Entries.definition_entry -> unit Entries.definition_entry +val push_private_constants : Environ.env -> private_constants -> Environ.env +(** Push the constants in the environment if not already there. *) + val universes_of_private : private_constants -> Univ.ContextSet.t list val is_curmod_library : safe_environment -> bool diff --git a/proofs/refine.ml b/proofs/refine.ml index 06e6b89df1..4a9404aa96 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -44,17 +44,6 @@ let typecheck_evar ev env sigma = let sigma, _ = Typing.sort_of env sigma (Evd.evar_concl info) in sigma -(* Get the side-effect's constant declarations to update the monad's - * environmnent *) -let add_if_undefined env eff = - let open Entries in - try ignore(Environ.lookup_constant eff.seff_constant env); env - with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env - -(* Add the side effects to the monad's environment, if not already done. *) -let add_side_effects env eff = - List.fold_left add_if_undefined env eff - let generic_refine ~typecheck f gl = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -71,8 +60,7 @@ let generic_refine ~typecheck f gl = let evs = Evd.save_future_goals sigma in (* Redo the effects in sigma in the monad's env *) let privates_csts = Evd.eval_side_effects sigma in - let sideff = Safe_typing.side_effects_of_private_constants privates_csts in - let env = add_side_effects env sideff in + let env = Safe_typing.push_private_constants env privates_csts in (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 1c7cc5e636..fe895098c0 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -75,13 +75,7 @@ let adjust_guardness_conditions const = function List.interval 0 (List.length ((lam_assum c)))) lemma_guard (Array.to_list fixdefs) in *) - let fold env eff = - try - let _ = Environ.lookup_constant eff.seff_constant env in - env - with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env - in - let env = List.fold_left fold env (Safe_typing.side_effects_of_private_constants eff) in + let env = Safe_typing.push_private_constants env eff in let indexes = search_guard env possible_indexes fixdecls in -- cgit v1.2.3 From 3cdaffab75414f3f59386a4b76c6b00c94bc8b0e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 13 May 2019 00:26:56 +0200 Subject: Simplify the private constant API. We ungroup the rewrite scheme-defined constants, while only exporting a function to turn the last added constant into a private constant. --- kernel/safe_typing.ml | 102 ++++++++++++++++++++----------------------------- kernel/safe_typing.mli | 4 +- tactics/abstract.ml | 2 +- tactics/ind_tables.ml | 20 +++++----- 4 files changed, 55 insertions(+), 73 deletions(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 7b573e3146..75375812c0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -244,18 +244,14 @@ let get_opaque_body env cbo = (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) -type side_eff = { +type side_effect = { + from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; seff_body : Declarations.constant_body; seff_env : seff_env; seff_role : Entries.side_effect_role; } -type side_effect = { - from_env : Declarations.structure_body CEphemeron.key; - eff : side_eff list; -} - module SideEffects : sig type t @@ -269,8 +265,7 @@ struct module SeffOrd = struct type t = side_effect let compare e1 e2 = - let cmp e1 e2 = Constant.CanOrd.compare e1.seff_constant e2.seff_constant in - List.compare cmp e1.eff e2.eff + Constant.CanOrd.compare e1.seff_constant e2.seff_constant end module SeffSet = Set.Make(SeffOrd) @@ -291,8 +286,7 @@ end type private_constants = SideEffects.t let side_effects_of_private_constants l = - let ans = List.rev (SideEffects.repr l) in - List.map_append (fun { eff; _ } -> eff) ans + List.rev (SideEffects.repr l) let push_private_constants env eff = let eff = side_effects_of_private_constants eff in @@ -303,29 +297,24 @@ let push_private_constants env eff = List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty -let add_private mb eff effs = - let from_env = CEphemeron.create mb in - SideEffects.add { eff; from_env } effs let concat_private = SideEffects.concat -let make_eff env cst r = +let private_constant env role cst = + (** The constant must be the last entry of the safe environment *) + let () = match env.revstruct with + | (lbl, SFBconst _) :: _ -> assert (Label.equal lbl (Constant.label cst)) + | _ -> assert false + in + let from_env = CEphemeron.create env.revstruct in let cbo = Environ.lookup_constant cst env.env in - { + let eff = { + from_env = from_env; seff_constant = cst; seff_body = cbo; seff_env = get_opaque_body env.env cbo; - seff_role = r; - } - -let private_con_of_con env c = - let open Entries in - let eff = [make_eff env c Subproof] in - add_private env.revstruct eff empty_private_constants - -let private_con_of_scheme ~kind env cl = - let open Entries in - let eff = List.map (fun (i, c) -> make_eff env c (Schema (i, kind))) cl in - add_private env.revstruct eff empty_private_constants + seff_role = role; + } in + SideEffects.add eff empty_private_constants let universes_of_private eff = let fold acc eff = @@ -608,19 +597,15 @@ let mk_pure_proof c = (c, Univ.ContextSet.empty), SideEffects.empty let inline_side_effects env body side_eff = let open Constr in (** First step: remove the constants that are still in the environment *) - let filter { eff = se; from_env = mb } = - let map e = (e.seff_constant, e.seff_body, e.seff_env) in - let cbl = List.map map se in - let not_exists (c,_,_) = - try ignore(Environ.lookup_constant c env); false - with Not_found -> true in - let cbl = List.filter not_exists cbl in - (cbl, mb) + let filter e = + let cb = (e.seff_constant, e.seff_body, e.seff_env) in + try ignore (Environ.lookup_constant e.seff_constant env); None + with Not_found -> Some (cb, e.from_env) in (* CAVEAT: we assure that most recent effects come first *) - let side_eff = List.map filter (SideEffects.repr side_eff) in - let sigs = List.rev_map (fun (cbl, mb) -> mb, List.length cbl) side_eff in - let side_eff = List.fold_left (fun accu (cbl, _) -> cbl @ accu) [] side_eff in + let side_eff = List.map_filter filter (SideEffects.repr side_eff) in + let sigs = List.rev_map (fun (_, mb) -> mb) side_eff in + let side_eff = List.fold_left (fun accu (cb, _) -> cb :: accu) [] side_eff in let side_eff = List.rev side_eff in (** Most recent side-effects first in side_eff *) if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs) @@ -692,24 +677,22 @@ let inline_private_constants_in_definition_entry env ce = let inline_private_constants_in_constr env body side_eff = pi1 (inline_side_effects env body side_eff) -let rec is_nth_suffix n l suf = - if Int.equal n 0 then l == suf - else match l with - | [] -> false - | _ :: l -> is_nth_suffix (pred n) l suf +let is_suffix l suf = match l with +| [] -> false +| _ :: l -> l == suf (* Given the list of signatures of side effects, checks if they match. * I.e. if they are ordered descendants of the current revstruct. Returns the number of effects that can be trusted. *) let check_signatures curmb sl = - let is_direct_ancestor accu (mb, how_many) = + let is_direct_ancestor accu mb = match accu with | None -> None | Some (n, curmb) -> try let mb = CEphemeron.get mb in - if is_nth_suffix how_many mb curmb - then Some (n + how_many, mb) + if is_suffix mb curmb + then Some (n + 1, mb) else None with CEphemeron.InvalidKey -> None in let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in @@ -766,10 +749,9 @@ let export_side_effects mb env c = let not_exists e = try ignore(Environ.lookup_constant e.seff_constant env); false with Not_found -> true in - let aux (acc,sl) { eff = se; from_env = mb } = - let cbl = List.filter not_exists se in - if List.is_empty cbl then acc, sl - else cbl :: acc, (mb,List.length cbl) :: sl in + let aux (acc,sl) e = + if not (not_exists e) then acc, sl + else e :: acc, e.from_env :: sl in let seff, signatures = List.fold_left aux ([],[]) (SideEffects.repr eff) in let trusted = check_signatures mb signatures in let push_seff env eff = @@ -787,10 +769,9 @@ let export_side_effects mb env c = let rec translate_seff sl seff acc env = match seff with | [] -> List.rev acc, ce - | cbs :: rest -> + | eff :: rest -> if Int.equal sl 0 then - let env, cbs = - List.fold_left (fun (env,cbs) eff -> + let env, cb = let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in let ce = constant_entry_of_side_effect ocb u in let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in @@ -798,15 +779,14 @@ let export_side_effects mb env c = seff_body = cb; seff_env = `Nothing; } in - (push_seff env eff, export_eff eff :: cbs)) - (env,[]) cbs in - translate_seff 0 rest (cbs @ acc) env + (push_seff env eff, export_eff eff) + in + translate_seff 0 rest (cb :: acc) env else - let cbs_len = List.length cbs in - let cbs = List.map turn_direct cbs in - let env = List.fold_left push_seff env cbs in - let ecbs = List.map export_eff cbs in - translate_seff (sl - cbs_len) rest (ecbs @ acc) env + let cb = turn_direct eff in + let env = push_seff env cb in + let ecb = export_eff cb in + translate_seff (sl - 1) rest (ecb :: acc) env in translate_seff trusted seff [] env diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 6fcdef9a10..d6c7022cf5 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -48,8 +48,8 @@ val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) -val private_con_of_con : safe_environment -> Constant.t -> private_constants -val private_con_of_scheme : kind:string -> safe_environment -> (inductive * Constant.t) list -> private_constants +val private_constant : safe_environment -> Entries.side_effect_role -> Constant.t -> private_constants +(** Constant must be the last definition of the safe_environment. *) val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 7a61deba0c..499152f39a 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -174,7 +174,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in - let eff = private_con_of_con (Global.safe_env ()) cst in + let eff = private_constant (Global.safe_env ()) Entries.Subproof cst in let effs = concat_private eff Entries.(snd (Future.force const.const_entry_body)) in let solve = diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 16829482e5..e95778a90d 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -147,9 +147,10 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in let const = define mode id c (Declareops.inductive_is_polymorphic mib) ctx in + let role = Entries.Schema (ind, kind) in + let neff = Safe_typing.private_constant (Global.safe_env ()) role const in declare_scheme kind [|ind,const|]; - const, Safe_typing.concat_private - (Safe_typing.private_con_of_scheme ~kind (Global.safe_env()) [ind,const]) eff + const, Safe_typing.concat_private neff eff let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with @@ -163,15 +164,16 @@ let define_mutual_scheme_base kind suff f mode names mind = let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in - let consts = Array.map2 (fun id cl -> - define mode id cl (Declareops.inductive_is_polymorphic mib) ctx) ids cl in + let fold i effs id cl = + let cst = define mode id cl (Declareops.inductive_is_polymorphic mib) ctx in + let role = Entries.Schema ((mind, i), kind)in + let neff = Safe_typing.private_constant (Global.safe_env ()) role cst in + (Safe_typing.concat_private neff effs, cst) + in + let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; - consts, - Safe_typing.concat_private - (Safe_typing.private_con_of_scheme - ~kind (Global.safe_env()) (Array.to_list schemes)) - eff + consts, eff let define_mutual_scheme kind mode names mind = match Hashtbl.find scheme_object_table kind with -- cgit v1.2.3 From feb9c50b5812a01e9dc60e2408f4f9f38986ce8c Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Fri, 10 May 2019 22:29:57 -0400 Subject: [refman] Introduce syntax for alternatives in notations Closes GH-8482. --- doc/sphinx/README.rst | 9 +- doc/sphinx/README.template.rst | 7 +- doc/sphinx/_static/coqnotations.sty | 29 +- doc/sphinx/_static/notations.css | 37 +- doc/sphinx/addendum/extraction.rst | 2 +- doc/sphinx/addendum/generalized-rewriting.rst | 2 +- doc/sphinx/addendum/program.rst | 2 +- doc/sphinx/addendum/type-classes.rst | 8 +- doc/sphinx/changes.rst | 4 +- doc/sphinx/language/gallina-extensions.rst | 12 +- doc/sphinx/proof-engine/ltac2.rst | 6 +- doc/sphinx/proof-engine/proof-handling.rst | 8 +- .../proof-engine/ssreflect-proof-language.rst | 20 +- doc/sphinx/proof-engine/tactics.rst | 8 +- doc/sphinx/proof-engine/vernacular-commands.rst | 20 +- doc/tools/coqrst/coqdomain.py | 2 +- doc/tools/coqrst/notations/TacticNotations.g | 29 +- doc/tools/coqrst/notations/TacticNotations.tokens | 24 +- doc/tools/coqrst/notations/TacticNotationsLexer.py | 82 +-- .../coqrst/notations/TacticNotationsLexer.tokens | 24 +- .../coqrst/notations/TacticNotationsParser.py | 624 +++++++++++++++++---- .../coqrst/notations/TacticNotationsVisitor.py | 36 +- doc/tools/coqrst/notations/html.py | 25 +- doc/tools/coqrst/notations/plain.py | 17 +- doc/tools/coqrst/notations/sphinx.py | 46 +- 25 files changed, 823 insertions(+), 260 deletions(-) diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 881f7a310d..b20669c7f1 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -60,8 +60,11 @@ The signatures of most objects can be written using a succinct DSL for Coq notat ``{*, …}``, ``{+, …}`` an optional or mandatory repeatable block, with repetitions separated by commas -``%|``, ``%{``, … - an escaped character (rendered without the leading ``%``) +``{| … | … | … }`` + an alternative, indicating than one of multiple constructs can be used + +``%{``, ``%}``, ``%|`` + an escaped character (rendered without the leading ``%``). In most cases, escaping is not necessary. In particular, the following expressions are all parsed as plain text, and do not need escaping: ``{ xyz }``, ``x |- y``. But the following escapes *are* needed: ``{| a b %| c | d }``, ``all: %{``. (We use ``%`` instead of the usual ``\`` because you'd have to type ``\`` twice in your reStructuredText file.) .. FIXME document the new subscript support @@ -148,7 +151,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica Example:: .. prodn:: term += let: @pattern := @term in @term - .. prodn:: occ_switch ::= { {? + %| - } {* @num } } + .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } ``.. table::`` :black_nib: A Coq table, i.e. a setting that is a set of values. Example:: diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index 78803a927f..2093765608 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -60,8 +60,11 @@ The signatures of most objects can be written using a succinct DSL for Coq notat ``{*, …}``, ``{+, …}`` an optional or mandatory repeatable block, with repetitions separated by commas -``%|``, ``%{``, … - an escaped character (rendered without the leading ``%``) +``{| … | … | … }`` + an alternative, indicating than one of multiple constructs can be used + +``%{``, ``%}``, ``%|`` + an escaped character (rendered without the leading ``%``). In most cases, escaping is not necessary. In particular, the following expressions are all parsed as plain text, and do not need escaping: ``{ xyz }``, ``x |- y``. But the following escapes *are* needed: ``{| a b %| c | d }``, ``all: %{``. (We use ``%`` instead of the usual ``\`` because you'd have to type ``\`` twice in your reStructuredText file.) .. FIXME document the new subscript support diff --git a/doc/sphinx/_static/coqnotations.sty b/doc/sphinx/_static/coqnotations.sty index 75eac1f724..3548b8754c 100644 --- a/doc/sphinx/_static/coqnotations.sty +++ b/doc/sphinx/_static/coqnotations.sty @@ -18,6 +18,9 @@ \newlength{\nscriptsize} \setlength{\nscriptsize}{0.8em} +\newlength{\nboxsep} +\setlength{\nboxsep}{2pt} + \newcommand*{\scriptsmallsquarebox}[1]{% % Force width \makebox[\nscriptsize]{% @@ -31,7 +34,8 @@ \newcommand*{\nsup}[1]{^{\nscript{0.15}{#1}}} \newcommand*{\nsub}[1]{_{\nscript{0.35}{#1}}} \newcommand*{\nnotation}[1]{#1} -\newcommand*{\nrepeat}[1]{\text{\adjustbox{cfbox=nbordercolor 0.5pt 2pt,bgcolor=nbgcolor}{#1\hspace{.5\nscriptsize}}}} +\newcommand*{\nbox}[1]{\adjustbox{cfbox=nbordercolor 0.5pt \nboxsep,bgcolor=nbgcolor}{#1}} +\newcommand*{\nrepeat}[1]{\text{\nbox{#1\hspace{.5\nscriptsize}}}} \newcommand*{\nwrapper}[1]{\ensuremath{\displaystyle#1}} % https://tex.stackexchange.com/questions/310877/ \newcommand*{\nhole}[1]{\textit{\color{nholecolor}#1}} @@ -42,9 +46,32 @@ } % +% https://tex.stackexchange.com/questions/490262/ +\def\naltsep{} +\newsavebox{\nsavedalt} +\newlength{\naltvruleht} +\newlength{\naltvruledp} +\def\naltvrule{\smash{\vrule height\naltvruleht depth\naltvruledp}} +\newcommand{\nalternative}[2]{% + % First measure the contents of the box without the bar + \bgroup% + \def\naltsep{}% + \savebox{\nsavedalt}{#1}% + \setlength{\naltvruleht}{\ht\nsavedalt}% + \setlength{\naltvruledp}{\dp\nsavedalt}% + \addtolength{\naltvruleht}{#2}% + \addtolength{\naltvruledp}{#2}% + % Then redraw it with the bar + \def\naltsep{\naltvrule}% + #1\egroup} + \newcssclass{notation-sup}{\nsup{#1}} \newcssclass{notation-sub}{\nsub{#1}} \newcssclass{notation}{\nnotation{#1}} \newcssclass{repeat}{\nrepeat{#1}} \newcssclass{repeat-wrapper}{\nwrapper{#1}} \newcssclass{hole}{\nhole{#1}} +\newcssclass{alternative}{\nalternative{\nbox{#1}}{0pt}} +\newcssclass{alternative-block}{#1} +\newcssclass{repeated-alternative}{\nalternative{#1}{\nboxsep}} +\newcssclass{alternative-separator}{\quad\naltsep{}\quad} diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index dcb47d1786..8322ab0137 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -45,15 +45,46 @@ width: 2.2em; } -.notation .repeat { +.notation .repeat, .notation .alternative { background: #EAEAEA; border: 1px solid #AAA; display: inline-block; - padding-right: 0.6em; /* Space for the left half of the sub- and sup-scripts */ - padding-left: 0.2em; + padding: 0 0.2em 0 0.3em; margin: 0.25em 0; } +.notation .repeated-alternative { + display: inline-table; +} + +.notation .alternative { + display: inline-table; + padding: 0 0.2em; +} + +.notation .alternative-block { + display: table-cell; + padding: 0 0.5em; +} + +.notation .alternative-separator { + border-left: 1px solid black; /* Display a thin bar */ + display: table-cell; + width: 0; +} + +.alternative-block:first-child { + padding-left: 0; +} + +.alternative-block:last-child { + padding-right: 0; +} + +.notation .repeat { + padding-right: 0.6em; /* Space for the left half of the sub- and sup-scripts */ +} + .notation .repeat-wrapper { display: inline-block; position: relative; diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index e93b01f14d..8a895eb515 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -99,7 +99,7 @@ Extraction Options Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Extraction Language ( OCaml | Haskell | Scheme ) +.. cmd:: Extraction Language {| OCaml | Haskell | Scheme } :name: Extraction Language The ability to fix target language is the first and more important diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index b474c51f17..4d9e8d8b3a 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -809,7 +809,7 @@ Usage ~~~~~ -.. tacn:: rewrite_strat @s [in @ident] +.. tacn:: rewrite_strat @s {? in @ident } :name: rewrite_strat Rewrite using the strategy s in hypothesis ident or the conclusion. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index b410833d25..22ddcae584 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -283,7 +283,7 @@ optional identifier is used when multiple functions have unsolved obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. -.. cmd:: {? Local|Global} Obligation Tactic := @tactic +.. cmd:: {? {| Local | Global } } Obligation Tactic := @tactic :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 77a6ee79cc..9219aa21ca 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -311,7 +311,7 @@ Summary of the commands This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {? @binders} : @class t1 … tn [| priority] := { field1 := b1 ; …; fieldi := bi } +.. cmd:: Instance @ident {? @binders} : @class t1 … tn {? | priority } := { field1 := b1 ; …; fieldi := bi } This command is used to declare a typeclass instance named :token:`ident` of the class :token:`class` with parameters ``t1`` to ``tn`` and @@ -324,7 +324,7 @@ Summary of the commands :tacn:`auto` hints. If the priority is not specified, it defaults to the number of non-dependent binders of the instance. - .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n [| priority] := @term + .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n {? | priority } := @term This syntax is used for declaration of singleton class instances or for directly giving an explicit term of type :n:`forall @binders, @class @@ -356,7 +356,7 @@ Summary of the commands Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a few other commands related to typeclasses. -.. cmd:: Existing Instance {+ @ident} [| priority] +.. cmd:: Existing Instance {+ @ident} {? | priority } This command adds an arbitrary list of constants whose type ends with an applied typeclass to the instance database with an optional @@ -579,7 +579,7 @@ Settings Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? (dfs) | (bfs) } @num +.. cmd:: Typeclasses eauto := {? debug} {? {| (dfs) | (bfs) } } @num :name: Typeclasses eauto This command allows more global customization of the typeclass diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 5704587ae0..e54c1a4eec 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -457,7 +457,7 @@ Other changes in 8.10+beta1 - Command :cmd:`Instance`, when no body is provided, now always opens a proof. This is a breaking change, as instance of :n:`Instance @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will - have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` + have to be changed into :n:`Instance @ident__1 : @ident__2 := %{%}.` or :n:`Instance @ident__1 : @ident__2. Proof. Qed.` (`#9274 `_, by Maxime Dénès). @@ -3881,7 +3881,7 @@ Vernacular commands Equality Schemes", this replaces deprecated option "Equality Scheme"). - Made support for automatic generation of case analysis schemes available to user (governed by option "Set Case Analysis Schemes"). -- New command :n:`{? Global } Generalizable [All|No] [Variable|Variables] {* @ident}` to +- New command :n:`{? Global } Generalizable {| All | No } {| Variable | Variables } {* @ident}` to declare which identifiers are generalizable in `` `{} `` and `` `() `` binders. - New command "Print Opaque Dependencies" to display opaque constants in addition to all variables, parameters or axioms a theorem or diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 5308330820..af658b4698 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -931,7 +931,7 @@ In the syntax of module application, the ! prefix indicates that any :token:`module_binding`. The output module type is verified against each :token:`module_type`. -.. cmdv:: Module [ Import | Export ] +.. cmdv:: Module {| Import | Export } Behaves like :cmd:`Module`, but automatically imports or exports the module. @@ -1648,7 +1648,7 @@ Declaring Implicit Arguments -.. cmd:: Arguments @qualid {* [ @ident ] | { @ident } | @ident } +.. cmd:: Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } :name: Arguments (implicits) This command is used to set implicit arguments *a posteriori*, @@ -1665,20 +1665,20 @@ Declaring Implicit Arguments This command clears implicit arguments. -.. cmdv:: Global Arguments @qualid {* [ @ident ] | { @ident } | @ident } +.. cmdv:: Global Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } This command is used to recompute the implicit arguments of :token:`qualid` after ending of the current section if any, enforcing the implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* [ @ident ] | { @ident } | @ident } +.. cmdv:: Local Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } When in a module, tell not to activate the implicit arguments of :token:`qualid` declared by this command to contexts that require the module. -.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | { @ident } | @ident } } +.. cmdv:: {? {| Global | Local } } Arguments @qualid {*, {+ {| [ @ident ] | { @ident } | @ident } } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -2148,7 +2148,7 @@ that specify which variables should be generalizable. Disable implicit generalization entirely. This is the default behavior. -.. cmd:: Generalizable (Variable | Variables) {+ @ident } +.. cmd:: Generalizable {| Variable | Variables } {+ @ident } Allow generalization of the given identifiers only. Calling this command multiple times adds to the allowed identifiers. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 945ffd6307..aa603fc966 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -668,7 +668,7 @@ A scope is a name given to a grammar entry used to produce some Ltac2 expression at parsing time. Scopes are described using a form of S-expression. .. prodn:: - ltac2_scope ::= @string %| @integer %| @lident ({+, @ltac2_scope}) + ltac2_scope ::= {| @string | @integer | @lident ({+, @ltac2_scope}) } A few scopes contain antiquotation features. For sake of uniformity, all antiquotations are introduced by the syntax :n:`$@lident`. @@ -751,7 +751,7 @@ Notations The Ltac2 parser can be extended by syntactic notations. -.. cmd:: Ltac2 Notation {+ @lident (@ltac2_scope) %| @string } {? : @integer} := @ltac2_term +.. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @integer} := @ltac2_term :name: Ltac2 Notation A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded @@ -966,7 +966,7 @@ errors produced by the typechecker. In Ltac expressions +++++++++++++++++++ -.. exn:: Unbound ( value | constructor ) X +.. exn:: Unbound {| value | constructor } X * if `X` is meant to be a term from the current stactic environment, replace the problematic use by `'X`. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 16b158c397..139506723e 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -322,7 +322,7 @@ Navigation in the proof tree .. index:: { } -.. cmd:: %{ %| %} +.. cmd:: {| %{ | %} } The command ``{`` (without a terminating period) focuses on the first goal, much like :cmd:`Focus` does, however, the subproof can only be @@ -430,7 +430,7 @@ not go beyond enclosing ``{`` and ``}``, so bullets can be reused as further nesting levels provided they are delimited by these. Bullets are made of repeated ``-``, ``+`` or ``*`` symbols: -.. prodn:: bullet ::= {+ - } %| {+ + } %| {+ * } +.. prodn:: bullet ::= {| {+ - } | {+ + } | {+ * } } Note again that when a focused goal is proved a message is displayed together with a suggestion about the right bullet or ``}`` to unfocus it @@ -492,7 +492,7 @@ The following example script illustrates all these features: Set Bullet Behavior ``````````````````` -.. opt:: Bullet Behavior %( "None" %| "Strict Subproofs" %) +.. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } :name: Bullet Behavior This option controls the bullet behavior and can take two possible values: @@ -680,7 +680,7 @@ This image shows an error message with diff highlighting in CoqIDE: How to enable diffs ``````````````````` -.. opt:: Diffs %( "on" %| "off" %| "removed" %) +.. opt:: Diffs {| "on" | "off" | "removed" } :name: Diffs The “on” setting highlights added tokens in green, while the “removed” setting diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 4e40df6f94..d6247d1bc5 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -617,7 +617,7 @@ Abbreviations selected occurrences of a term. .. prodn:: - occ_switch ::= { {? + %| - } {* @num } } + occ_switch ::= { {? {| + | - } } {* @num } } where: @@ -2273,7 +2273,7 @@ to the others. Iteration ~~~~~~~~~ -.. tacn:: do {? @num } ( @tactic | [ {+| @tactic } ] ) +.. tacn:: do {? @num } {| @tactic | [ {+| @tactic } ] } :name: do (ssreflect) This tactical offers an accurate control on the repetition of tactics. @@ -2300,7 +2300,7 @@ tactic should be repeated on the current subgoal. There are four kinds of multipliers: .. prodn:: - mult ::= @num ! %| ! %| @num ? %| ? + mult ::= {| @num ! | ! | @num ? | ? } Their meaning is: @@ -5444,7 +5444,7 @@ equivalences are indeed taken into account, otherwise only single |SSR| searching tool -------------------- -.. cmd:: Search {? @pattern } {* {? - } %( @string %| @pattern %) {? % @ident} } {? in {+ {? - } @qualid } } +.. cmd:: Search {? @pattern } {* {? - } {| @string | @pattern } {? % @ident} } {? in {+ {? - } @qualid } } :name: Search (ssreflect) This is the |SSR| extension of the Search command. :token:`qualid` is the @@ -5686,7 +5686,7 @@ respectively. local cofix definition -.. tacn:: set @ident {? : @term } := {? @occ_switch } %( @term %| ( @c_pattern) %) +.. tacn:: set @ident {? : @term } := {? @occ_switch } {| @term | ( @c_pattern) } abbreviation (see :ref:`abbreviations_ssr`) @@ -5714,26 +5714,26 @@ introduction see :ref:`introduction_ssr` localization see :ref:`localization_ssr` -.. prodn:: tactic += do {? @mult } %( @tactic %| [ {+| @tactic } ] %) +.. prodn:: tactic += do {? @mult } {| @tactic | [ {+| @tactic } ] } iteration see :ref:`iteration_ssr` -.. prodn:: tactic += @tactic ; %( first %| last %) {? @num } %( @tactic %| [ {+| @tactic } ] %) +.. prodn:: tactic += @tactic ; {| first | last } {? @num } {| @tactic | [ {+| @tactic } ] } selector see :ref:`selectors_ssr` -.. prodn:: tactic += @tactic ; %( first %| last %) {? @num } +.. prodn:: tactic += @tactic ; {| first | last } {? @num } rotation see :ref:`selectors_ssr` -.. prodn:: tactic += by %( @tactic %| [ {*| @tactic } ] %) +.. prodn:: tactic += by {| @tactic | [ {*| @tactic } ] } closing see :ref:`terminators_ssr` Commands ~~~~~~~~ -.. cmd:: Hint View for %( move %| apply %) / @ident {? | @num } +.. cmd:: Hint View for {| move | apply } / @ident {? | @num } view hint declaration (see :ref:`declaring_new_hints_ssr`) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 0f78a9b84a..c8442d7ea1 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3777,8 +3777,8 @@ The general command to add a hint to some databases :n:`{+ @ident}` is discrimination network to relax or constrain it in the case of discriminated databases. - .. cmdv:: Hint Variables %( Transparent %| Opaque %) : @ident - Hint Constants %( Transparent %| Opaque %) : @ident + .. cmdv:: Hint Variables {| Transparent | Opaque } : @ident + Hint Constants {| Transparent | Opaque } : @ident :name: Hint Variables; Hint Constants This sets the transparency flag used during unification of @@ -3850,7 +3850,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is semantics of :n:`Hint Cut @regexp` is to set the cut expression to :n:`c | regexp`, the initial cut expression being `emp`. - .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} : @ident + .. cmdv:: Hint Mode @qualid {* {| + | ! | - } } : @ident :name: Hint Mode This sets an optional mode of use of the identifier :n:`@qualid`. When @@ -4016,7 +4016,7 @@ We propose a smooth transitional path by providing the :opt:`Loose Hint Behavior option which accepts three flags allowing for a fine-grained handling of non-imported hints. -.. opt:: Loose Hint Behavior %( "Lax" %| "Warn" %| "Strict" %) +.. opt:: Loose Hint Behavior {| "Lax" | "Warn" | "Strict" } :name: Loose Hint Behavior This option accepts three values, which control the behavior of hints w.r.t. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index e207a072cc..4e4a10f590 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -91,13 +91,13 @@ and tables: Flags, options and tables are identified by a series of identifiers, each with an initial capital letter. -.. cmd:: {? Local | Global | Export } Set @flag +.. cmd:: {? {| Local | Global | Export } } Set @flag :name: Set Sets :token:`flag` on. Scoping qualifiers are described :ref:`here `. -.. cmd:: {? Local | Global | Export } Unset @flag +.. cmd:: {? {| Local | Global | Export } } Unset @flag :name: Unset Sets :token:`flag` off. Scoping qualifiers are @@ -108,13 +108,13 @@ capital letter. Prints the current value of :token:`flag`. -.. cmd:: {? Local | Global | Export } Set @option ( @num | @string ) +.. cmd:: {? {| Local | Global | Export } } Set @option {| @num | @string } :name: Set @option Sets :token:`option` to the specified value. Scoping qualifiers are described :ref:`here `. -.. cmd:: {? Local | Global | Export } Unset @option +.. cmd:: {? {| Local | Global | Export } } Unset @option :name: Unset @option Sets :token:`option` to its default value. Scoping qualifiers are @@ -129,17 +129,17 @@ capital letter. Prints the current value of all flags and options, and the names of all tables. -.. cmd:: Add @table ( @string | @qualid ) +.. cmd:: Add @table {| @string | @qualid } :name: Add @table Adds the specified value to :token:`table`. -.. cmd:: Remove @table ( @string | @qualid ) +.. cmd:: Remove @table {| @string | @qualid } :name: Remove @table Removes the specified value from :token:`table`. -.. cmd:: Test @table for ( @string | @qualid ) +.. cmd:: Test @table for {| @string | @qualid } :name: Test @table for Reports whether :token:`table` contains the specified value. @@ -162,7 +162,7 @@ capital letter. Scope qualifiers for :cmd:`Set` and :cmd:`Unset` ````````````````````````````````````````````````` -:n:`{? Local | Global | Export }` +:n:`{? {| Local | Global | Export } }` Flag and option settings can be global in scope or local to nested scopes created by :cmd:`Module` and :cmd:`Section` commands. There are four alternatives: @@ -622,7 +622,7 @@ file is a particular case of module called *library file*. but if a further module, say `A`, contains a command :cmd:`Require Export` `B`, then the command :cmd:`Require Import` `A` also imports the module `B.` - .. cmdv:: Require [Import | Export] {+ @qualid } + .. cmdv:: Require {| Import | Export } {+ @qualid } This loads the modules named by the :token:`qualid` sequence and their recursive @@ -988,7 +988,7 @@ Controlling display This option controls the normal displaying. -.. opt:: Warnings "{+, {? %( - %| + %) } @ident }" +.. opt:: Warnings "{+, {? {| - | + } } @ident }" :name: Warnings This option configures the display of warnings. It is experimental, and diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 1784519f5f..4bdfac7c42 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -418,7 +418,7 @@ class ProductionObject(CoqObject): Example:: .. prodn:: term += let: @pattern := @term in @term - .. prodn:: occ_switch ::= { {? + %| - } {* @num } } + .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } """ subdomain = "prodn" diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index a889ebda7b..01c656eb23 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -13,21 +13,38 @@ grammar TacticNotations; // needs rendering (in particular whitespace (kept in output) vs. WHITESPACE // (discarded)). +// The distinction between nopipeblock and block is needed because we only want +// to require escaping within alternative blocks, so that e.g. `first [ x | y ]` +// can be written without escaping the `|`. + top: blocks EOF; blocks: block ((whitespace)? block)*; -block: atomic | meta | hole | repeat | curlies; -repeat: LGROUP (ATOM)? WHITESPACE blocks (WHITESPACE)? RBRACE; + +block: pipe | nopipeblock; +nopipeblock: atomic | escaped | hole | alternative | repeat | curlies; + +alternative: LALT (WHITESPACE)? altblocks (WHITESPACE)? RBRACE; +altblocks: altblock ((WHITESPACE)? altsep (WHITESPACE)? altblock)+; +altblock: nopipeblock ((whitespace)? nopipeblock)*; + +repeat: LGROUP (ATOM | PIPE)? WHITESPACE blocks (WHITESPACE)? RBRACE; curlies: LBRACE (whitespace)? blocks (whitespace)? RBRACE; + +pipe: PIPE; +altsep: PIPE; whitespace: WHITESPACE; -meta: METACHAR; +escaped: ESCAPED; atomic: ATOM (SUB)?; hole: ID (SUB)?; -LGROUP: '{' [+*?]; + +LALT: '{|'; +LGROUP: '{+' | '{*' | '{?'; LBRACE: '{'; RBRACE: '}'; -METACHAR: '%' [|(){}]; -ATOM: '@' | '_' | ~[@_{} ]+; +ESCAPED: '%{' | '%}' | '%|'; +PIPE: '|'; +ATOM: '@' | '_' | ~[@_{}| ]+; ID: '@' ('_'? [a-zA-Z0-9])+; SUB: '_' '_' [a-zA-Z0-9]+; WHITESPACE: ' '+; diff --git a/doc/tools/coqrst/notations/TacticNotations.tokens b/doc/tools/coqrst/notations/TacticNotations.tokens index 88b38f97a6..2670e20aa6 100644 --- a/doc/tools/coqrst/notations/TacticNotations.tokens +++ b/doc/tools/coqrst/notations/TacticNotations.tokens @@ -1,10 +1,14 @@ -LGROUP=1 -LBRACE=2 -RBRACE=3 -METACHAR=4 -ATOM=5 -ID=6 -SUB=7 -WHITESPACE=8 -'{'=2 -'}'=3 +LALT=1 +LGROUP=2 +LBRACE=3 +RBRACE=4 +ESCAPED=5 +PIPE=6 +ATOM=7 +ID=8 +SUB=9 +WHITESPACE=10 +'{|'=1 +'{'=3 +'}'=4 +'|'=6 diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index 27293e7e09..e3a115e32a 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -1,4 +1,4 @@ -# Generated from TacticNotations.g by ANTLR 4.7 +# Generated from TacticNotations.g by ANTLR 4.7.2 from antlr4 import * from io import StringIO from typing.io import TextIO @@ -7,28 +7,34 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\n") - buf.write(":\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") - buf.write("\4\b\t\b\4\t\t\t\3\2\3\2\3\2\3\3\3\3\3\4\3\4\3\5\3\5\3") - buf.write("\5\3\6\3\6\6\6 \n\6\r\6\16\6!\5\6$\n\6\3\7\3\7\5\7(\n") - buf.write("\7\3\7\6\7+\n\7\r\7\16\7,\3\b\3\b\3\b\6\b\62\n\b\r\b\16") - buf.write("\b\63\3\t\6\t\67\n\t\r\t\16\t8\2\2\n\3\3\5\4\7\5\t\6\13") - buf.write("\7\r\b\17\t\21\n\3\2\7\4\2,-AA\4\2*+}\177\4\2BBaa\7\2") - buf.write("\"\"BBaa}}\177\177\5\2\62;C\\c|\2?\2\3\3\2\2\2\2\5\3\2") - buf.write("\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2") - buf.write("\2\17\3\2\2\2\2\21\3\2\2\2\3\23\3\2\2\2\5\26\3\2\2\2\7") - buf.write("\30\3\2\2\2\t\32\3\2\2\2\13#\3\2\2\2\r%\3\2\2\2\17.\3") - buf.write("\2\2\2\21\66\3\2\2\2\23\24\7}\2\2\24\25\t\2\2\2\25\4\3") - buf.write("\2\2\2\26\27\7}\2\2\27\6\3\2\2\2\30\31\7\177\2\2\31\b") - buf.write("\3\2\2\2\32\33\7\'\2\2\33\34\t\3\2\2\34\n\3\2\2\2\35$") - buf.write("\t\4\2\2\36 \n\5\2\2\37\36\3\2\2\2 !\3\2\2\2!\37\3\2\2") - buf.write("\2!\"\3\2\2\2\"$\3\2\2\2#\35\3\2\2\2#\37\3\2\2\2$\f\3") - buf.write("\2\2\2%*\7B\2\2&(\7a\2\2\'&\3\2\2\2\'(\3\2\2\2()\3\2\2") - buf.write("\2)+\t\6\2\2*\'\3\2\2\2+,\3\2\2\2,*\3\2\2\2,-\3\2\2\2") - buf.write("-\16\3\2\2\2./\7a\2\2/\61\7a\2\2\60\62\t\6\2\2\61\60\3") - buf.write("\2\2\2\62\63\3\2\2\2\63\61\3\2\2\2\63\64\3\2\2\2\64\20") - buf.write("\3\2\2\2\65\67\7\"\2\2\66\65\3\2\2\2\678\3\2\2\28\66\3") - buf.write("\2\2\289\3\2\2\29\22\3\2\2\2\t\2!#\',\638\2") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\f") + buf.write("M\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\3\2\3\2\3\2\3\3\3\3") + buf.write("\3\3\3\3\3\3\3\3\5\3!\n\3\3\4\3\4\3\5\3\5\3\6\3\6\3\6") + buf.write("\3\6\3\6\3\6\5\6-\n\6\3\7\3\7\3\b\3\b\6\b\63\n\b\r\b\16") + buf.write("\b\64\5\b\67\n\b\3\t\3\t\5\t;\n\t\3\t\6\t>\n\t\r\t\16") + buf.write("\t?\3\n\3\n\3\n\6\nE\n\n\r\n\16\nF\3\13\6\13J\n\13\r\13") + buf.write("\16\13K\2\2\f\3\3\5\4\7\5\t\6\13\7\r\b\17\t\21\n\23\13") + buf.write("\25\f\3\2\5\4\2BBaa\6\2\"\"BBaa}\177\5\2\62;C\\c|\2V\2") + buf.write("\3\3\2\2\2\2\5\3\2\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3") + buf.write("\2\2\2\2\r\3\2\2\2\2\17\3\2\2\2\2\21\3\2\2\2\2\23\3\2") + buf.write("\2\2\2\25\3\2\2\2\3\27\3\2\2\2\5 \3\2\2\2\7\"\3\2\2\2") + buf.write("\t$\3\2\2\2\13,\3\2\2\2\r.\3\2\2\2\17\66\3\2\2\2\218\3") + buf.write("\2\2\2\23A\3\2\2\2\25I\3\2\2\2\27\30\7}\2\2\30\31\7~\2") + buf.write("\2\31\4\3\2\2\2\32\33\7}\2\2\33!\7-\2\2\34\35\7}\2\2\35") + buf.write("!\7,\2\2\36\37\7}\2\2\37!\7A\2\2 \32\3\2\2\2 \34\3\2\2") + buf.write("\2 \36\3\2\2\2!\6\3\2\2\2\"#\7}\2\2#\b\3\2\2\2$%\7\177") + buf.write("\2\2%\n\3\2\2\2&\'\7\'\2\2\'-\7}\2\2()\7\'\2\2)-\7\177") + buf.write("\2\2*+\7\'\2\2+-\7~\2\2,&\3\2\2\2,(\3\2\2\2,*\3\2\2\2") + buf.write("-\f\3\2\2\2./\7~\2\2/\16\3\2\2\2\60\67\t\2\2\2\61\63\n") + buf.write("\3\2\2\62\61\3\2\2\2\63\64\3\2\2\2\64\62\3\2\2\2\64\65") + buf.write("\3\2\2\2\65\67\3\2\2\2\66\60\3\2\2\2\66\62\3\2\2\2\67") + buf.write("\20\3\2\2\28=\7B\2\29;\7a\2\2:9\3\2\2\2:;\3\2\2\2;<\3") + buf.write("\2\2\2<>\t\4\2\2=:\3\2\2\2>?\3\2\2\2?=\3\2\2\2?@\3\2\2") + buf.write("\2@\22\3\2\2\2AB\7a\2\2BD\7a\2\2CE\t\4\2\2DC\3\2\2\2E") + buf.write("F\3\2\2\2FD\3\2\2\2FG\3\2\2\2G\24\3\2\2\2HJ\7\"\2\2IH") + buf.write("\3\2\2\2JK\3\2\2\2KI\3\2\2\2KL\3\2\2\2L\26\3\2\2\2\13") + buf.write("\2 ,\64\66:?FK\2") return buf.getvalue() @@ -38,34 +44,36 @@ class TacticNotationsLexer(Lexer): decisionsToDFA = [ DFA(ds, i) for i, ds in enumerate(atn.decisionToState) ] - LGROUP = 1 - LBRACE = 2 - RBRACE = 3 - METACHAR = 4 - ATOM = 5 - ID = 6 - SUB = 7 - WHITESPACE = 8 + LALT = 1 + LGROUP = 2 + LBRACE = 3 + RBRACE = 4 + ESCAPED = 5 + PIPE = 6 + ATOM = 7 + ID = 8 + SUB = 9 + WHITESPACE = 10 channelNames = [ u"DEFAULT_TOKEN_CHANNEL", u"HIDDEN" ] modeNames = [ "DEFAULT_MODE" ] literalNames = [ "", - "'{'", "'}'" ] + "'{|'", "'{'", "'}'", "'|'" ] symbolicNames = [ "", - "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", "SUB", - "WHITESPACE" ] + "LALT", "LGROUP", "LBRACE", "RBRACE", "ESCAPED", "PIPE", "ATOM", + "ID", "SUB", "WHITESPACE" ] - ruleNames = [ "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", - "SUB", "WHITESPACE" ] + ruleNames = [ "LALT", "LGROUP", "LBRACE", "RBRACE", "ESCAPED", "PIPE", + "ATOM", "ID", "SUB", "WHITESPACE" ] grammarFileName = "TacticNotations.g" def __init__(self, input=None, output:TextIO = sys.stdout): super().__init__(input, output) - self.checkVersion("4.7") + self.checkVersion("4.7.2") self._interp = LexerATNSimulator(self, self.atn, self.decisionsToDFA, PredictionContextCache()) self._actions = None self._predicates = None diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens index 88b38f97a6..2670e20aa6 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens @@ -1,10 +1,14 @@ -LGROUP=1 -LBRACE=2 -RBRACE=3 -METACHAR=4 -ATOM=5 -ID=6 -SUB=7 -WHITESPACE=8 -'{'=2 -'}'=3 +LALT=1 +LGROUP=2 +LBRACE=3 +RBRACE=4 +ESCAPED=5 +PIPE=6 +ATOM=7 +ID=8 +SUB=9 +WHITESPACE=10 +'{|'=1 +'{'=3 +'}'=4 +'|'=6 diff --git a/doc/tools/coqrst/notations/TacticNotationsParser.py b/doc/tools/coqrst/notations/TacticNotationsParser.py index 645f078979..4a2a73672a 100644 --- a/doc/tools/coqrst/notations/TacticNotationsParser.py +++ b/doc/tools/coqrst/notations/TacticNotationsParser.py @@ -1,4 +1,4 @@ -# Generated from TacticNotations.g by ANTLR 4.7 +# Generated from TacticNotations.g by ANTLR 4.7.2 # encoding: utf-8 from antlr4 import * from io import StringIO @@ -7,31 +7,47 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\n") - buf.write("J\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7\4\b") - buf.write("\t\b\4\t\t\t\4\n\t\n\3\2\3\2\3\2\3\3\3\3\5\3\32\n\3\3") - buf.write("\3\7\3\35\n\3\f\3\16\3 \13\3\3\4\3\4\3\4\3\4\3\4\5\4\'") - buf.write("\n\4\3\5\3\5\5\5+\n\5\3\5\3\5\3\5\5\5\60\n\5\3\5\3\5\3") - buf.write("\6\3\6\5\6\66\n\6\3\6\3\6\5\6:\n\6\3\6\3\6\3\7\3\7\3\b") - buf.write("\3\b\3\t\3\t\5\tD\n\t\3\n\3\n\5\nH\n\n\3\n\2\2\13\2\4") - buf.write("\6\b\n\f\16\20\22\2\2\2L\2\24\3\2\2\2\4\27\3\2\2\2\6&") - buf.write("\3\2\2\2\b(\3\2\2\2\n\63\3\2\2\2\f=\3\2\2\2\16?\3\2\2") - buf.write("\2\20A\3\2\2\2\22E\3\2\2\2\24\25\5\4\3\2\25\26\7\2\2\3") - buf.write("\26\3\3\2\2\2\27\36\5\6\4\2\30\32\5\f\7\2\31\30\3\2\2") - buf.write("\2\31\32\3\2\2\2\32\33\3\2\2\2\33\35\5\6\4\2\34\31\3\2") - buf.write("\2\2\35 \3\2\2\2\36\34\3\2\2\2\36\37\3\2\2\2\37\5\3\2") - buf.write("\2\2 \36\3\2\2\2!\'\5\20\t\2\"\'\5\16\b\2#\'\5\22\n\2") - buf.write("$\'\5\b\5\2%\'\5\n\6\2&!\3\2\2\2&\"\3\2\2\2&#\3\2\2\2") - buf.write("&$\3\2\2\2&%\3\2\2\2\'\7\3\2\2\2(*\7\3\2\2)+\7\7\2\2*") - buf.write(")\3\2\2\2*+\3\2\2\2+,\3\2\2\2,-\7\n\2\2-/\5\4\3\2.\60") - buf.write("\7\n\2\2/.\3\2\2\2/\60\3\2\2\2\60\61\3\2\2\2\61\62\7\5") - buf.write("\2\2\62\t\3\2\2\2\63\65\7\4\2\2\64\66\5\f\7\2\65\64\3") - buf.write("\2\2\2\65\66\3\2\2\2\66\67\3\2\2\2\679\5\4\3\28:\5\f\7") - buf.write("\298\3\2\2\29:\3\2\2\2:;\3\2\2\2;<\7\5\2\2<\13\3\2\2\2") - buf.write("=>\7\n\2\2>\r\3\2\2\2?@\7\6\2\2@\17\3\2\2\2AC\7\7\2\2") - buf.write("BD\7\t\2\2CB\3\2\2\2CD\3\2\2\2D\21\3\2\2\2EG\7\b\2\2F") - buf.write("H\7\t\2\2GF\3\2\2\2GH\3\2\2\2H\23\3\2\2\2\13\31\36&*/") - buf.write("\659CG") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\f") + buf.write("\u0081\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\4\f\t\f\4\r\t\r\4\16") + buf.write("\t\16\4\17\t\17\4\20\t\20\3\2\3\2\3\2\3\3\3\3\5\3&\n\3") + buf.write("\3\3\7\3)\n\3\f\3\16\3,\13\3\3\4\3\4\5\4\60\n\4\3\5\3") + buf.write("\5\3\5\3\5\3\5\3\5\5\58\n\5\3\6\3\6\5\6<\n\6\3\6\3\6\5") + buf.write("\6@\n\6\3\6\3\6\3\7\3\7\5\7F\n\7\3\7\3\7\5\7J\n\7\3\7") + buf.write("\3\7\6\7N\n\7\r\7\16\7O\3\b\3\b\5\bT\n\b\3\b\7\bW\n\b") + buf.write("\f\b\16\bZ\13\b\3\t\3\t\5\t^\n\t\3\t\3\t\3\t\5\tc\n\t") + buf.write("\3\t\3\t\3\n\3\n\5\ni\n\n\3\n\3\n\5\nm\n\n\3\n\3\n\3\13") + buf.write("\3\13\3\f\3\f\3\r\3\r\3\16\3\16\3\17\3\17\5\17{\n\17\3") + buf.write("\20\3\20\5\20\177\n\20\3\20\2\2\21\2\4\6\b\n\f\16\20\22") + buf.write("\24\26\30\32\34\36\2\3\3\2\b\t\2\u0086\2 \3\2\2\2\4#\3") + buf.write("\2\2\2\6/\3\2\2\2\b\67\3\2\2\2\n9\3\2\2\2\fC\3\2\2\2\16") + buf.write("Q\3\2\2\2\20[\3\2\2\2\22f\3\2\2\2\24p\3\2\2\2\26r\3\2") + buf.write("\2\2\30t\3\2\2\2\32v\3\2\2\2\34x\3\2\2\2\36|\3\2\2\2 ") + buf.write("!\5\4\3\2!\"\7\2\2\3\"\3\3\2\2\2#*\5\6\4\2$&\5\30\r\2") + buf.write("%$\3\2\2\2%&\3\2\2\2&\'\3\2\2\2\')\5\6\4\2(%\3\2\2\2)") + buf.write(",\3\2\2\2*(\3\2\2\2*+\3\2\2\2+\5\3\2\2\2,*\3\2\2\2-\60") + buf.write("\5\24\13\2.\60\5\b\5\2/-\3\2\2\2/.\3\2\2\2\60\7\3\2\2") + buf.write("\2\618\5\34\17\2\628\5\32\16\2\638\5\36\20\2\648\5\n\6") + buf.write("\2\658\5\20\t\2\668\5\22\n\2\67\61\3\2\2\2\67\62\3\2\2") + buf.write("\2\67\63\3\2\2\2\67\64\3\2\2\2\67\65\3\2\2\2\67\66\3\2") + buf.write("\2\28\t\3\2\2\29;\7\3\2\2:<\7\f\2\2;:\3\2\2\2;<\3\2\2") + buf.write("\2<=\3\2\2\2=?\5\f\7\2>@\7\f\2\2?>\3\2\2\2?@\3\2\2\2@") + buf.write("A\3\2\2\2AB\7\6\2\2B\13\3\2\2\2CM\5\16\b\2DF\7\f\2\2E") + buf.write("D\3\2\2\2EF\3\2\2\2FG\3\2\2\2GI\5\26\f\2HJ\7\f\2\2IH\3") + buf.write("\2\2\2IJ\3\2\2\2JK\3\2\2\2KL\5\16\b\2LN\3\2\2\2ME\3\2") + buf.write("\2\2NO\3\2\2\2OM\3\2\2\2OP\3\2\2\2P\r\3\2\2\2QX\5\b\5") + buf.write("\2RT\5\30\r\2SR\3\2\2\2ST\3\2\2\2TU\3\2\2\2UW\5\b\5\2") + buf.write("VS\3\2\2\2WZ\3\2\2\2XV\3\2\2\2XY\3\2\2\2Y\17\3\2\2\2Z") + buf.write("X\3\2\2\2[]\7\4\2\2\\^\t\2\2\2]\\\3\2\2\2]^\3\2\2\2^_") + buf.write("\3\2\2\2_`\7\f\2\2`b\5\4\3\2ac\7\f\2\2ba\3\2\2\2bc\3\2") + buf.write("\2\2cd\3\2\2\2de\7\6\2\2e\21\3\2\2\2fh\7\5\2\2gi\5\30") + buf.write("\r\2hg\3\2\2\2hi\3\2\2\2ij\3\2\2\2jl\5\4\3\2km\5\30\r") + buf.write("\2lk\3\2\2\2lm\3\2\2\2mn\3\2\2\2no\7\6\2\2o\23\3\2\2\2") + buf.write("pq\7\b\2\2q\25\3\2\2\2rs\7\b\2\2s\27\3\2\2\2tu\7\f\2\2") + buf.write("u\31\3\2\2\2vw\7\7\2\2w\33\3\2\2\2xz\7\t\2\2y{\7\13\2") + buf.write("\2zy\3\2\2\2z{\3\2\2\2{\35\3\2\2\2|~\7\n\2\2}\177\7\13") + buf.write("\2\2~}\3\2\2\2~\177\3\2\2\2\177\37\3\2\2\2\23%*/\67;?") + buf.write("EIOSX]bhlz~") return buf.getvalue() @@ -45,37 +61,47 @@ class TacticNotationsParser ( Parser ): sharedContextCache = PredictionContextCache() - literalNames = [ "", "", "'{'", "'}'" ] + literalNames = [ "", "'{|'", "", "'{'", "'}'", "", + "'|'" ] - symbolicNames = [ "", "LGROUP", "LBRACE", "RBRACE", "METACHAR", - "ATOM", "ID", "SUB", "WHITESPACE" ] + symbolicNames = [ "", "LALT", "LGROUP", "LBRACE", "RBRACE", + "ESCAPED", "PIPE", "ATOM", "ID", "SUB", "WHITESPACE" ] RULE_top = 0 RULE_blocks = 1 RULE_block = 2 - RULE_repeat = 3 - RULE_curlies = 4 - RULE_whitespace = 5 - RULE_meta = 6 - RULE_atomic = 7 - RULE_hole = 8 - - ruleNames = [ "top", "blocks", "block", "repeat", "curlies", "whitespace", - "meta", "atomic", "hole" ] + RULE_nopipeblock = 3 + RULE_alternative = 4 + RULE_altblocks = 5 + RULE_altblock = 6 + RULE_repeat = 7 + RULE_curlies = 8 + RULE_pipe = 9 + RULE_altsep = 10 + RULE_whitespace = 11 + RULE_escaped = 12 + RULE_atomic = 13 + RULE_hole = 14 + + ruleNames = [ "top", "blocks", "block", "nopipeblock", "alternative", + "altblocks", "altblock", "repeat", "curlies", "pipe", + "altsep", "whitespace", "escaped", "atomic", "hole" ] EOF = Token.EOF - LGROUP=1 - LBRACE=2 - RBRACE=3 - METACHAR=4 - ATOM=5 - ID=6 - SUB=7 - WHITESPACE=8 + LALT=1 + LGROUP=2 + LBRACE=3 + RBRACE=4 + ESCAPED=5 + PIPE=6 + ATOM=7 + ID=8 + SUB=9 + WHITESPACE=10 def __init__(self, input:TokenStream, output:TextIO = sys.stdout): super().__init__(input, output) - self.checkVersion("4.7") + self.checkVersion("4.7.2") self._interp = ParserATNSimulator(self, self.atn, self.decisionsToDFA, self.sharedContextCache) self._predicates = None @@ -112,9 +138,9 @@ class TacticNotationsParser ( Parser ): self.enterRule(localctx, 0, self.RULE_top) try: self.enterOuterAlt(localctx, 1) - self.state = 18 + self.state = 30 self.blocks() - self.state = 19 + self.state = 31 self.match(TacticNotationsParser.EOF) except RecognitionException as re: localctx.exception = re @@ -163,24 +189,24 @@ class TacticNotationsParser ( Parser ): self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 21 + self.state = 33 self.block() - self.state = 28 + self.state = 40 self._errHandler.sync(self) _alt = self._interp.adaptivePredict(self._input,1,self._ctx) while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: if _alt==1: - self.state = 23 + self.state = 35 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 22 + self.state = 34 self.whitespace() - self.state = 25 + self.state = 37 self.block() - self.state = 30 + self.state = 42 self._errHandler.sync(self) _alt = self._interp.adaptivePredict(self._input,1,self._ctx) @@ -194,6 +220,61 @@ class TacticNotationsParser ( Parser ): class BlockContext(ParserRuleContext): + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def pipe(self): + return self.getTypedRuleContext(TacticNotationsParser.PipeContext,0) + + + def nopipeblock(self): + return self.getTypedRuleContext(TacticNotationsParser.NopipeblockContext,0) + + + def getRuleIndex(self): + return TacticNotationsParser.RULE_block + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitBlock" ): + return visitor.visitBlock(self) + else: + return visitor.visitChildren(self) + + + + + def block(self): + + localctx = TacticNotationsParser.BlockContext(self, self._ctx, self.state) + self.enterRule(localctx, 4, self.RULE_block) + try: + self.state = 45 + self._errHandler.sync(self) + token = self._input.LA(1) + if token in [TacticNotationsParser.PIPE]: + self.enterOuterAlt(localctx, 1) + self.state = 43 + self.pipe() + pass + elif token in [TacticNotationsParser.LALT, TacticNotationsParser.LGROUP, TacticNotationsParser.LBRACE, TacticNotationsParser.ESCAPED, TacticNotationsParser.ATOM, TacticNotationsParser.ID]: + self.enterOuterAlt(localctx, 2) + self.state = 44 + self.nopipeblock() + pass + else: + raise NoViableAltException(self) + + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class NopipeblockContext(ParserRuleContext): + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): super().__init__(parent, invokingState) self.parser = parser @@ -202,14 +283,18 @@ class TacticNotationsParser ( Parser ): return self.getTypedRuleContext(TacticNotationsParser.AtomicContext,0) - def meta(self): - return self.getTypedRuleContext(TacticNotationsParser.MetaContext,0) + def escaped(self): + return self.getTypedRuleContext(TacticNotationsParser.EscapedContext,0) def hole(self): return self.getTypedRuleContext(TacticNotationsParser.HoleContext,0) + def alternative(self): + return self.getTypedRuleContext(TacticNotationsParser.AlternativeContext,0) + + def repeat(self): return self.getTypedRuleContext(TacticNotationsParser.RepeatContext,0) @@ -219,48 +304,53 @@ class TacticNotationsParser ( Parser ): def getRuleIndex(self): - return TacticNotationsParser.RULE_block + return TacticNotationsParser.RULE_nopipeblock def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitBlock" ): - return visitor.visitBlock(self) + if hasattr( visitor, "visitNopipeblock" ): + return visitor.visitNopipeblock(self) else: return visitor.visitChildren(self) - def block(self): + def nopipeblock(self): - localctx = TacticNotationsParser.BlockContext(self, self._ctx, self.state) - self.enterRule(localctx, 4, self.RULE_block) + localctx = TacticNotationsParser.NopipeblockContext(self, self._ctx, self.state) + self.enterRule(localctx, 6, self.RULE_nopipeblock) try: - self.state = 36 + self.state = 53 self._errHandler.sync(self) token = self._input.LA(1) if token in [TacticNotationsParser.ATOM]: self.enterOuterAlt(localctx, 1) - self.state = 31 + self.state = 47 self.atomic() pass - elif token in [TacticNotationsParser.METACHAR]: + elif token in [TacticNotationsParser.ESCAPED]: self.enterOuterAlt(localctx, 2) - self.state = 32 - self.meta() + self.state = 48 + self.escaped() pass elif token in [TacticNotationsParser.ID]: self.enterOuterAlt(localctx, 3) - self.state = 33 + self.state = 49 self.hole() pass - elif token in [TacticNotationsParser.LGROUP]: + elif token in [TacticNotationsParser.LALT]: self.enterOuterAlt(localctx, 4) - self.state = 34 + self.state = 50 + self.alternative() + pass + elif token in [TacticNotationsParser.LGROUP]: + self.enterOuterAlt(localctx, 5) + self.state = 51 self.repeat() pass elif token in [TacticNotationsParser.LBRACE]: - self.enterOuterAlt(localctx, 5) - self.state = 35 + self.enterOuterAlt(localctx, 6) + self.state = 52 self.curlies() pass else: @@ -274,6 +364,232 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx + class AlternativeContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def LALT(self): + return self.getToken(TacticNotationsParser.LALT, 0) + + def altblocks(self): + return self.getTypedRuleContext(TacticNotationsParser.AltblocksContext,0) + + + def RBRACE(self): + return self.getToken(TacticNotationsParser.RBRACE, 0) + + def WHITESPACE(self, i:int=None): + if i is None: + return self.getTokens(TacticNotationsParser.WHITESPACE) + else: + return self.getToken(TacticNotationsParser.WHITESPACE, i) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_alternative + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAlternative" ): + return visitor.visitAlternative(self) + else: + return visitor.visitChildren(self) + + + + + def alternative(self): + + localctx = TacticNotationsParser.AlternativeContext(self, self._ctx, self.state) + self.enterRule(localctx, 8, self.RULE_alternative) + self._la = 0 # Token type + try: + self.enterOuterAlt(localctx, 1) + self.state = 55 + self.match(TacticNotationsParser.LALT) + self.state = 57 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 56 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 59 + self.altblocks() + self.state = 61 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 60 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 63 + self.match(TacticNotationsParser.RBRACE) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class AltblocksContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def altblock(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.AltblockContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.AltblockContext,i) + + + def altsep(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.AltsepContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.AltsepContext,i) + + + def WHITESPACE(self, i:int=None): + if i is None: + return self.getTokens(TacticNotationsParser.WHITESPACE) + else: + return self.getToken(TacticNotationsParser.WHITESPACE, i) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_altblocks + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAltblocks" ): + return visitor.visitAltblocks(self) + else: + return visitor.visitChildren(self) + + + + + def altblocks(self): + + localctx = TacticNotationsParser.AltblocksContext(self, self._ctx, self.state) + self.enterRule(localctx, 10, self.RULE_altblocks) + self._la = 0 # Token type + try: + self.enterOuterAlt(localctx, 1) + self.state = 65 + self.altblock() + self.state = 75 + self._errHandler.sync(self) + _alt = 1 + while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: + if _alt == 1: + self.state = 67 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 66 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 69 + self.altsep() + self.state = 71 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 70 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 73 + self.altblock() + + else: + raise NoViableAltException(self) + self.state = 77 + self._errHandler.sync(self) + _alt = self._interp.adaptivePredict(self._input,8,self._ctx) + + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class AltblockContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def nopipeblock(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.NopipeblockContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.NopipeblockContext,i) + + + def whitespace(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.WhitespaceContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.WhitespaceContext,i) + + + def getRuleIndex(self): + return TacticNotationsParser.RULE_altblock + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAltblock" ): + return visitor.visitAltblock(self) + else: + return visitor.visitChildren(self) + + + + + def altblock(self): + + localctx = TacticNotationsParser.AltblockContext(self, self._ctx, self.state) + self.enterRule(localctx, 12, self.RULE_altblock) + self._la = 0 # Token type + try: + self.enterOuterAlt(localctx, 1) + self.state = 79 + self.nopipeblock() + self.state = 86 + self._errHandler.sync(self) + _alt = self._interp.adaptivePredict(self._input,10,self._ctx) + while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: + if _alt==1: + self.state = 81 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 80 + self.whitespace() + + + self.state = 83 + self.nopipeblock() + self.state = 88 + self._errHandler.sync(self) + _alt = self._interp.adaptivePredict(self._input,10,self._ctx) + + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + class RepeatContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): @@ -299,6 +615,9 @@ class TacticNotationsParser ( Parser ): def ATOM(self): return self.getToken(TacticNotationsParser.ATOM, 0) + def PIPE(self): + return self.getToken(TacticNotationsParser.PIPE, 0) + def getRuleIndex(self): return TacticNotationsParser.RULE_repeat @@ -314,33 +633,38 @@ class TacticNotationsParser ( Parser ): def repeat(self): localctx = TacticNotationsParser.RepeatContext(self, self._ctx, self.state) - self.enterRule(localctx, 6, self.RULE_repeat) + self.enterRule(localctx, 14, self.RULE_repeat) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 38 + self.state = 89 self.match(TacticNotationsParser.LGROUP) - self.state = 40 + self.state = 91 self._errHandler.sync(self) _la = self._input.LA(1) - if _la==TacticNotationsParser.ATOM: - self.state = 39 - self.match(TacticNotationsParser.ATOM) + if _la==TacticNotationsParser.PIPE or _la==TacticNotationsParser.ATOM: + self.state = 90 + _la = self._input.LA(1) + if not(_la==TacticNotationsParser.PIPE or _la==TacticNotationsParser.ATOM): + self._errHandler.recoverInline(self) + else: + self._errHandler.reportMatch(self) + self.consume() - self.state = 42 + self.state = 93 self.match(TacticNotationsParser.WHITESPACE) - self.state = 43 + self.state = 94 self.blocks() - self.state = 45 + self.state = 96 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 44 + self.state = 95 self.match(TacticNotationsParser.WHITESPACE) - self.state = 47 + self.state = 98 self.match(TacticNotationsParser.RBRACE) except RecognitionException as re: localctx.exception = re @@ -388,31 +712,31 @@ class TacticNotationsParser ( Parser ): def curlies(self): localctx = TacticNotationsParser.CurliesContext(self, self._ctx, self.state) - self.enterRule(localctx, 8, self.RULE_curlies) + self.enterRule(localctx, 16, self.RULE_curlies) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 49 + self.state = 100 self.match(TacticNotationsParser.LBRACE) - self.state = 51 + self.state = 102 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 50 + self.state = 101 self.whitespace() - self.state = 53 + self.state = 104 self.blocks() - self.state = 55 + self.state = 106 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 54 + self.state = 105 self.whitespace() - self.state = 57 + self.state = 108 self.match(TacticNotationsParser.RBRACE) except RecognitionException as re: localctx.exception = re @@ -422,6 +746,80 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx + class PipeContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def PIPE(self): + return self.getToken(TacticNotationsParser.PIPE, 0) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_pipe + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitPipe" ): + return visitor.visitPipe(self) + else: + return visitor.visitChildren(self) + + + + + def pipe(self): + + localctx = TacticNotationsParser.PipeContext(self, self._ctx, self.state) + self.enterRule(localctx, 18, self.RULE_pipe) + try: + self.enterOuterAlt(localctx, 1) + self.state = 110 + self.match(TacticNotationsParser.PIPE) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class AltsepContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def PIPE(self): + return self.getToken(TacticNotationsParser.PIPE, 0) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_altsep + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAltsep" ): + return visitor.visitAltsep(self) + else: + return visitor.visitChildren(self) + + + + + def altsep(self): + + localctx = TacticNotationsParser.AltsepContext(self, self._ctx, self.state) + self.enterRule(localctx, 20, self.RULE_altsep) + try: + self.enterOuterAlt(localctx, 1) + self.state = 112 + self.match(TacticNotationsParser.PIPE) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + class WhitespaceContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): @@ -446,10 +844,10 @@ class TacticNotationsParser ( Parser ): def whitespace(self): localctx = TacticNotationsParser.WhitespaceContext(self, self._ctx, self.state) - self.enterRule(localctx, 10, self.RULE_whitespace) + self.enterRule(localctx, 22, self.RULE_whitespace) try: self.enterOuterAlt(localctx, 1) - self.state = 59 + self.state = 114 self.match(TacticNotationsParser.WHITESPACE) except RecognitionException as re: localctx.exception = re @@ -459,35 +857,35 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx - class MetaContext(ParserRuleContext): + class EscapedContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): super().__init__(parent, invokingState) self.parser = parser - def METACHAR(self): - return self.getToken(TacticNotationsParser.METACHAR, 0) + def ESCAPED(self): + return self.getToken(TacticNotationsParser.ESCAPED, 0) def getRuleIndex(self): - return TacticNotationsParser.RULE_meta + return TacticNotationsParser.RULE_escaped def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitMeta" ): - return visitor.visitMeta(self) + if hasattr( visitor, "visitEscaped" ): + return visitor.visitEscaped(self) else: return visitor.visitChildren(self) - def meta(self): + def escaped(self): - localctx = TacticNotationsParser.MetaContext(self, self._ctx, self.state) - self.enterRule(localctx, 12, self.RULE_meta) + localctx = TacticNotationsParser.EscapedContext(self, self._ctx, self.state) + self.enterRule(localctx, 24, self.RULE_escaped) try: self.enterOuterAlt(localctx, 1) - self.state = 61 - self.match(TacticNotationsParser.METACHAR) + self.state = 116 + self.match(TacticNotationsParser.ESCAPED) except RecognitionException as re: localctx.exception = re self._errHandler.reportError(self, re) @@ -523,17 +921,17 @@ class TacticNotationsParser ( Parser ): def atomic(self): localctx = TacticNotationsParser.AtomicContext(self, self._ctx, self.state) - self.enterRule(localctx, 14, self.RULE_atomic) + self.enterRule(localctx, 26, self.RULE_atomic) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 63 + self.state = 118 self.match(TacticNotationsParser.ATOM) - self.state = 65 + self.state = 120 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.SUB: - self.state = 64 + self.state = 119 self.match(TacticNotationsParser.SUB) @@ -572,17 +970,17 @@ class TacticNotationsParser ( Parser ): def hole(self): localctx = TacticNotationsParser.HoleContext(self, self._ctx, self.state) - self.enterRule(localctx, 16, self.RULE_hole) + self.enterRule(localctx, 28, self.RULE_hole) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 67 + self.state = 122 self.match(TacticNotationsParser.ID) - self.state = 69 + self.state = 124 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.SUB: - self.state = 68 + self.state = 123 self.match(TacticNotationsParser.SUB) diff --git a/doc/tools/coqrst/notations/TacticNotationsVisitor.py b/doc/tools/coqrst/notations/TacticNotationsVisitor.py index c0bcc4af37..aba696c89f 100644 --- a/doc/tools/coqrst/notations/TacticNotationsVisitor.py +++ b/doc/tools/coqrst/notations/TacticNotationsVisitor.py @@ -1,4 +1,4 @@ -# Generated from TacticNotations.g by ANTLR 4.7 +# Generated from TacticNotations.g by ANTLR 4.7.2 from antlr4 import * if __name__ is not None and "." in __name__: from .TacticNotationsParser import TacticNotationsParser @@ -24,6 +24,26 @@ class TacticNotationsVisitor(ParseTreeVisitor): return self.visitChildren(ctx) + # Visit a parse tree produced by TacticNotationsParser#nopipeblock. + def visitNopipeblock(self, ctx:TacticNotationsParser.NopipeblockContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#alternative. + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#altblocks. + def visitAltblocks(self, ctx:TacticNotationsParser.AltblocksContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#altblock. + def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): + return self.visitChildren(ctx) + + # Visit a parse tree produced by TacticNotationsParser#repeat. def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): return self.visitChildren(ctx) @@ -34,13 +54,23 @@ class TacticNotationsVisitor(ParseTreeVisitor): return self.visitChildren(ctx) + # Visit a parse tree produced by TacticNotationsParser#pipe. + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#altsep. + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + return self.visitChildren(ctx) + + # Visit a parse tree produced by TacticNotationsParser#whitespace. def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return self.visitChildren(ctx) - # Visit a parse tree produced by TacticNotationsParser#meta. - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + # Visit a parse tree produced by TacticNotationsParser#escaped. + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): return self.visitChildren(ctx) diff --git a/doc/tools/coqrst/notations/html.py b/doc/tools/coqrst/notations/html.py index 87a41cf9f3..d2b5d86b37 100644 --- a/doc/tools/coqrst/notations/html.py +++ b/doc/tools/coqrst/notations/html.py @@ -13,12 +13,24 @@ Uses the dominate package. """ from dominate import tags +from dominate.utils import text from .parsing import parse from .TacticNotationsParser import TacticNotationsParser from .TacticNotationsVisitor import TacticNotationsVisitor class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + with tags.span(_class='alternative'): + self.visitChildren(ctx) + + def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): + with tags.span(_class='alternative-block'): + self.visitChildren(ctx) + + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + tags.span('\u200b', _class="alternative-separator") + def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): with tags.span(_class="repeat-wrapper"): with tags.span(_class="repeat"): @@ -39,21 +51,20 @@ class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): tags.span(ctx.ATOM().getText()) + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + text("|") + def visitHole(self, ctx:TacticNotationsParser.HoleContext): tags.span(ctx.ID().getText()[1:], _class="hole") sub = ctx.SUB() if sub: tags.sub(sub.getText()[1:]) - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - txt = ctx.METACHAR().getText()[1:] - if (txt == "{") or (txt == "}"): - tags.span(txt) - else: - tags.span(txt, _class="meta") + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): + tags.span(ctx.ESCAPED().getText()[1:]) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): - tags.span(" ") # TODO: no need for a here + text(" ") def htmlize(notation): """Translate notation to a dominate HTML tree""" diff --git a/doc/tools/coqrst/notations/plain.py b/doc/tools/coqrst/notations/plain.py index f6e82fc68e..2180c8e6a5 100644 --- a/doc/tools/coqrst/notations/plain.py +++ b/doc/tools/coqrst/notations/plain.py @@ -22,8 +22,16 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): def __init__(self): self.buffer = StringIO() + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + self.buffer.write("[") + self.visitChildren(ctx) + self.buffer.write("]") + + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + self.buffer.write("|") + def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): - separator = ctx.ATOM() + separator = ctx.ATOM() or ctx.PIPE() self.visitChildren(ctx) if ctx.LGROUP().getText()[1] == "+": spacer = (separator.getText() + " " if separator else "") @@ -38,11 +46,14 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): self.buffer.write(ctx.ATOM().getText()) + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + self.buffer.write("|") + def visitHole(self, ctx:TacticNotationsParser.HoleContext): self.buffer.write("‘{}’".format(ctx.ID().getText()[1:])) - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - self.buffer.write(ctx.METACHAR().getText()[1:]) + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): + self.buffer.write(ctx.ESCAPED().getText()[1:]) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): self.buffer.write(" ") diff --git a/doc/tools/coqrst/notations/sphinx.py b/doc/tools/coqrst/notations/sphinx.py index e05b834184..4ed09e04a9 100644 --- a/doc/tools/coqrst/notations/sphinx.py +++ b/doc/tools/coqrst/notations/sphinx.py @@ -20,8 +20,6 @@ from .TacticNotationsVisitor import TacticNotationsVisitor from docutils import nodes from sphinx import addnodes -import sys - class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def defaultResult(self): return [] @@ -31,16 +29,36 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): aggregate.extend(nextResult) return aggregate + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + return [nodes.inline('', '', *self.visitChildren(ctx), classes=['alternative'])] + + def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): + return [nodes.inline('', '', *self.visitChildren(ctx), classes=['alternative-block'])] + + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + return [nodes.inline('|', '\u200b', classes=['alternative-separator'])] + + @staticmethod + def is_alternative(node): + return isinstance(node, nodes.inline) and node['classes'] == ['alternative'] + def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): # Uses inline nodes instead of subscript and superscript to ensure that # we get the right customization hooks at the LaTeX level wrapper = nodes.inline('', '', classes=['repeat-wrapper']) - wrapper += nodes.inline('', '', *self.visitChildren(ctx), classes=["repeat"]) + + children = self.visitChildren(ctx) + if len(children) == 1 and self.is_alternative(children[0]): + # Use a custom style if an alternative is nested in a repeat. + # (We could detect this in CSS, but it's much harder in LaTeX.) + + children[0]['classes'] = ['repeated-alternative'] + wrapper += nodes.inline('', '', *children, classes=["repeat"]) repeat_marker = ctx.LGROUP().getText()[1] wrapper += nodes.inline(repeat_marker, repeat_marker, classes=['notation-sup']) - separator = ctx.ATOM() + separator = ctx.ATOM() or ctx.PIPE() if separator: sep = separator.getText() wrapper += nodes.inline(sep, sep, classes=['notation-sub']) @@ -65,6 +83,9 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): return [node] + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + return [nodes.Text("|")] + def visitHole(self, ctx:TacticNotationsParser.HoleContext): hole = ctx.ID().getText() token_name = hole[1:] @@ -75,23 +96,18 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): sub_index = sub.getText()[2:] node += nodes.subscript(sub_index, sub_index) - return [addnodes.pending_xref(token_name, node, reftype='token', refdomain='std', reftarget=token_name)] + return [addnodes.pending_xref(token_name, node, reftype='token', + refdomain='std', reftarget=token_name)] - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - meta = ctx.METACHAR().getText() - metachar = meta[1:] # remove escape char - token_name = metachar - if (metachar == "{") or (metachar == "}"): - classes=[] - else: - classes=["meta"] - return [nodes.inline(metachar, token_name, classes=classes)] + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): + escaped = ctx.ESCAPED().getText() + return [nodes.inline(escaped, escaped[1:])] def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return [nodes.Text(" ")] def sphinxify(notation): - """Translate notation into a Sphinx document tree""" + """Translate a notation into a Sphinx document tree.""" vs = TacticNotationsToSphinxVisitor() return vs.visit(parse(notation)) -- cgit v1.2.3 From 02d547e3bc531c9a0bec8d47436c204e3bc15ddc Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 15 May 2019 09:20:37 +0000 Subject: [Nix-CI] Bignums no longer depends on camlp5 --- dev/ci/nix/bignums.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/ci/nix/bignums.nix b/dev/ci/nix/bignums.nix index 1d931c858e..d813ddd8d7 100644 --- a/dev/ci/nix/bignums.nix +++ b/dev/ci/nix/bignums.nix @@ -1,5 +1,5 @@ { ocamlPackages }: { - buildInputs = with ocamlPackages; [ ocaml findlib camlp5 ]; + buildInputs = [ ocamlPackages.ocaml ]; } -- cgit v1.2.3 From 2bb5d2b7f3432883107651141a1440ef8c62e877 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 15 May 2019 11:53:27 +0000 Subject: [default.nix] Exclude the nix/ directory from sources --- default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 1e2cb3625d..d5c6cdb8ad 100644 --- a/default.nix +++ b/default.nix @@ -74,7 +74,7 @@ stdenv.mkDerivation rec { else with builtins; filterSource (path: _: - !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci"]) ./.; + !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci" "nix"]) ./.; preConfigure = '' patchShebangs dev/tools/ -- cgit v1.2.3 From 3faa91524befcd3c163ec34684986fde3aa37462 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 15 May 2019 12:14:24 +0000 Subject: [Nix-ci] Update Unicoq patch --- dev/ci/nix/unicoq/unicoq-num.patch | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/dev/ci/nix/unicoq/unicoq-num.patch b/dev/ci/nix/unicoq/unicoq-num.patch index 6d96d94dfc..6d2f6470b1 100644 --- a/dev/ci/nix/unicoq/unicoq-num.patch +++ b/dev/ci/nix/unicoq/unicoq-num.patch @@ -4,19 +4,6 @@ Date: Thu Nov 29 08:59:22 2018 +0000 Make explicit dependency to num -diff --git a/Make b/Make -index 550dc6a..8aa1309 100644 ---- a/Make -+++ b/Make -@@ -9,7 +9,7 @@ src/logger.ml - src/munify.mli - src/munify.ml - src/unitactics.mlg --src/unicoq.mllib -+src/unicoq.mlpack - theories/Unicoq.v - test-suite/munifytest.v - test-suite/microtests.v diff --git a/Makefile.local b/Makefile.local new file mode 100644 index 0000000..88be365 @@ -24,21 +11,3 @@ index 0000000..88be365 +++ b/Makefile.local @@ -0,0 +1 @@ +CAMLPKGS += -package num -diff --git a/src/unicoq.mllib b/src/unicoq.mllib -deleted file mode 100644 -index 2b84e2d..0000000 ---- a/src/unicoq.mllib -+++ /dev/null -@@ -1,3 +0,0 @@ --Logger --Munify --Unitactics -diff --git a/src/unicoq.mlpack b/src/unicoq.mlpack -new file mode 100644 -index 0000000..2b84e2d ---- /dev/null -+++ b/src/unicoq.mlpack -@@ -0,0 +1,3 @@ -+Logger -+Munify -+Unitactics -- cgit v1.2.3 From 5c1e7ae5e16803fd7bd19fbb343b57877b646119 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 17 May 2019 08:35:41 +0000 Subject: [nix] Update reference to nixpkgs --- dev/nixpkgs.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index f4786d9431..8dfe1e7833 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/8471ab76242987b11afd4486b82888e1588f8307.tar.gz"; - sha256 = "06pp6b6x78jlinxifnphkbp79dx58jr990fkm4qziq0ay5klpxd7"; + url = "https://github.com/NixOS/nixpkgs/archive/bc9df0f66110039e495b6debe3a6cda4a1bb0fed.tar.gz"; + sha256 = "0y2w259j0vqiwjhjvlbsaqnp1nl2zwz6sbwwhkrqn7k7fmhmxnq1"; }) -- cgit v1.2.3 From a5dc22c471e299ef2ff288eedabf8b63dc3a2bce Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 17 May 2019 12:23:15 +0000 Subject: [CI/Azure/macOS] Target macOS version 10.11 --- azure-pipelines.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index f2cec1eb19..c93920a884 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -43,7 +43,7 @@ jobs: vmImage: 'macOS-10.13' variables: - MACOSX_DEPLOYMENT_TARGET: '10.12' + MACOSX_DEPLOYMENT_TARGET: '10.11' steps: - checkout: self -- cgit v1.2.3 From d8d665f900ee92fac8f776031a9a6a0981a4ed2e Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Sun, 19 May 2019 01:38:59 -0700 Subject: Implicit Quantifiers recurse in continuation of let-in --- interp/implicit_quantifiers.ml | 2 +- test-suite/bugs/closed/bug_10189.v | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/bug_10189.v diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index dffccf02fc..6277d874dd 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -281,7 +281,7 @@ let implicits_of_glob_constr ?(with_products=true) l = | _ -> () in [] | GLambda (na, bk, t, b) -> abs na bk b - | GLetIn (na, b, t, c) -> aux i b + | GLetIn (na, b, t, c) -> aux i c | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) diff --git a/test-suite/bugs/closed/bug_10189.v b/test-suite/bugs/closed/bug_10189.v new file mode 100644 index 0000000000..d603bff386 --- /dev/null +++ b/test-suite/bugs/closed/bug_10189.v @@ -0,0 +1,9 @@ +Definition foo : forall (x := unit) {y : nat}, nat := fun y => y. +Check foo (y := 3). (*We fail to get implicits in the type past a let-in*) +Definition foo' : forall (x : Set) {y : nat}, nat := fun _ y => y. +Check foo' unit (y := 3). (* It works with a function binder *) + +Definition bar := let f {x} : nat -> nat := fun y => x in f (x := 3). +(* Adding bar : nat -> nat gives implicits-in-term warning *) +Fail Check bar (x := 3). +(* The implicits from the type of the local definition leak to the outer term *) -- cgit v1.2.3 From b1a3ea4855b1e150b2e677a6d5466458893d6c60 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 15 May 2019 18:47:22 +0200 Subject: Inverting the responsibility to define logically a constant in Declare. The code was intricate due to the special handling of side-effects, while it was sufficient to extrude the logical definition to make it clearer. We thus declare a constant in two parts, first purely kernel-related, then purely libobject-related. --- interp/declare.ml | 68 +++++++++++++++++++++++++++---------------------------- library/lib.ml | 3 --- library/lib.mli | 1 - 3 files changed, 33 insertions(+), 39 deletions(-) diff --git a/interp/declare.ml b/interp/declare.ml index 76b4bab2ce..9640ea26a6 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -36,9 +36,8 @@ type internal_flag = (** Declaration of constants and parameters *) type constant_obj = { - cst_decl : global_declaration option; - (** [None] when the declaration is a side-effect and has already been defined - in the global environment. *) + cst_decl : Cooking.recipe option; + (** Non-empty only when rebuilding a constant after a section *) cst_kind : logical_kind; cst_locl : bool; } @@ -65,21 +64,21 @@ let open_constant i ((sp,kn), obj) = let exists_name id = variable_exists id || Global.exists_objlabel (Label.of_id id) -let check_exists sp = - let id = basename sp in +let check_exists id = if exists_name id then alreadydeclared (Id.print id ++ str " already exists") let cache_constant ((sp,kn), obj) = + (* Invariant: the constant must exist in the logical environment, except when + redefining it when exiting a section. See [discharge_constant]. *) let id = basename sp in let kn' = match obj.cst_decl with | None -> if Global.exists_objlabel (Label.of_id (basename sp)) then Constant.make1 kn - else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") - | Some decl -> - let () = check_exists sp in - Global.add_constant ~in_section:(Lib.sections_are_opened ()) id decl + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") + | Some r -> + Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); @@ -93,7 +92,9 @@ let discharge_constant ((sp, kn), obj) = let modlist = replacement_context () in let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in let abstract = (named_of_variable_context hyps, subst, uctx) in - let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in + let new_decl = { from; info = { Opaqueproof.modlist; abstract } } in + (* This is a hack: when leaving a section, we lose the constant definition, so + we have to store it in the libobject to be able to retrieve it after. *) Some { obj with cst_decl = Some new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) @@ -121,27 +122,22 @@ let update_tables c = declare_constant_implicits c; Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) -let register_side_effect (c, role) = +let register_constant kn kind local = let o = inConstant { cst_decl = None; - cst_kind = IsProof Theorem; - cst_locl = false; + cst_kind = kind; + cst_locl = local; } in - let id = Label.to_id (Constant.label c) in - ignore(add_leaf id o); - update_tables c; + let id = Label.to_id (Constant.label kn) in + let _ = add_leaf id o in + update_tables kn + +let register_side_effect (c, role) = + let () = register_constant c (IsProof Theorem) false in match role with | Subproof -> () | Schema (ind, kind) -> !declare_scheme kind [|ind,c|] -let declare_constant_common id cst = - let o = inConstant cst in - let _, kn as oname = add_leaf id o in - pull_to_head oname; - let c = Global.constant_of_delta_kn kn in - update_tables c; - c - let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = @@ -153,7 +149,8 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = +let define_constant ?(export_seff=false) id cd = + (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false | Polymorphic_entry _ -> true @@ -165,20 +162,21 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e export_seff || not de.const_entry_opaque || is_poly de -> - (* This globally defines the side-effects in the environment. We mark - exported constants as being side-effect not to redeclare them at - caching time. *) + (* This globally defines the side-effects in the environment. *) let de, export = Global.export_private_constants ~in_section de in export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in + let kn = Global.add_constant ~in_section id decl in + kn, export + +let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = + let () = check_exists id in + let kn, export = define_constant ~export_seff id cd in + (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in - let cst = { - cst_decl = Some decl; - cst_kind = kind; - cst_locl = local; - } in - declare_constant_common id cst + let () = register_constant kn kind local in + kn let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) @@ -297,7 +295,7 @@ let open_inductive i ((sp,kn),mie) = let cache_inductive ((sp,kn),mie) = let names = inductive_names sp kn mie in - List.iter check_exists (List.map fst names); + List.iter check_exists (List.map (fun p -> basename (fst p)) names); let id = basename sp in let kn' = Global.add_mind id mie in assert (MutInd.equal kn' (MutInd.make1 kn)); diff --git a/library/lib.ml b/library/lib.ml index a046360822..4be288ed20 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -211,9 +211,6 @@ let split_lib_at_opening sp = let add_entry sp node = lib_state := { !lib_state with lib_stk = (sp,node) :: !lib_state.lib_stk } -let pull_to_head oname = - lib_state := { !lib_state with lib_stk = (oname,List.assoc oname !lib_state.lib_stk) :: List.remove_assoc oname !lib_state.lib_stk } - let anonymous_id = let n = ref 0 in fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) diff --git a/library/lib.mli b/library/lib.mli index 30569197bc..5da76961a6 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -57,7 +57,6 @@ val segment_of_objects : val add_leaf : Id.t -> Libobject.obj -> Libobject.object_name val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit -val pull_to_head : Libobject.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) -- cgit v1.2.3 From 93aa8aad110a2839d16dce53af12f0728b59ed2a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 14 May 2019 20:27:24 +0200 Subject: Merge the definition of constants and private constants in the API. --- interp/declare.ml | 17 ++++++++++++----- interp/declare.mli | 3 +++ kernel/safe_typing.ml | 8 ++++++-- kernel/safe_typing.mli | 7 ++----- library/global.ml | 2 +- library/global.mli | 2 +- tactics/abstract.ml | 5 ++--- tactics/ind_tables.ml | 13 +++++-------- 8 files changed, 32 insertions(+), 25 deletions(-) diff --git a/interp/declare.ml b/interp/declare.ml index 9640ea26a6..29da49f29d 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -78,7 +78,8 @@ let cache_constant ((sp,kn), obj) = then Constant.make1 kn else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") | Some r -> - Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) + let kn, _ = Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) in + kn in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); @@ -149,7 +150,7 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let define_constant ?(export_seff=false) id cd = +let define_constant ?role ?(export_seff=false) id cd = (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false @@ -167,17 +168,23 @@ let define_constant ?(export_seff=false) id cd = export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in - let kn = Global.add_constant ~in_section id decl in - kn, export + let kn, eff = Global.add_constant ?role ~in_section id decl in + kn, eff, export let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = let () = check_exists id in - let kn, export = define_constant ~export_seff id cd in + let kn, _eff, export = define_constant ~export_seff id cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn +let declare_private_constant ~role ?(internal=UserIndividualRequest) ?(local = false) id (cd, kind) = + let kn, eff, export = define_constant ~role id cd in + let () = assert (List.is_empty export) in + let () = register_constant kn kind local in + kn, eff + let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) id ?types (body,univs) = diff --git a/interp/declare.mli b/interp/declare.mli index 8f1e73c88c..2ffde31fc0 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -55,6 +55,9 @@ val definition_entry : ?fix_exn:Future.fix_exn -> val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t +val declare_private_constant : + role:side_effect_role -> ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> Constant.t * Safe_typing.private_constants + val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> ?local:bool -> Id.t -> ?types:constr -> diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 75375812c0..f2e7cff8ec 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -797,7 +797,7 @@ let export_private_constants ~in_section ce senv = let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv -let add_constant ~in_section l decl senv = +let add_constant ?role ~in_section l decl senv = let kn = Constant.make2 senv.modpath l in let senv = let cb = @@ -822,7 +822,11 @@ let add_constant ~in_section l decl senv = add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv | _ -> senv in - kn, senv + let eff = match role with + | None -> empty_private_constants + | Some role -> private_constant senv role kn + in + (kn, eff), senv (** Insertion of inductive types *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d6c7022cf5..b9a68663d3 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -48,9 +48,6 @@ val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) -val private_constant : safe_environment -> Entries.side_effect_role -> Constant.t -> private_constants -(** Constant must be the last definition of the safe_environment. *) - val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : Environ.env -> Constr.constr -> private_constants -> Constr.constr @@ -103,8 +100,8 @@ val export_private_constants : in_section:bool -> (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) val add_constant : - in_section:bool -> Label.t -> global_declaration -> - Constant.t safe_transformer + ?role:Entries.side_effect_role -> in_section:bool -> Label.t -> global_declaration -> + (Constant.t * private_constants) safe_transformer (** Adding an inductive type *) diff --git a/library/global.ml b/library/global.ml index 06e06a8cf2..33cdbd88ea 100644 --- a/library/global.ml +++ b/library/global.ml @@ -94,7 +94,7 @@ let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) -let add_constant ~in_section id d = globalize (Safe_typing.add_constant ~in_section (i2l id) d) +let add_constant ?role ~in_section id d = globalize (Safe_typing.add_constant ?role ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) diff --git a/library/global.mli b/library/global.mli index a60de48897..f65ffaa2ee 100644 --- a/library/global.mli +++ b/library/global.mli @@ -46,7 +46,7 @@ val export_private_constants : in_section:bool -> unit Entries.definition_entry * Safe_typing.exported_private_constant list val add_constant : - in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t + ?role:Entries.side_effect_role -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * Safe_typing.private_constants val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 499152f39a..6dd9a976f9 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -158,9 +158,9 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl + Declare.declare_private_constant ~role:Entries.Subproof ~internal:Declare.InternalTacticRequest ~local:true id decl in - let cst = Impargs.with_implicit_protection cst () in + let cst, eff = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with | Entries.Monomorphic_entry _ -> EInstance.empty | Entries.Polymorphic_entry (_, ctx) -> @@ -174,7 +174,6 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in - let eff = private_constant (Global.safe_env ()) Entries.Subproof cst in let effs = concat_private eff Entries.(snd (Future.force const.const_entry_body)) in let solve = diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e95778a90d..b9485b8823 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -116,8 +116,7 @@ let compute_name internal id = | InternalTacticRequest -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name -let define internal id c poly univs = - let fd = declare_constant ~internal in +let define internal role id c poly univs = let id = compute_name internal id in let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in @@ -133,12 +132,12 @@ let define internal id c poly univs = const_entry_inline_code = false; const_entry_feedback = None; } in - let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in + let kn, eff = declare_private_constant ~role ~internal id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in let () = match internal with | InternalTacticRequest -> () | _-> definition_message id in - kn + kn, eff let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let (c, ctx), eff = f mode ind in @@ -146,9 +145,8 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define mode id c (Declareops.inductive_is_polymorphic mib) ctx in let role = Entries.Schema (ind, kind) in - let neff = Safe_typing.private_constant (Global.safe_env ()) role const in + let const, neff = define mode role id c (Declareops.inductive_is_polymorphic mib) ctx in declare_scheme kind [|ind,const|]; const, Safe_typing.concat_private neff eff @@ -165,9 +163,8 @@ let define_mutual_scheme_base kind suff f mode names mind = try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let fold i effs id cl = - let cst = define mode id cl (Declareops.inductive_is_polymorphic mib) ctx in let role = Entries.Schema ((mind, i), kind)in - let neff = Safe_typing.private_constant (Global.safe_env ()) role cst in + let cst, neff = define mode role id cl (Declareops.inductive_is_polymorphic mib) ctx in (Safe_typing.concat_private neff effs, cst) in let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in -- cgit v1.2.3 From 925778ff0128dfbfe00aafa8a4aa9f3a2eb2301d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 15 May 2019 17:00:57 +0200 Subject: Make the type of constant bodies parametric on opaque proofs. --- kernel/cClosure.ml | 2 +- kernel/cClosure.mli | 2 +- kernel/cbytegen.mli | 2 +- kernel/cooking.ml | 2 +- kernel/cooking.mli | 2 +- kernel/declarations.ml | 6 +++--- pretyping/cbv.ml | 2 +- 7 files changed, 9 insertions(+), 9 deletions(-) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 412637c4b6..95f88c0306 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -389,7 +389,7 @@ type clos_infos = { i_flags : reds; i_cache : infos_cache } -type clos_tab = fconstr constant_def KeyTable.t +type clos_tab = (fconstr, Empty.t) constant_def KeyTable.t let info_flags info = info.i_flags let info_env info = info.i_cache.i_env diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index b1b69dded8..1a790eaed6 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -215,7 +215,7 @@ val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) -val unfold_reference : clos_infos -> clos_tab -> table_key -> fconstr constant_def +val unfold_reference : clos_infos -> clos_tab -> table_key -> (fconstr, Util.Empty.t) constant_def (*********************************************************************** i This is for lazy debug *) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 6a9550342c..bdaf5fe422 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -20,7 +20,7 @@ val compile : fail_on_error:bool -> (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> - env -> universes -> Constr.t Mod_subst.substituted constant_def -> + env -> universes -> (Constr.t Mod_subst.substituted, 'opaque) constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 9b974c4ecc..19da63b4d4 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -156,7 +156,7 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { - cook_body : constr Mod_subst.substituted constant_def; + cook_body : (constr Mod_subst.substituted, Opaqueproof.opaque) constant_def; cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; diff --git a/kernel/cooking.mli b/kernel/cooking.mli index b0f143c47d..d218dd36da 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -18,7 +18,7 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { - cook_body : constr Mod_subst.substituted constant_def; + cook_body : (constr Mod_subst.substituted, Opaqueproof.opaque) constant_def; cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 5551742c02..649bb8725d 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -47,10 +47,10 @@ type inline = int option transparent body, or an opaque one *) (* Global declarations (i.e. constants) can be either: *) -type 'a constant_def = +type ('a, 'opaque) constant_def = | Undef of inline (** a global assumption *) | Def of 'a (** or a transparent global definition *) - | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) + | OpaqueDef of 'opaque (** or an opaque global definition *) | Primitive of CPrimitives.t (** or a primitive operation *) type universes = @@ -89,7 +89,7 @@ type typing_flags = { * the OpaqueDef *) type constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) - const_body : Constr.t Mod_subst.substituted constant_def; + const_body : (Constr.t Mod_subst.substituted, Opaqueproof.opaque) constant_def; const_type : types; const_relevance : Sorts.relevance; const_body_code : Cemitcodes.to_patch_substituted option; diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index c9f18d89be..5ea9b79336 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -145,7 +145,7 @@ let mkSTACK = function type cbv_infos = { env : Environ.env; - tab : cbv_value Declarations.constant_def KeyTable.t; + tab : (cbv_value, Empty.t) Declarations.constant_def KeyTable.t; reds : RedFlags.reds; sigma : Evd.evar_map } -- cgit v1.2.3 From 801aed67a90ec49c15a4469e1905aa2835fabe19 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 15 May 2019 23:50:42 +0200 Subject: Parameterize the constant_body type by opaque subproofs. --- kernel/cooking.ml | 2 +- kernel/cooking.mli | 2 +- kernel/declarations.ml | 6 +++--- kernel/declareops.mli | 12 ++++++------ kernel/environ.ml | 2 +- kernel/environ.mli | 12 ++++++------ kernel/nativecode.mli | 2 +- kernel/safe_typing.ml | 2 +- kernel/subtyping.ml | 2 +- kernel/term_typing.mli | 6 +++--- library/global.mli | 4 ++-- plugins/extraction/extraction.mli | 4 ++-- plugins/extraction/table.ml | 4 ++-- plugins/extraction/table.mli | 8 ++++---- 14 files changed, 34 insertions(+), 34 deletions(-) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 19da63b4d4..d879f4ee95 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -152,7 +152,7 @@ let abstract_constant_body c (hyps, subst) = let c = Vars.subst_vars subst c in it_mkLambda_or_LetIn c hyps -type recipe = { from : constant_body; info : Opaqueproof.cooking_info } +type recipe = { from : Opaqueproof.opaque constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { diff --git a/kernel/cooking.mli b/kernel/cooking.mli index d218dd36da..ffd4e51ffc 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -13,7 +13,7 @@ open Declarations (** {6 Cooking the constants. } *) -type recipe = { from : constant_body; info : Opaqueproof.cooking_info } +type recipe = { from : Opaqueproof.opaque constant_body; info : Opaqueproof.cooking_info } type inline = bool diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 649bb8725d..36ee952099 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -87,9 +87,9 @@ type typing_flags = { (* some contraints are in constant_constraints, some other may be in * the OpaqueDef *) -type constant_body = { +type 'opaque constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) - const_body : (Constr.t Mod_subst.substituted, Opaqueproof.opaque) constant_def; + const_body : (Constr.t Mod_subst.substituted, 'opaque) constant_def; const_type : types; const_relevance : Sorts.relevance; const_body_code : Cemitcodes.to_patch_substituted option; @@ -246,7 +246,7 @@ type module_alg_expr = (** A component of a module structure *) type structure_field_body = - | SFBconst of constant_body + | SFBconst of Opaqueproof.opaque constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 54a853fc81..fb02c6a029 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -26,21 +26,21 @@ val map_decl_arity : ('a -> 'c) -> ('b -> 'd) -> (** {6 Constants} *) -val subst_const_body : substitution -> constant_body -> constant_body +val subst_const_body : substitution -> Opaqueproof.opaque constant_body -> Opaqueproof.opaque constant_body (** Is there a actual body in const_body ? *) -val constant_has_body : constant_body -> bool +val constant_has_body : 'a constant_body -> bool -val constant_polymorphic_context : constant_body -> AUContext.t +val constant_polymorphic_context : 'a constant_body -> AUContext.t (** Is the constant polymorphic? *) -val constant_is_polymorphic : constant_body -> bool +val constant_is_polymorphic : 'a constant_body -> bool (** Return the universe context, in case the definition is polymorphic, otherwise the context is empty. *) -val is_opaque : constant_body -> bool +val is_opaque : 'a constant_body -> bool (** {6 Inductive types} *) @@ -83,7 +83,7 @@ val safe_flags : Conv_oracle.oracle -> typing_flags of the structure, but simply hash-cons all inner constr and other known elements *) -val hcons_const_body : constant_body -> constant_body +val hcons_const_body : 'a constant_body -> 'a constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body val hcons_module_body : module_body -> module_body val hcons_module_type : module_type_body -> module_type_body diff --git a/kernel/environ.ml b/kernel/environ.ml index 97c9f8654a..67125e9ad1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -46,7 +46,7 @@ type link_info = | LinkedInteractive of string | NotLinked -type constant_key = constant_body * (link_info ref * key) +type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref diff --git a/kernel/environ.mli b/kernel/environ.mli index 8c6bc105c7..6d3756e891 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -42,7 +42,7 @@ type link_info = type key = int CEphemeron.key option ref -type constant_key = constant_body * (link_info ref * key) +type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref @@ -174,19 +174,19 @@ val reset_with_named_context : named_context_val -> env -> env val pop_rel_context : int -> env -> env (** Useful for printing *) -val fold_constants : (Constant.t -> constant_body -> 'a -> 'a) -> env -> 'a -> 'a +val fold_constants : (Constant.t -> Opaqueproof.opaque constant_body -> 'a -> 'a) -> env -> 'a -> 'a (** {5 Global constants } {6 Add entries to global environment } *) -val add_constant : Constant.t -> constant_body -> env -> env -val add_constant_key : Constant.t -> constant_body -> link_info -> +val add_constant : Constant.t -> Opaqueproof.opaque constant_body -> env -> env +val add_constant_key : Constant.t -> Opaqueproof.opaque constant_body -> link_info -> env -> env val lookup_constant_key : Constant.t -> env -> constant_key (** Looks up in the context of global constant names raises [Not_found] if the required path is not found *) -val lookup_constant : Constant.t -> env -> constant_body +val lookup_constant : Constant.t -> env -> Opaqueproof.opaque constant_body val evaluable_constant : Constant.t -> env -> bool (** New-style polymorphism *) @@ -219,7 +219,7 @@ val constant_context : env -> Constant.t -> Univ.AUContext.t it lives in. For monomorphic constant, the latter is empty, and for polymorphic constants, the term contains De Bruijn universe variables that need to be instantiated. *) -val body_of_constant_body : env -> constant_body -> (Constr.constr * Univ.AUContext.t) option +val body_of_constant_body : env -> Opaqueproof.opaque constant_body -> (Constr.constr * Univ.AUContext.t) option (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 96efa7faa5..b5c03b6ca3 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -65,7 +65,7 @@ val empty_updates : code_location_updates val register_native_file : string -> unit val compile_constant_field : env -> string -> Constant.t -> - global list -> constant_body -> global list + global list -> 'a constant_body -> global list val compile_mind_field : ModPath.t -> Label.t -> global list -> mutual_inductive_body -> global list diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f2e7cff8ec..36f1515a8c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -247,7 +247,7 @@ let get_opaque_body env cbo = type side_effect = { from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; - seff_body : Declarations.constant_body; + seff_body : Opaqueproof.opaque Declarations.constant_body; seff_env : seff_env; seff_role : Entries.side_effect_role; } diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 1857ea3329..24845ce459 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -31,7 +31,7 @@ open Mod_subst an inductive type. It can also be useful to allow reorderings in inductive types *) type namedobject = - | Constant of constant_body + | Constant of Opaqueproof.opaque constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 1fa5eca2e3..01b69b2b66 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -33,9 +33,9 @@ val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> - constant_body + Opaqueproof.opaque constant_body -val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> constant_body +val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body (** Internal functions, mentioned here for debug purpose only *) @@ -43,4 +43,4 @@ val infer_declaration : trust:'a trust -> env -> 'a constant_entry -> Cooking.result val build_constant_declaration : - Constant.t -> env -> Cooking.result -> constant_body + Constant.t -> env -> Cooking.result -> Opaqueproof.opaque constant_body diff --git a/library/global.mli b/library/global.mli index f65ffaa2ee..eabae89d8d 100644 --- a/library/global.mli +++ b/library/global.mli @@ -84,7 +84,7 @@ val add_module_parameter : (** {6 Queries in the global environment } *) val lookup_named : variable -> Constr.named_declaration -val lookup_constant : Constant.t -> Declarations.constant_body +val lookup_constant : Constant.t -> Opaqueproof.opaque Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_pinductive : Constr.pinductive -> @@ -105,7 +105,7 @@ val body_of_constant : Constant.t -> (Constr.constr * Univ.AUContext.t) option polymorphic constants, the term contains De Bruijn universe variables that need to be instantiated. *) -val body_of_constant_body : Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option +val body_of_constant_body : Opaqueproof.opaque Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option (** Same as {!body_of_constant} but on {!Declarations.constant_body}. *) (** {6 Compiled libraries } *) diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index d27c79cb62..bf98f8cd70 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -16,9 +16,9 @@ open Environ open Evd open Miniml -val extract_constant : env -> Constant.t -> constant_body -> ml_decl +val extract_constant : env -> Constant.t -> Opaqueproof.opaque constant_body -> ml_decl -val extract_constant_spec : env -> Constant.t -> constant_body -> ml_spec +val extract_constant_spec : env -> Constant.t -> 'a constant_body -> ml_spec (** For extracting "module ... with ..." declaration *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 399a77c596..4e229a94b6 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -109,7 +109,7 @@ let labels_of_ref r = (*s Constants tables. *) -let typedefs = ref (Cmap_env.empty : (constant_body * ml_type) Cmap_env.t) +let typedefs = ref (Cmap_env.empty : (Opaqueproof.opaque constant_body * ml_type) Cmap_env.t) let init_typedefs () = typedefs := Cmap_env.empty let add_typedef kn cb t = typedefs := Cmap_env.add kn (cb,t) !typedefs @@ -120,7 +120,7 @@ let lookup_typedef kn cb = with Not_found -> None let cst_types = - ref (Cmap_env.empty : (constant_body * ml_schema) Cmap_env.t) + ref (Cmap_env.empty : (Opaqueproof.opaque constant_body * ml_schema) Cmap_env.t) let init_cst_types () = cst_types := Cmap_env.empty let add_cst_type kn cb s = cst_types := Cmap_env.add kn (cb,s) !cst_types let lookup_cst_type kn cb = diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index acc1bfee8a..7e53964642 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -72,11 +72,11 @@ val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list [mutual_inductive_body] as checksum. In both case, we should ideally also check the env *) -val add_typedef : Constant.t -> constant_body -> ml_type -> unit -val lookup_typedef : Constant.t -> constant_body -> ml_type option +val add_typedef : Constant.t -> Opaqueproof.opaque constant_body -> ml_type -> unit +val lookup_typedef : Constant.t -> Opaqueproof.opaque constant_body -> ml_type option -val add_cst_type : Constant.t -> constant_body -> ml_schema -> unit -val lookup_cst_type : Constant.t -> constant_body -> ml_schema option +val add_cst_type : Constant.t -> Opaqueproof.opaque constant_body -> ml_schema -> unit +val lookup_cst_type : Constant.t -> Opaqueproof.opaque constant_body -> ml_schema option val add_ind : MutInd.t -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : MutInd.t -> mutual_inductive_body -> ml_ind option -- cgit v1.2.3 From 942621f7747bd56a7da35cacc21f0e5fdbf93413 Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Sun, 12 May 2019 19:38:36 -0400 Subject: [refman] Misc fixes (indentation, whitespace, notation syntax) --- doc/sphinx/addendum/generalized-rewriting.rst | 23 +++++++++--------- doc/sphinx/addendum/type-classes.rst | 12 +++++----- doc/sphinx/language/gallina-extensions.rst | 10 ++++---- .../language/gallina-specification-language.rst | 26 ++++++++++---------- doc/sphinx/proof-engine/ltac.rst | 28 +++++++++++----------- doc/sphinx/proof-engine/proof-handling.rst | 4 ++-- .../proof-engine/ssreflect-proof-language.rst | 2 +- doc/sphinx/proof-engine/tactics.rst | 18 +++++++------- doc/sphinx/proof-engine/vernacular-commands.rst | 12 +++++----- doc/sphinx/user-extensions/proof-schemes.rst | 27 +++++++++++---------- 10 files changed, 83 insertions(+), 79 deletions(-) diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 4d9e8d8b3a..847abb33fc 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -170,12 +170,12 @@ compatibility constraints. Adding new relations and morphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Add Parametric Relation (x1 : T1) ... (xn : Tk) : (A t1 ... tn) (Aeq t′1 ... t′m) {? reflexivity proved by refl} {? symmetry proved by sym} {? transitivity proved by trans} as @ident +.. cmd:: Add Parametric Relation @binders : (A t1 ... tn) (Aeq t′1 ... t′m) {? reflexivity proved by @term} {? symmetry proved by @term} {? transitivity proved by @term} as @ident This command declares a parametric relation :g:`Aeq: forall (y1 : β1 ... ym : βm)`, :g:`relation (A t1 ... tn)` over :g:`(A : αi -> ... αn -> Type)`. - The :token:`ident` gives a unique name to the morphism and it is used + The final :token:`ident` gives a unique name to the morphism and it is used by the command to generate fresh names for automatically provided lemmas used internally. @@ -219,15 +219,16 @@ replace terms with related ones only in contexts that are syntactic compositions of parametric morphism instances declared with the following command. -.. cmd:: Add Parametric Morphism (x1 : T1) ... (xk : Tk) : (f t1 ... tn) with signature sig as @ident +.. cmd:: Add Parametric Morphism @binders : (@ident {+ @term__1}) with signature @term__2 as @ident - This command declares ``f`` as a parametric morphism of signature ``sig``. The - identifier :token:`ident` gives a unique name to the morphism and it is used as - the base name of the typeclass instance definition and as the name of - the lemma that proves the well-definedness of the morphism. The - parameters of the morphism as well as the signature may refer to the - context of variables. The command asks the user to prove interactively - that ``f`` respects the relations identified from the signature. + This command declares a parametric morphism :n:`@ident {+ @term__1}` of + signature :n:`@term__2`. The final identifier :token:`ident` gives a unique + name to the morphism and it is used as the base name of the typeclass + instance definition and as the name of the lemma that proves the + well-definedness of the morphism. The parameters of the morphism as well as + the signature may refer to the context of variables. The command asks the + user to prove interactively that the function denoted by the first + :token:`ident` respects the relations identified from the signature. .. example:: @@ -577,7 +578,7 @@ Deprecated syntax and backward incompatibilities Notice that the syntax is not completely backward compatible since the identifier was not required. -.. cmd:: Add Morphism f : @ident +.. cmd:: Add Morphism @ident : @ident :name: Add Morphism This command is restricted to the declaration of morphisms diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 9219aa21ca..f0c9ba5735 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -311,7 +311,7 @@ Summary of the commands This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {? @binders} : @class t1 … tn {? | priority } := { field1 := b1 ; …; fieldi := bi } +.. cmd:: Instance @ident {? @binders} : @class t1 … tn {? | priority} := { field1 := b1 ; …; fieldi := bi } This command is used to declare a typeclass instance named :token:`ident` of the class :token:`class` with parameters ``t1`` to ``tn`` and @@ -324,11 +324,11 @@ Summary of the commands :tacn:`auto` hints. If the priority is not specified, it defaults to the number of non-dependent binders of the instance. - .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n {? | priority } := @term + .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class {+ @term} {? | @priority } := @term This syntax is used for declaration of singleton class instances or for directly giving an explicit term of type :n:`forall @binders, @class - @term__1 … @term__n`. One need not even mention the unique field name for + {+ @term}`. One need not even mention the unique field name for singleton classes. .. cmdv:: Global Instance @@ -356,7 +356,7 @@ Summary of the commands Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a few other commands related to typeclasses. -.. cmd:: Existing Instance {+ @ident} {? | priority } +.. cmd:: Existing Instance {+ @ident} {? | @priority} This command adds an arbitrary list of constants whose type ends with an applied typeclass to the instance database with an optional @@ -408,7 +408,7 @@ few other commands related to typeclasses. + When considering local hypotheses, we use the union of all the modes declared in the given databases. - .. cmdv:: typeclasses eauto @num + .. tacv:: typeclasses eauto @num .. warning:: The semantics for the limit :n:`@num` @@ -417,7 +417,7 @@ few other commands related to typeclasses. counted, which might result in larger limits being necessary when searching with ``typeclasses eauto`` than with :tacn:`auto`. - .. cmdv:: typeclasses eauto with {+ @ident} + .. tacv:: typeclasses eauto with {+ @ident} This variant runs resolution with the given hint databases. It treats typeclass subgoals the same as other subgoals (no shelving of diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index ccd25ec9f3..96e74bf118 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -831,16 +831,16 @@ Sections create local contexts which can be shared across multiple definitions. Links :token:`type` to each :token:`ident`. - .. cmdv:: Variable {+ ( {+ @ident } : @type ) } + .. cmdv:: Variable {+ ( {+ @ident } : @type ) } Declare one or more variables with various types. - .. cmdv:: Variables {+ ( {+ @ident } : @type) } - Hypothesis {+ ( {+ @ident } : @type) } - Hypotheses {+ ( {+ @ident } : @type) } + .. cmdv:: Variables {+ ( {+ @ident } : @type) } + Hypothesis {+ ( {+ @ident } : @type) } + Hypotheses {+ ( {+ @ident } : @type) } :name: Variables; Hypothesis; Hypotheses - These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @type) }`. + These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @type) }`. .. cmd:: Let @ident := @term diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 5a1af9f9fa..8acbcbec8f 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -616,34 +616,34 @@ has type :token:`type`. Adds several parameters with specification :token:`type`. - .. cmdv:: Parameter {+ ( {+ @ident } : @type ) } + .. cmdv:: Parameter {+ ( {+ @ident } : @type ) } Adds blocks of parameters with different specifications. - .. cmdv:: Local Parameter {+ ( {+ @ident } : @type ) } + .. cmdv:: Local Parameter {+ ( {+ @ident } : @type ) } :name: Local Parameter Such parameters are never made accessible through their unqualified name by :cmd:`Import` and its variants. You have to explicitly give their fully qualified name to refer to them. - .. cmdv:: {? Local } Parameters {+ ( {+ @ident } : @type ) } - {? Local } Axiom {+ ( {+ @ident } : @type ) } - {? Local } Axioms {+ ( {+ @ident } : @type ) } - {? Local } Conjecture {+ ( {+ @ident } : @type ) } - {? Local } Conjectures {+ ( {+ @ident } : @type ) } + .. cmdv:: {? Local } Parameters {+ ( {+ @ident } : @type ) } + {? Local } Axiom {+ ( {+ @ident } : @type ) } + {? Local } Axioms {+ ( {+ @ident } : @type ) } + {? Local } Conjecture {+ ( {+ @ident } : @type ) } + {? Local } Conjectures {+ ( {+ @ident } : @type ) } :name: Parameters; Axiom; Axioms; Conjecture; Conjectures - These variants are synonyms of :n:`{? Local } Parameter {+ ( {+ @ident } : @type ) }`. + These variants are synonyms of :n:`{? Local } Parameter {+ ( {+ @ident } : @type ) }`. - .. cmdv:: Variable {+ ( {+ @ident } : @type ) } - Variables {+ ( {+ @ident } : @type ) } - Hypothesis {+ ( {+ @ident } : @type ) } - Hypotheses {+ ( {+ @ident } : @type ) } + .. cmdv:: Variable {+ ( {+ @ident } : @type ) } + Variables {+ ( {+ @ident } : @type ) } + Hypothesis {+ ( {+ @ident } : @type ) } + Hypotheses {+ ( {+ @ident } : @type ) } :name: Variable (outside a section); Variables (outside a section); Hypothesis (outside a section); Hypotheses (outside a section) Outside of any section, these variants are synonyms of - :n:`Local Parameter {+ ( {+ @ident } : @type ) }`. + :n:`Local Parameter {+ ( {+ @ident } : @type ) }`. For their meaning inside a section, see :cmd:`Variable` in :ref:`section-mechanism`. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index a7eb7c2319..bbd7e0ba3d 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -360,7 +360,7 @@ Detecting progress We can check if a tactic made progress with: -.. tacn:: progress expr +.. tacn:: progress @expr :name: progress :n:`@expr` is evaluated to v which must be a tactic value. The tactic value ``v`` @@ -555,7 +555,7 @@ Identity The constant :n:`idtac` is the identity tactic: it leaves any goal unchanged but it appears in the proof script. -.. tacn:: idtac {* message_token} +.. tacn:: idtac {* @message_token} :name: idtac This prints the given tokens. Strings and integers are printed @@ -684,7 +684,7 @@ Timing a tactic that evaluates to a term Tactic expressions that produce terms can be timed with the experimental tactic -.. tacn:: time_constr expr +.. tacn:: time_constr @expr :name: time_constr which evaluates :n:`@expr ()` and displays the time the tactic expression @@ -880,7 +880,7 @@ We can perform pattern matching on goals using the following expression: .. we should provide the full grammar here -.. tacn:: match goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end +.. tacn:: match goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end :name: match goal If each hypothesis pattern :n:`hyp`\ :sub:`1,i`, with i = 1, ..., m\ :sub:`1` is @@ -918,7 +918,7 @@ We can perform pattern matching on goals using the following expression: first), but it possible to reverse this order (oldest first) with the :n:`match reverse goal with` variant. - .. tacv:: multimatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + .. tacv:: multimatch goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end Using :n:`multimatch` instead of :n:`match` will allow subsequent tactics to backtrack into a right-hand side tactic which has backtracking points @@ -929,7 +929,7 @@ We can perform pattern matching on goals using the following expression: The syntax :n:`match [reverse] goal …` is, in fact, a shorthand for :n:`once multimatch [reverse] goal …`. - .. tacv:: lazymatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + .. tacv:: lazymatch goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end Using lazymatch instead of match will perform the same pattern matching procedure but will commit to the first matching branch with the first @@ -1135,33 +1135,33 @@ Defining |Ltac| functions Basically, |Ltac| toplevel definitions are made as follows: -.. cmd:: Ltac @ident {* @ident} := @expr +.. cmd:: {? Local} Ltac @ident {* @ident} := @expr + :name: Ltac This defines a new |Ltac| function that can be used in any tactic script or new |Ltac| toplevel definition. + If preceded by the keyword ``Local``, the tactic definition will not be + exported outside the current module. + .. note:: The preceding definition can equivalently be written: :n:`Ltac @ident := fun {+ @ident} => @expr` - Recursive and mutual recursive function definitions are also possible - with the syntax: - .. cmdv:: Ltac @ident {* @ident} {* with @ident {* @ident}} := @expr - It is also possible to *redefine* an existing user-defined tactic using the syntax: + This syntax allows recursive and mutual recursive function definitions. .. cmdv:: Ltac @qualid {* @ident} ::= @expr + This syntax *redefines* an existing user-defined tactic. + A previous definition of qualid must exist in the environment. The new definition will always be used instead of the old one and it goes across module boundaries. - If preceded by the keyword Local the tactic definition will not be - exported outside the current module. - Printing |Ltac| tactics ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 139506723e..4a2f9c0db3 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -544,9 +544,9 @@ Requesting information ````. - .. deprecated:: 8.10 + .. deprecated:: 8.10 - Please use a text editor. + Please use a text editor. .. cmdv:: Show Proof :name: Show Proof diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index d6247d1bc5..75e019592f 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -2571,7 +2571,7 @@ destruction of existential assumptions like in the tactic: An alternative use of the ``have`` tactic is to provide the explicit proof term for the intermediate lemma, using tactics of the form: -.. tacv:: have {? @ident } := term +.. tacv:: have {? @ident } := @term This tactic creates a new assumption of type the type of :token:`term`. If the diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 537a40c53c..4297e5a64b 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -1749,7 +1749,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) They combine the effects of the ``with``, ``as``, ``eqn:``, ``using``, and ``in`` clauses. -.. tacn:: case term +.. tacn:: case @term :name: case The tactic :n:`case` is a more basic tactic to perform case analysis without @@ -1982,7 +1982,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) :n:`induction @ident; induction @ident` (or :n:`induction @ident ; destruct @ident` depending on the exact needs). -.. tacv:: double induction num1 num2 +.. tacv:: double induction @num__1 @num__2 This tactic is deprecated and should be replaced by :n:`induction num1; induction num3` where :n:`num3` is the result @@ -2271,11 +2271,11 @@ and an explanation of the underlying technique. :undocumented: .. tacv:: injection @term {? with @bindings_list} as {+ @simple_intropattern} - injection @num as {+ simple_intropattern} - injection as {+ simple_intropattern} - einjection @term {? with @bindings_list} as {+ simple_intropattern} - einjection @num as {+ simple_intropattern} - einjection as {+ simple_intropattern} + injection @num as {+ @simple_intropattern} + injection as {+ @simple_intropattern} + einjection @term {? with @bindings_list} as {+ @simple_intropattern} + einjection @num as {+ @simple_intropattern} + einjection as {+ @simple_intropattern} These variants apply :n:`intros {+ @simple_intropattern}` after the call to :tacn:`injection` or :tacn:`einjection` so that all equalities generated are moved in @@ -2637,7 +2637,7 @@ and an explanation of the underlying technique. is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). -.. tacv:: fix @ident @num with {+ (ident {+ @binder} [{struct @ident}] : @type)} +.. tacv:: fix @ident @num with {+ (@ident {+ @binder} [{struct @ident}] : @type)} This starts a proof by mutual induction. The statements to be simultaneously proved are respectively :g:`forall binder ... binder, type`. @@ -4048,7 +4048,7 @@ Setting implicit automation tactics .. seealso:: :cmd:`Proof` in :ref:`proof-editing-mode`. - .. cmdv:: Proof with tactic using {+ @ident} + .. cmdv:: Proof with @tactic using {+ @ident} Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 4e4a10f590..26dc4e02cf 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -277,7 +277,7 @@ Requests to the environment :token:`term_pattern` (holes of the pattern are either denoted by `_` or by :n:`?@ident` when non linear patterns are expected). - .. cmdv:: Search { + [-]@term_pattern_string } + .. cmdv:: Search {+ {? -}@term_pattern_string} where :n:`@term_pattern_string` is a term_pattern, a string, or a string followed @@ -289,17 +289,17 @@ Requests to the environment prefixed by `-`, the search excludes the objects that mention that term_pattern or that string. - .. cmdv:: Search @term_pattern_string … @term_pattern_string inside {+ @qualid } + .. cmdv:: Search {+ {? -}@term_pattern_string} inside {+ @qualid } This restricts the search to constructions defined in the modules named by the given :n:`qualid` sequence. - .. cmdv:: Search @term_pattern_string … @term_pattern_string outside {+ @qualid } + .. cmdv:: Search {+ {? -}@term_pattern_string} outside {+ @qualid } This restricts the search to constructions not defined in the modules named by the given :n:`qualid` sequence. - .. cmdv:: @selector: Search [-]@term_pattern_string … [-]@term_pattern_string + .. cmdv:: @selector: Search {+ {? -}@term_pattern_string} This specifies the goal on which to search hypothesis (see Section :ref:`invocation-of-tactics`). @@ -353,7 +353,7 @@ Requests to the environment This restricts the search to constructions defined in the modules named by the given :n:`qualid` sequence. - .. cmdv:: SearchHead term outside {+ @qualid } + .. cmdv:: SearchHead @term outside {+ @qualid } This restricts the search to constructions not defined in the modules named by the given :n:`qualid` sequence. @@ -443,7 +443,7 @@ Requests to the environment SearchRewrite (_ + _ + _). - .. cmdv:: SearchRewrite term inside {+ @qualid } + .. cmdv:: SearchRewrite @term inside {+ @qualid } This restricts the search to constructions defined in the modules named by the given :n:`qualid` sequence. diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 418922e9b3..3a12ee288a 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -336,29 +336,32 @@ Generation of induction principles with ``Functional`` ``Scheme`` Generation of inversion principles with ``Derive`` ``Inversion`` ----------------------------------------------------------------- -.. cmd:: Derive Inversion @ident with forall (x : T), I t Sort sort +.. cmd:: Derive Inversion @ident with @ident Sort @sort + Derive Inversion @ident with (forall @binders, @ident @term) Sort @sort This command generates an inversion principle for the - :tacn:`inversion ... using ...` tactic. Let :g:`I` be an inductive - predicate and :g:`x` the variables occurring in t. This command - generates and stocks the inversion lemma for the sort :g:`sort` - corresponding to the instance :g:`∀ (x:T), I t` with the name - :n:`@ident` in the global environment. When applied, it is - equivalent to having inverted the instance with the tactic - :g:`inversion`. - + :tacn:`inversion ... using ...` tactic. The first :token:`ident` is the name + of the generated principle. The second :token:`ident` should be an inductive + predicate, and :token:`binders` the variables occurring in the term + :token:`term`. This command generates the inversion lemma for the sort + :token:`sort` corresponding to the instance :n:`forall @binders, @ident @term`. + When applied, it is equivalent to having inverted the instance with the + tactic :g:`inversion`. -.. cmdv:: Derive Inversion_clear @ident with forall (x:T), I t Sort @sort +.. cmdv:: Derive Inversion_clear @ident with @ident Sort @sort + Derive Inversion_clear @ident with (forall @binders, @ident @term) Sort @sort When applied, it is equivalent to having inverted the instance with the tactic inversion replaced by the tactic `inversion_clear`. -.. cmdv:: Derive Dependent Inversion @ident with forall (x:T), I t Sort @sort +.. cmdv:: Derive Dependent Inversion @ident with @ident Sort @sort + Derive Dependent Inversion @ident with (forall @binders, @ident @term) Sort @sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion`. -.. cmdv:: Derive Dependent Inversion_clear @ident with forall(x:T), I t Sort @sort +.. cmdv:: Derive Dependent Inversion_clear @ident with @ident Sort @sort + Derive Dependent Inversion_clear @ident with (forall @binders, @ident @term) Sort @sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion_clear`. -- cgit v1.2.3 From b381e8d1c601659ce1a864cc51edece23b1a7fd2 Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Thu, 16 May 2019 10:59:17 -0400 Subject: [refman] Fix up the documentation of Instance and Existing Instance --- doc/sphinx/addendum/type-classes.rst | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index f0c9ba5735..ee417f269d 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -311,23 +311,23 @@ Summary of the commands This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {? @binders} : @class t1 … tn {? | priority} := { field1 := b1 ; …; fieldi := bi } +.. cmd:: Instance @ident {? @binders} : @term__0 {+ @term} {? | @num} := { {*; @field_def} } This command is used to declare a typeclass instance named - :token:`ident` of the class :token:`class` with parameters ``t1`` to ``tn`` and - fields ``b1`` to ``bi``, where each field must be a declared field of + :token:`ident` of the class :n:`@term__0` with parameters :token:`term` and + fields defined by :token:`field_def`, where each field must be a declared field of the class. Missing fields must be filled in interactive proof mode. An arbitrary context of :token:`binders` can be put after the name of the instance and before the colon to declare a parameterized instance. An optional priority can be declared, 0 being the highest priority as for - :tacn:`auto` hints. If the priority is not specified, it defaults to the number + :tacn:`auto` hints. If the priority :token:`num` is not specified, it defaults to the number of non-dependent binders of the instance. - .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class {+ @term} {? | @priority } := @term + .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @term__0 {+ @term} {? | @num } := @term This syntax is used for declaration of singleton class instances or - for directly giving an explicit term of type :n:`forall @binders, @class + for directly giving an explicit term of type :n:`forall @binders, @term__0 {+ @term}`. One need not even mention the unique field name for singleton classes. @@ -356,11 +356,11 @@ Summary of the commands Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a few other commands related to typeclasses. -.. cmd:: Existing Instance {+ @ident} {? | @priority} +.. cmd:: Existing Instance {+ @ident} {? | @num} This command adds an arbitrary list of constants whose type ends with an applied typeclass to the instance database with an optional - priority. It can be used for redeclaring instances at the end of + priority :token:`num`. It can be used for redeclaring instances at the end of sections, or declaring structure projections as instances. This is equivalent to ``Hint Resolve ident : typeclass_instances``, except it registers instances for :cmd:`Print Instances`. -- cgit v1.2.3 From 2a4bd4861d0ebf0b5d5a63774ac964b431e94fbb Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Thu, 16 May 2019 10:59:33 -0400 Subject: [refman] Add a .. cmd:: header for Reserved Notation and Reserved Infix Co-Authored-By: Théo Zimmermann --- doc/sphinx/user-extensions/syntax-extensions.rst | 31 +++++++++++++++--------- 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index edec13f681..cda228a7da 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -327,22 +327,29 @@ symbols. Reserving notations ~~~~~~~~~~~~~~~~~~~ -A given notation may be used in different contexts. Coq expects all -uses of the notation to be defined at the same precedence and with the -same associativity. To avoid giving the precedence and associativity -every time, it is possible to declare a parsing rule in advance -without giving its interpretation. Here is an example from the initial -state of Coq. +.. cmd:: Reserved Notation @string {? (@modifiers) } -.. coqtop:: in + A given notation may be used in different contexts. Coq expects all + uses of the notation to be defined at the same precedence and with the + same associativity. To avoid giving the precedence and associativity + every time, this command declares a parsing rule (:token:`string`) in advance + without giving its interpretation. Here is an example from the initial + state of Coq. + + .. coqtop:: in + + Reserved Notation "x = y" (at level 70, no associativity). + + Reserving a notation is also useful for simultaneously defining an + inductive type or a recursive constant and a notation for it. - Reserved Notation "x = y" (at level 70, no associativity). + .. note:: The notations mentioned in the module :ref:`init-notations` are reserved. Hence + their precedence and associativity cannot be changed. -Reserving a notation is also useful for simultaneously defining an -inductive type or a recursive constant and a notation for it. + .. cmdv:: Reserved Infix "@symbol" {* @modifiers} -.. note:: The notations mentioned in the module :ref:`init-notations` are reserved. Hence - their precedence and associativity cannot be changed. + This command declares an infix parsing rule without giving its + interpretation. Simultaneous definition of terms and notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- cgit v1.2.3 From 4a69c594b484cb7e9af28b8ba9608a228e2376f1 Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Thu, 16 May 2019 11:00:05 -0400 Subject: [refman] Fix up the grammar entry for field_def --- doc/sphinx/language/gallina-extensions.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 96e74bf118..5e214f6f7f 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -85,7 +85,7 @@ To build an object of type :token:`ident`, one should provide the constructor .. productionlist:: record_term : {| [`field_def` ; … ; `field_def`] |} - field_def : name [binders] := `record_term` + field_def : `ident` [`binders`] := `term` Alternatively, the following syntax allows creating objects by using named fields, as shown in this grammar. The fields do not have to be in any particular order, nor do they have -- cgit v1.2.3 From 8aeaf2d184f95037021a644cf03e7ae340d8c790 Mon Sep 17 00:00:00 2001 From: Clément Pit-Claudel Date: Thu, 16 May 2019 11:00:19 -0400 Subject: [refman] Document etransitivity --- doc/sphinx/proof-engine/tactics.rst | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 4297e5a64b..4e47621938 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -4400,6 +4400,11 @@ Equality This tactic applies to a goal that has the form :g:`t=u` and transforms it into the two subgoals :n:`t=@term` and :n:`@term=u`. + .. tacv:: etransitivity + + This tactic behaves like :tacn:`transitivity`, using a fresh evar instead of + a concrete :token:`term`. + Equality and inductive sets --------------------------- -- cgit v1.2.3 From a6757b089e1d268517bcba48a9fe33aa47526de2 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Jan 2019 00:06:32 +0100 Subject: Remove Refine Instance Mode option --- .../07-commands-and-options/09530-rm-unknown.rst | 6 ++++++ doc/sphinx/addendum/type-classes.rst | 15 +-------------- doc/sphinx/changes.rst | 7 +++---- plugins/ltac/rewrite.ml | 2 +- test-suite/success/Typeclasses.v | 4 +--- theories/Compat/Coq89.v | 1 - vernac/classes.ml | 18 ++++-------------- vernac/classes.mli | 1 - 8 files changed, 16 insertions(+), 38 deletions(-) create mode 100644 doc/changelog/07-commands-and-options/09530-rm-unknown.rst diff --git a/doc/changelog/07-commands-and-options/09530-rm-unknown.rst b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst new file mode 100644 index 0000000000..78874cadb1 --- /dev/null +++ b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst @@ -0,0 +1,6 @@ +- Deprecated flag `Refine Instance Mode` has been removed. + (`#09530 `_, fixes + `#3632 `_, `#3890 + `_ and `#4638 + `_ + by Maxime Dénès, review by Gaëtan Gilbert). diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index ee417f269d..65934efaa6 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -316,7 +316,7 @@ Summary of the commands This command is used to declare a typeclass instance named :token:`ident` of the class :n:`@term__0` with parameters :token:`term` and fields defined by :token:`field_def`, where each field must be a declared field of - the class. Missing fields must be filled in interactive proof mode. + the class. An arbitrary context of :token:`binders` can be put after the name of the instance and before the colon to declare a parameterized instance. An @@ -563,19 +563,6 @@ Settings of goals. Setting this option to 1 or 2 turns on :flag:`Typeclasses Debug`; setting this option to 0 turns that option off. -.. flag:: Refine Instance Mode - - .. deprecated:: 8.10 - - This flag allows to switch the behavior of instance declarations made through - the Instance command. - - + When it is off (the default), they fail with an error instead. - - + When it is on, instances that have unsolved holes in - their proof-term silently open the proof mode with the remaining - obligations to prove. - Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 5e337bcef0..cc2c43e7dd 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -486,10 +486,9 @@ Other changes in 8.10+beta1 - :cmd:`Declare Instance` now requires an instance name. - The flag :flag:`Refine Instance Mode` has been turned off by default, - meaning that :cmd:`Instance` no longer opens a proof when a body is - provided. The flag has been deprecated and will be removed in the next - version. + The flag `Refine Instance Mode` has been turned off by default, meaning that + :cmd:`Instance` no longer opens a proof when a body is provided. The flag + has been deprecated and will be removed in the next version. (`#9270 `_, and `#9825 `_, diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index a68efa4713..963b7189f9 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1800,7 +1800,7 @@ let anew_instance ~pstate atts binders instance fields = let program_mode = atts.program in new_instance ~pstate ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) - ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info + ~global:atts.global ~generalize:false Hints.empty_hint_info let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 3888cafed3..736d05fefc 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -198,9 +198,7 @@ Module UniqueInstances. for it. *) Set Typeclasses Unique Instances. Class Eq (A : Type) : Set. - Set Refine Instance Mode. - Instance eqa : Eq nat := _. constructor. Qed. - Unset Refine Instance Mode. + Instance eqa : Eq nat. Qed. Instance eqb : Eq nat := {}. Class Foo (A : Type) (e : Eq A) : Set. Instance fooa : Foo _ eqa := {}. diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index 05d63d9a47..49e0af9b2c 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -14,4 +14,3 @@ Local Set Warnings "-deprecated". Require Export Coq.Compat.Coq810. Unset Private Polymorphic Universes. -Set Refine Instance Mode. diff --git a/vernac/classes.ml b/vernac/classes.ml index ece9fc8937..05a75ab435 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -31,16 +31,6 @@ module NamedDecl = Context.Named.Declaration open Decl_kinds open Entries -let refine_instance = ref false - -let () = Goptions.(declare_bool_option { - optdepr = true; - optname = "definition of instances by refining"; - optkey = ["Refine";"Instance";"Mode"]; - optread = (fun () -> !refine_instance); - optwrite = (fun b -> refine_instance := b) -}) - let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) @@ -419,7 +409,7 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po | None -> pstate) ()) -let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -503,7 +493,7 @@ let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program let term = to_constr sigma (Option.get term) in (declare_instance_constant k pri global imps ?hook id decl poly sigma term termtype; None) - else if program_mode || refine || Option.is_empty props then + else if program_mode || Option.is_empty props then declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in id, pstate @@ -550,7 +540,7 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mode +let new_instance ~pstate ?(global=false) ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -566,7 +556,7 @@ let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mo Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode + do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) pri = diff --git a/vernac/classes.mli b/vernac/classes.mli index e7f90ff306..57bb9ce312 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -48,7 +48,6 @@ val declare_instance_constant : val new_instance : pstate:Proof_global.t option -> ?global:bool (** Not global by default. *) -> - ?refine:bool (** Allow refinement *) -> program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> -- cgit v1.2.3 From c352873936db93c251c544383853474736f128d6 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Jan 2019 00:48:36 +0100 Subject: Remove VtUnknown classification This clean-up removes the dependency of the current proof mode (and hence the parsing state) on unification. The current proof mode can now be known simply by parsing and elaborating attributes. We give access to attributes from the classifier for this purpose. We remove the infamous `VtUnknown` code path in the STM which is known to be buggy. Fixes #3632 #3890 #4638. --- plugins/ltac/g_rewrite.mlg | 2 +- stm/stm.ml | 51 +-------------------------------------- stm/vernac_classifier.ml | 36 +++++++++++++++------------ test-suite/bugs/closed/bug_3890.v | 12 +++++++++ test-suite/bugs/closed/bug_4580.v | 1 - test-suite/bugs/closed/bug_4638.v | 12 +++++++++ test-suite/bugs/opened/bug_3890.v | 22 ----------------- vernac/vernacextend.ml | 1 - vernac/vernacextend.mli | 1 - 9 files changed, 47 insertions(+), 91 deletions(-) create mode 100644 test-suite/bugs/closed/bug_3890.v create mode 100644 test-suite/bugs/closed/bug_4638.v delete mode 100644 test-suite/bugs/opened/bug_3890.v diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 469551809c..12b12bc7b0 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -278,7 +278,7 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF } | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) - => { VtUnknown, VtNow } + => { (if Lib.is_modtype() then VtSideff([n]) else VtStartProof(GuaranteesOpacity, [n])), VtLater } -> { add_morphism_infer atts m n } diff --git a/stm/stm.ml b/stm/stm.ml index 21618bc044..6f7cefb582 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -364,7 +364,6 @@ module VCS : sig val set_parsing_state : id -> Vernacstate.Parser.state -> unit val get_parsing_state : id -> Vernacstate.Parser.state option val get_proof_mode : id -> Pvernac.proof_mode option - val set_proof_mode : id -> Pvernac.proof_mode option -> unit (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs @@ -572,6 +571,7 @@ end = struct (* {{{ *) (match Vernacprop.under_control x with | VernacDefinition (_,({CAst.v=Name i},_),_) -> Id.to_string i | VernacStartTheoremProof (_,[({CAst.v=i},_),_]) -> Id.to_string i + | VernacInstance (_,(({CAst.v=Name i},_),_,_),_,_) -> Id.to_string i | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind @@ -611,7 +611,6 @@ end = struct (* {{{ *) info.state <- new_state let get_proof_mode id = (get_info id).proof_mode - let set_proof_mode id pm = (get_info id).proof_mode <- pm let reached id = let info = get_info id in @@ -3050,53 +3049,6 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.set_parsing_state id parsing_state) new_ids; `Ok - (* Unknown: we execute it, check for open goals and propagate sideeff *) - | VtUnknown, VtNow -> - let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in - if not (get_allow_nested_proofs ()) && in_proof then - "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." - |> Pp.str - |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy newtip - |> Exninfo.iraise - else - let id = VCS.new_node ~id:newtip proof_mode () in - let head_id = VCS.get_branch_pos head in - let _st : unit = Reach.known_state ~doc ~cache:true head_id in (* ensure it is ok *) - let step () = - VCS.checkout VCS.Branch.master; - let mid = VCS.get_branch_pos VCS.Branch.master in - let _st' : unit = Reach.known_state ~doc ~cache:(VCS.is_interactive ()) mid in - let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_vernac_interp id st x); - (* Vernac x may or may not start a proof *) - if not in_proof && PG_compat.there_are_pending_proofs () then - begin - let bname = VCS.mk_branch_name x in - let opacity_of_produced_term = function - (* This AST is ambiguous, hence we check it dynamically *) - | VernacInstance (_,_ , None, _) -> GuaranteesOpacity - | _ -> Doesn'tGuaranteeOpacity in - VCS.commit id (Fork (x,bname,opacity_of_produced_term (Vernacprop.under_control x.expr),[])); - VCS.set_proof_mode id (Some (Vernacentries.get_default_proof_mode ())); - VCS.branch bname (`Proof (VCS.proof_nesting () + 1)); - end else begin - begin match (VCS.get_branch head).VCS.kind with - | `Edit _ -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); - | `Master -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); - | `Proof _ -> - VCS.commit id (mkTransCmd x [] in_proof `MainQueue); - (* We hope it can be replayed, but we can't really know *) - ignore(VCS.propagate_sideff ~action:(ReplayCommand x)); - end; - VCS.checkout_shallowest_proof_branch (); - end in - State.define ~doc ~safe_id:head_id ~cache:true step id; - Backtrack.record (); `Ok - - | VtUnknown, VtLater -> - anomaly(str"classifier: VtUnknown must imply VtNow.") - | VtProofMode pm, VtNow -> let proof_mode = Pvernac.lookup_proof_mode pm in let id = VCS.new_node ~id:newtip proof_mode () in @@ -3106,7 +3058,6 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtProofMode _, VtLater -> anomaly(str"classifier: VtProofMode must imply VtNow.") - end in let pr_rc rc = match rc with | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 4a4c5c94e9..7cecd801e4 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -21,7 +21,6 @@ let string_of_parallel = function | `No -> "" let string_of_vernac_type = function - | VtUnknown -> "Unknown" | VtStartProof _ -> "StartProof" | VtSideff _ -> "Sideff" | VtQed (VtKeep VtKeepAxiom) -> "Qed(admitted)" @@ -61,7 +60,7 @@ let options_affecting_stm_scheduling = ] let classify_vernac e = - let static_classifier ~poly e = match e with + let static_classifier ~atts e = match e with (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) @@ -97,15 +96,18 @@ let classify_vernac e = VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater | VernacDefinition (_,({v=i},_),ProveBody _) -> - let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof(guarantee, idents_of_name i), VtLater + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in + let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof(guarantee, idents_of_name i), VtLater | VernacStartTheoremProof (_,l) -> - let ids = List.map (fun (({v=i}, _), _) -> i) l in - let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof (guarantee,ids), VtLater + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in + let ids = List.map (fun (({v=i}, _), _) -> i) l in + let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof (guarantee,ids), VtLater | VernacFixpoint (discharge,l) -> + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = - if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity + if discharge = Decl_kinds.DoDischarge || polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in let ids, open_proof = @@ -115,8 +117,9 @@ let classify_vernac e = then VtStartProof (guarantee,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (discharge,l) -> + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = - if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity + if discharge = Decl_kinds.DoDischarge || polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in let ids, open_proof = @@ -185,8 +188,12 @@ let classify_vernac e = | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) -> VtSideff [], VtNow | VernacProofMode pm -> VtProofMode pm, VtNow - (* These are ambiguous *) - | VernacInstance _ -> VtUnknown, VtNow + | VernacInstance (_,((name,_),_,_),None,_) when not (Attributes.parse_drop_extra Attributes.program atts) -> + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in + let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof (guarantee, idents_of_name name.CAst.v), VtLater + | VernacInstance (_,((name,_),_,_),_,_) -> + VtSideff (idents_of_name name.CAst.v), VtLater (* Stm will install a new classifier to handle these *) | VernacBack _ | VernacAbortAll | VernacUndoTo _ | VernacUndo _ @@ -201,9 +208,8 @@ let classify_vernac e = with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier v = v |> CAst.with_val (function - | VernacExpr (f, e) -> - let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in - static_classifier ~poly e + | VernacExpr (atts, e) -> + static_classifier ~atts e | VernacTimeout (_,e) -> static_control_classifier e | VernacTime (_,e) | VernacRedirect (_, e) -> static_control_classifier e @@ -214,6 +220,6 @@ let classify_vernac e = | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtLater - | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater)) + | (VtStartProof _ | VtProofMode _), _ -> VtQuery, VtLater)) in static_control_classifier e diff --git a/test-suite/bugs/closed/bug_3890.v b/test-suite/bugs/closed/bug_3890.v new file mode 100644 index 0000000000..e1823ac54c --- /dev/null +++ b/test-suite/bugs/closed/bug_3890.v @@ -0,0 +1,12 @@ +Set Nested Proofs Allowed. + +Class Foo. +Class Bar := b : Type. + +Instance foo : Foo. + +Instance bar : Bar. +exact Type. +Defined. + +Defined. diff --git a/test-suite/bugs/closed/bug_4580.v b/test-suite/bugs/closed/bug_4580.v index a8a446cc9b..3f40569d61 100644 --- a/test-suite/bugs/closed/bug_4580.v +++ b/test-suite/bugs/closed/bug_4580.v @@ -2,6 +2,5 @@ Require Import Program. Class Foo (A : Type) := foo : A. -Unset Refine Instance Mode. Program Instance f1 : Foo nat := S _. Next Obligation. exact 0. Defined. diff --git a/test-suite/bugs/closed/bug_4638.v b/test-suite/bugs/closed/bug_4638.v new file mode 100644 index 0000000000..951fe5302b --- /dev/null +++ b/test-suite/bugs/closed/bug_4638.v @@ -0,0 +1,12 @@ +Set Nested Proofs Allowed. + +Class Foo. + +Goal True. + +Instance foo: Foo. +Qed. + +trivial. + +Qed. diff --git a/test-suite/bugs/opened/bug_3890.v b/test-suite/bugs/opened/bug_3890.v deleted file mode 100644 index 9d83743b2a..0000000000 --- a/test-suite/bugs/opened/bug_3890.v +++ /dev/null @@ -1,22 +0,0 @@ -Set Nested Proofs Allowed. - -Class Foo. -Class Bar := b : Type. - -Set Refine Instance Mode. -Instance foo : Foo := _. -Unset Refine Instance Mode. -(* 1 subgoals, subgoal 1 (ID 4) - - ============================ - Foo *) - -Instance bar : Bar. -exact Type. -Defined. -(* bar is defined *) - -About foo. -(* foo not a defined object. *) - -Fail Defined. diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index ef06e59316..730f5fd6da 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -36,7 +36,6 @@ type vernac_type = | VtProofMode of string (* To be removed *) | VtMeta - | VtUnknown and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 4d89eaffd9..54e08d0e95 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -52,7 +52,6 @@ type vernac_type = | VtProofMode of string (* To be removed *) | VtMeta - | VtUnknown and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = -- cgit v1.2.3 From 27468ae02bbbf018743d53a9db49efa34b6d6a3e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 16 May 2019 00:02:54 +0200 Subject: Ensure statically that declarations built by Term_typing are direct. This removes a lot of cruft breaking the opaque proof abstraction in Safe_typing and similar. --- interp/declare.ml | 3 +- kernel/cooking.ml | 4 +- kernel/cooking.mli | 6 +- kernel/opaqueproof.ml | 4 ++ kernel/opaqueproof.mli | 1 + kernel/safe_typing.ml | 146 ++++++++++++++++++++++--------------------------- kernel/safe_typing.mli | 4 +- kernel/term_typing.ml | 44 ++++++++------- kernel/term_typing.mli | 8 ++- library/global.ml | 1 + library/global.mli | 1 + 11 files changed, 109 insertions(+), 113 deletions(-) diff --git a/interp/declare.ml b/interp/declare.ml index 29da49f29d..7ee7ecb5e8 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -78,8 +78,7 @@ let cache_constant ((sp,kn), obj) = then Constant.make1 kn else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") | Some r -> - let kn, _ = Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) in - kn + Global.add_recipe ~in_section:(Lib.sections_are_opened ()) id r in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); diff --git a/kernel/cooking.ml b/kernel/cooking.ml index d879f4ee95..9b6e37251f 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -155,8 +155,8 @@ let abstract_constant_body c (hyps, subst) = type recipe = { from : Opaqueproof.opaque constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = { - cook_body : (constr Mod_subst.substituted, Opaqueproof.opaque) constant_def; +type 'opaque result = { + cook_body : (constr Mod_subst.substituted, 'opaque) constant_def; cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; diff --git a/kernel/cooking.mli b/kernel/cooking.mli index ffd4e51ffc..b022e2ac09 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -17,8 +17,8 @@ type recipe = { from : Opaqueproof.opaque constant_body; info : Opaqueproof.cook type inline = bool -type result = { - cook_body : (constr Mod_subst.substituted, Opaqueproof.opaque) constant_def; +type 'opaque result = { + cook_body : (constr Mod_subst.substituted, 'opaque) constant_def; cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; @@ -27,7 +27,7 @@ type result = { cook_context : Constr.named_context option; } -val cook_constant : hcons:bool -> recipe -> result +val cook_constant : hcons:bool -> recipe -> Opaqueproof.opaque result val cook_constr : Opaqueproof.cooking_info -> constr -> constr (** {6 Utility functions used in module [Discharge]. } *) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 57059300b8..423a416ca4 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -100,6 +100,10 @@ let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function let fp = snd (Int.Map.find i prfs) in join except fp +let force_direct = function +| Direct (_, cu) -> Future.force cu +| Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") + let force_proof { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> fst(Future.force cu) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index d47c0bbb3c..8b6e8a1c8f 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -39,6 +39,7 @@ val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab indirect opaque accessor configured below. *) val force_proof : opaquetab -> opaque -> constr val force_constraints : opaquetab -> opaque -> Univ.ContextSet.t +val force_direct : opaque -> (constr * Univ.ContextSet.t) val get_constraints : opaquetab -> opaque -> Univ.ContextSet.t Future.computation option diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 36f1515a8c..a5d8a480ee 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -228,27 +228,10 @@ let check_engagement env expected_impredicative_set = (** {6 Stm machinery } *) -type seff_env = - [ `Nothing - (* The proof term and its universes. - Same as the constant_body's but not in an ephemeron *) - | `Opaque of Constr.t * Univ.ContextSet.t ] - -let get_opaque_body env cbo = - match cbo.const_body with - | Undef _ -> assert false - | Primitive _ -> assert false - | Def _ -> `Nothing - | OpaqueDef opaque -> - `Opaque - (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, - Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) - type side_effect = { from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; - seff_body : Opaqueproof.opaque Declarations.constant_body; - seff_env : seff_env; + seff_body : (Constr.t * Univ.ContextSet.t) Declarations.constant_body; seff_role : Entries.side_effect_role; } @@ -288,39 +271,38 @@ type private_constants = SideEffects.t let side_effects_of_private_constants l = List.rev (SideEffects.repr l) +(* Only used to push in an Environ.env. *) +let lift_constant c = + let body = match c.const_body with + | OpaqueDef _ -> Undef None + | Def _ | Undef _ | Primitive _ as body -> body + in + { c with const_body = body } + +let map_constant f c = + let body = match c.const_body with + | OpaqueDef o -> OpaqueDef (f o) + | Def _ | Undef _ | Primitive _ as body -> body + in + { c with const_body = body } + let push_private_constants env eff = let eff = side_effects_of_private_constants eff in let add_if_undefined env eff = try ignore(Environ.lookup_constant eff.seff_constant env); env - with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env + with Not_found -> Environ.add_constant eff.seff_constant (lift_constant eff.seff_body) env in List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty let concat_private = SideEffects.concat -let private_constant env role cst = - (** The constant must be the last entry of the safe environment *) - let () = match env.revstruct with - | (lbl, SFBconst _) :: _ -> assert (Label.equal lbl (Constant.label cst)) - | _ -> assert false - in - let from_env = CEphemeron.create env.revstruct in - let cbo = Environ.lookup_constant cst env.env in - let eff = { - from_env = from_env; - seff_constant = cst; - seff_body = cbo; - seff_env = get_opaque_body env.env cbo; - seff_role = role; - } in - SideEffects.add eff empty_private_constants - let universes_of_private eff = let fold acc eff = - let acc = match eff.seff_env with - | `Nothing -> acc - | `Opaque (_, ctx) -> ctx :: acc + let acc = match eff.seff_body.const_body with + | Def _ -> acc + | OpaqueDef (_, ctx) -> ctx :: acc + | Primitive _ | Undef _ -> assert false in match eff.seff_body.const_universes with | Monomorphic ctx -> ctx :: acc @@ -565,7 +547,6 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration - | GlobalRecipe of Cooking.recipe type exported_private_constant = Constant.t * Entries.side_effect_role @@ -598,7 +579,7 @@ let inline_side_effects env body side_eff = let open Constr in (** First step: remove the constants that are still in the environment *) let filter e = - let cb = (e.seff_constant, e.seff_body, e.seff_env) in + let cb = (e.seff_constant, e.seff_body) in try ignore (Environ.lookup_constant e.seff_constant env); None with Not_found -> Some (cb, e.from_env) in @@ -612,10 +593,10 @@ let inline_side_effects env body side_eff = else (** Second step: compute the lifts and substitutions to apply *) let cname c r = Context.make_annot (Name (Label.to_id (Constant.label c))) r in - let fold (subst, var, ctx, args) (c, cb, b) = - let (b, opaque) = match cb.const_body, b with - | Def b, _ -> (Mod_subst.force_constr b, false) - | OpaqueDef _, `Opaque (b,_) -> (b, true) + let fold (subst, var, ctx, args) (c, cb) = + let (b, opaque) = match cb.const_body with + | Def b -> (Mod_subst.force_constr b, false) + | OpaqueDef (b, _) -> (b, true) | _ -> assert false in match cb.const_universes with @@ -701,7 +682,8 @@ let check_signatures curmb sl = | Some (n, _) -> n -let constant_entry_of_side_effect cb u = +let constant_entry_of_side_effect eff = + let cb = eff.seff_body in let open Entries in let univs = match cb.const_universes with @@ -711,9 +693,9 @@ let constant_entry_of_side_effect cb u = Polymorphic_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) in let pt = - match cb.const_body, u with - | OpaqueDef _, `Opaque (b, c) -> b, c - | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty + match cb.const_body with + | OpaqueDef (b, c) -> b, c + | Def b -> Mod_subst.force_constr b, Univ.ContextSet.empty | _ -> assert false in DefinitionEntry { const_entry_body = Future.from_val (pt, ()); @@ -724,18 +706,6 @@ let constant_entry_of_side_effect cb u = const_entry_opaque = Declareops.is_opaque cb; const_entry_inline_code = cb.const_inline_code } -let turn_direct orig = - let cb = orig.seff_body in - if Declareops.is_opaque cb then - let p = match orig.seff_env with - | `Opaque (b, c) -> (b, c) - | _ -> assert false - in - let const_body = OpaqueDef (Opaqueproof.create (Future.from_val p)) in - let cb = { cb with const_body } in - { orig with seff_body = cb } - else orig - let export_eff eff = (eff.seff_constant, eff.seff_body, eff.seff_role) @@ -756,13 +726,14 @@ let export_side_effects mb env c = let trusted = check_signatures mb signatures in let push_seff env eff = let { seff_constant = kn; seff_body = cb ; _ } = eff in - let env = Environ.add_constant kn cb env in + let env = Environ.add_constant kn (lift_constant cb) env in match cb.const_universes with | Polymorphic _ -> env | Monomorphic ctx -> - let ctx = match eff.seff_env with - | `Nothing -> ctx - | `Opaque(_, ctx') -> Univ.ContextSet.union ctx' ctx + let ctx = match eff.seff_body.const_body with + | Def _ -> ctx + | OpaqueDef (_, ctx') -> Univ.ContextSet.union ctx' ctx + | Undef _ | Primitive _ -> assert false in Environ.push_context_set ~strict:true ctx env in @@ -771,35 +742,39 @@ let export_side_effects mb env c = | [] -> List.rev acc, ce | eff :: rest -> if Int.equal sl 0 then - let env, cb = - let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in - let ce = constant_entry_of_side_effect ocb u in + let env, cb = + let kn = eff.seff_constant in + let ce = constant_entry_of_side_effect eff in let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in - let eff = { eff with - seff_body = cb; - seff_env = `Nothing; - } in + let cb = map_constant Future.force cb in + let eff = { eff with seff_body = cb } in (push_seff env eff, export_eff eff) in translate_seff 0 rest (cb :: acc) env else - let cb = turn_direct eff in - let env = push_seff env cb in - let ecb = export_eff cb in + let env = push_seff env eff in + let ecb = export_eff eff in translate_seff (sl - 1) rest (ecb :: acc) env in translate_seff trusted seff [] env let export_private_constants ~in_section ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in - let bodies = List.map (fun (kn, cb, _) -> (kn, cb)) exported in + let map (kn, cb, _) = (kn, map_constant (fun p -> Opaqueproof.create (Future.from_val p)) cb) in + let bodies = List.map map exported in let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv +let add_recipe ~in_section l r senv = + let kn = Constant.make2 senv.modpath l in + let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in + let cb = if in_section then cb else Declareops.hcons_const_body cb in + let senv = add_constant_aux ~in_section senv (kn, cb) in + kn, senv + let add_constant ?role ~in_section l decl senv = let kn = Constant.make2 senv.modpath l in - let senv = let cb = match decl with | ConstantEntry (EffectEntry, ce) -> @@ -811,9 +786,9 @@ let add_constant ?role ~in_section l decl senv = Term_typing.translate_constant (Term_typing.SideEffects handle) senv.env kn ce | ConstantEntry (PureEntry, ce) -> Term_typing.translate_constant Term_typing.Pure senv.env kn ce - | GlobalRecipe r -> - let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in - if in_section then cb else Declareops.hcons_const_body cb in + in + let senv = + let cb = map_constant Opaqueproof.create cb in add_constant_aux ~in_section senv (kn, cb) in let senv = match decl with @@ -824,7 +799,16 @@ let add_constant ?role ~in_section l decl senv = in let eff = match role with | None -> empty_private_constants - | Some role -> private_constant senv role kn + | Some role -> + let cb = map_constant Future.force cb in + let from_env = CEphemeron.create senv.revstruct in + let eff = { + from_env = from_env; + seff_constant = kn; + seff_body = cb; + seff_role = role; + } in + SideEffects.add eff empty_private_constants in (kn, eff), senv diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index b9a68663d3..36ca3d8c47 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -88,7 +88,6 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration - | GlobalRecipe of Cooking.recipe type exported_private_constant = Constant.t * Entries.side_effect_role @@ -103,6 +102,9 @@ val add_constant : ?role:Entries.side_effect_role -> in_section:bool -> Label.t -> global_declaration -> (Constant.t * private_constants) safe_transformer +val add_recipe : + in_section:bool -> Label.t -> Cooking.recipe -> Constant.t safe_transformer + (** Adding an inductive type *) val add_mind : diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index faa4411e92..9e33b431fc 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -154,7 +154,7 @@ the polymorphic case let c = Constr.hcons j.uj_val in feedback_completion_typecheck feedback_id; c, uctx) in - let def = OpaqueDef (Opaqueproof.create proofterm) in + let def = OpaqueDef proofterm in { Cooking.cook_body = def; cook_type = tyj.utj_val; @@ -207,7 +207,7 @@ the polymorphic case in let def = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in let def = - if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty))) + if opaque then OpaqueDef (Future.from_val (def, Univ.ContextSet.empty)) else Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; @@ -232,7 +232,7 @@ let record_aux env s_ty s_bo = (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" v -let build_constant_declaration _kn env result = +let build_constant_declaration ~force ~iter env result = let open Cooking in let typ = result.cook_type in let check declared inferred = @@ -271,11 +271,8 @@ let build_constant_declaration _kn env result = | Undef _ | Primitive _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> - let vars = - global_vars_set env - (Opaqueproof.force_proof (opaque_tables env) lc) in - (* we force so that cst are added to the env immediately after *) - ignore(Opaqueproof.force_constraints (opaque_tables env) lc); + let (lc, _) = force lc in + let vars = global_vars_set env lc in if !Flags.record_aux_file then record_aux env ids_typ vars; vars in @@ -296,11 +293,14 @@ let build_constant_declaration _kn env result = check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) - OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env c in - let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in - check declared inferred) lc) in + let kont c = + let ids_typ = global_vars_set env typ in + let ids_def = global_vars_set env c in + let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in + check declared inferred + in + OpaqueDef (iter kont lc) + in let univs = result.cook_universes in let tps = let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in @@ -318,8 +318,10 @@ let build_constant_declaration _kn env result = (*s Global and local constant declaration. *) -let translate_constant mb env kn ce = - build_constant_declaration kn env +let translate_constant mb env _kn ce = + let force cu = Future.force cu in + let iter k cu = Future.chain cu (fun (c, _ as p) -> k c; p) in + build_constant_declaration ~force ~iter env (infer_declaration ~trust:mb env ce) let translate_local_assum env t = @@ -327,8 +329,10 @@ let translate_local_assum env t = let t = Typeops.assumption_of_judgment env j in j.uj_val, t -let translate_recipe ~hcons env kn r = - build_constant_declaration kn env (Cooking.cook_constant ~hcons r) +let translate_recipe ~hcons env _kn r = + let force o = Opaqueproof.force_direct o in + let iter k o = Opaqueproof.iter_direct_opaque k o in + build_constant_declaration ~force ~iter env (Cooking.cook_constant ~hcons r) let translate_local_def env _id centry = let open Cooking in @@ -351,8 +355,7 @@ let translate_local_def env _id centry = | Def _ -> () | OpaqueDef lc -> let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env - (Opaqueproof.force_proof (opaque_tables env) lc) in + let ids_def = global_vars_set env (fst (Future.force lc)) in record_aux env ids_typ ids_def end; let () = match decl.cook_universes with @@ -362,8 +365,7 @@ let translate_local_def env _id centry = let c = match decl.cook_body with | Def c -> Mod_subst.force_constr c | OpaqueDef o -> - let p = Opaqueproof.force_proof (Environ.opaque_tables env) o in - let cst = Opaqueproof.force_constraints (Environ.opaque_tables env) o in + let (p, cst) = Future.force o in (** Let definitions are ensured to have no extra constraints coming from the body by virtue of the typing of [Entries.section_def_entry]. *) let () = assert (Univ.ContextSet.is_empty cst) in diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 01b69b2b66..a046d26ea9 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -33,14 +33,16 @@ val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> - Opaqueproof.opaque constant_body + Opaqueproof.proofterm constant_body val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body (** Internal functions, mentioned here for debug purpose only *) val infer_declaration : trust:'a trust -> env -> - 'a constant_entry -> Cooking.result + 'a constant_entry -> Opaqueproof.proofterm Cooking.result val build_constant_declaration : - Constant.t -> env -> Cooking.result -> Opaqueproof.opaque constant_body + force:('a -> constr * 'b) -> + iter:((constr -> unit) -> 'a -> 'a) -> + env -> 'a Cooking.result -> 'a constant_body diff --git a/library/global.ml b/library/global.ml index 33cdbd88ea..58e2380440 100644 --- a/library/global.ml +++ b/library/global.ml @@ -95,6 +95,7 @@ let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) let add_constant ?role ~in_section id d = globalize (Safe_typing.add_constant ?role ~in_section (i2l id) d) +let add_recipe ~in_section id d = globalize (Safe_typing.add_recipe ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) diff --git a/library/global.mli b/library/global.mli index eabae89d8d..984d8c666c 100644 --- a/library/global.mli +++ b/library/global.mli @@ -47,6 +47,7 @@ val export_private_constants : in_section:bool -> val add_constant : ?role:Entries.side_effect_role -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * Safe_typing.private_constants +val add_recipe : in_section:bool -> Id.t -> Cooking.recipe -> Constant.t val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t -- cgit v1.2.3 From e69e4f7fd9aaba0e3fd6c38624e3fdb0bd96026c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 17 May 2019 14:18:25 +0200 Subject: Do not perform the section variable check on global recipes. By construction, we know that Cooking is returning the right set of used variables. This set has been checked already once at the time when the definition was performed inside the section. --- kernel/opaqueproof.ml | 9 --------- kernel/opaqueproof.mli | 2 -- kernel/term_typing.ml | 26 ++++++++++++++++++-------- kernel/term_typing.mli | 4 +--- 4 files changed, 19 insertions(+), 22 deletions(-) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 423a416ca4..18c1bcc0f8 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -77,11 +77,6 @@ let subst_opaque sub = function | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque.") -let iter_direct_opaque f = function - | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") - | Direct (d,cu) -> - Direct (d,Future.chain cu (fun (c, u) -> f c; c, u)) - let discharge_direct_opaque ~cook_constr ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> @@ -100,10 +95,6 @@ let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function let fp = snd (Int.Map.find i prfs) in join except fp -let force_direct = function -| Direct (_, cu) -> Future.force cu -| Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") - let force_proof { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> fst(Future.force cu) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 8b6e8a1c8f..4e8956af06 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -39,12 +39,10 @@ val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab indirect opaque accessor configured below. *) val force_proof : opaquetab -> opaque -> constr val force_constraints : opaquetab -> opaque -> Univ.ContextSet.t -val force_direct : opaque -> (constr * Univ.ContextSet.t) val get_constraints : opaquetab -> opaque -> Univ.ContextSet.t Future.computation option val subst_opaque : substitution -> opaque -> opaque -val iter_direct_opaque : (constr -> unit) -> opaque -> opaque type work_list = (Univ.Instance.t * Id.t array) Cmap.t * (Univ.Instance.t * Id.t array) Mindmap.t diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 9e33b431fc..74c6189a65 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -232,7 +232,7 @@ let record_aux env s_ty s_bo = (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" v -let build_constant_declaration ~force ~iter env result = +let build_constant_declaration env result = let open Cooking in let typ = result.cook_type in let check declared inferred = @@ -271,7 +271,7 @@ let build_constant_declaration ~force ~iter env result = | Undef _ | Primitive _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> - let (lc, _) = force lc in + let (lc, _) = Future.force lc in let vars = global_vars_set env lc in if !Flags.record_aux_file then record_aux env ids_typ vars; vars @@ -293,6 +293,7 @@ let build_constant_declaration ~force ~iter env result = check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) + let iter k cu = Future.chain cu (fun (c, _ as p) -> k c; p) in let kont c = let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in @@ -319,9 +320,7 @@ let build_constant_declaration ~force ~iter env result = (*s Global and local constant declaration. *) let translate_constant mb env _kn ce = - let force cu = Future.force cu in - let iter k cu = Future.chain cu (fun (c, _ as p) -> k c; p) in - build_constant_declaration ~force ~iter env + build_constant_declaration env (infer_declaration ~trust:mb env ce) let translate_local_assum env t = @@ -330,9 +329,20 @@ let translate_local_assum env t = j.uj_val, t let translate_recipe ~hcons env _kn r = - let force o = Opaqueproof.force_direct o in - let iter k o = Opaqueproof.iter_direct_opaque k o in - build_constant_declaration ~force ~iter env (Cooking.cook_constant ~hcons r) + let open Cooking in + let result = Cooking.cook_constant ~hcons r in + let univs = result.cook_universes in + let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in + let tps = Option.map Cemitcodes.from_val res in + { const_hyps = Option.get result.cook_context; + const_body = result.cook_body; + const_type = result.cook_type; + const_body_code = tps; + const_universes = univs; + const_private_poly_univs = result.cook_private_univs; + const_relevance = result.cook_relevance; + const_inline_code = result.cook_inline; + const_typing_flags = Environ.typing_flags env } let translate_local_def env _id centry = let open Cooking in diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index a046d26ea9..592a97e132 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -43,6 +43,4 @@ val infer_declaration : trust:'a trust -> env -> 'a constant_entry -> Opaqueproof.proofterm Cooking.result val build_constant_declaration : - force:('a -> constr * 'b) -> - iter:((constr -> unit) -> 'a -> 'a) -> - env -> 'a Cooking.result -> 'a constant_body + env -> Opaqueproof.proofterm Cooking.result -> Opaqueproof.proofterm constant_body -- cgit v1.2.3 From a74c28656a7978c429057b62c34227fe2a6cc432 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Wed, 1 May 2019 19:03:05 +0200 Subject: [Classes] Use prepare_parameter from DeclareDef. This code was originally part of #8811, authored by Gaëtan Gilbert. It seems we are not very consistent on what we do when we use `ParameterEntry`, specially w.r.t. universes but as code cleanup progresses we will have a better view. Co-authored-by: Gaëtan Gilbert --- vernac/classes.ml | 10 +++------- vernac/comAssumption.ml | 5 +++++ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/vernac/classes.ml b/vernac/classes.ml index 05a75ab435..5a7f60584a 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -318,6 +318,7 @@ let instance_hook k info global imps ?hook cst = (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k info global imps ?hook id decl poly sigma term termtype = + (* XXX: Duplication of the declare_constant path *) let kind = IsDefinition Instance in let sigma = let levels = Univ.LSet.union (CVars.universes_of_constr termtype) @@ -339,14 +340,9 @@ let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma = Evd.minimize_universes sigma in - Pretyping.check_evars env (Evd.from_env env) sigma termtype; - let univs = Evd.check_univ_decl ~poly sigma decl in - let termtype = to_constr sigma termtype in + let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma decl termtype in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id - (ParameterEntry - (None,(termtype,univs),None), Decl_kinds.IsAssumption Decl_kinds.Logical) - in + (ParameterEntry entry, Decl_kinds.IsAssumption Decl_kinds.Logical) in Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps (ConstRef cst) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 3406b6276f..27e31f486d 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -173,6 +173,11 @@ let do_assumptions ~pstate ~program_mode kind nl l = uvars, (coe,t,imps)) Univ.LSet.empty l in + (* XXX: Using `DeclareDef.prepare_parameter` here directly is not + possible as we indeed declare several parameters; however, + restrict_universe_context should be called in a centralized place + IMO, thus I think we should adapt `prepare_parameter` to handle + this case too. *) let sigma = Evd.restrict_universe_context sigma uvars in let uctx = Evd.check_univ_decl ~poly:(pi2 kind) sigma udecl in let ubinders = Evd.universe_binders sigma in -- cgit v1.2.3 From b7e4a0dd032889422a0057162c66e39f2d0187a5 Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Mon, 13 May 2019 20:06:06 +0200 Subject: Remove definition-not-visible warning This lets us avoid passing ~ontop to do_definition and co, and after #10050 to even more functions. --- doc/plugin_tutorial/tuto1/src/simple_declare.ml | 6 +++--- plugins/funind/indfun.ml | 2 +- vernac/comAssumption.ml | 21 ++++++++------------- vernac/comAssumption.mli | 9 +++------ vernac/comDefinition.ml | 4 ++-- vernac/comDefinition.mli | 3 +-- vernac/comFixpoint.ml | 4 ++-- vernac/declareDef.ml | 13 +++---------- vernac/declareDef.mli | 6 ++---- vernac/obligations.ml | 10 +++++----- vernac/vernacentries.ml | 14 +++++++------- 11 files changed, 37 insertions(+), 55 deletions(-) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 3c0355c92d..e9b91d5a7e 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,16 +1,16 @@ -let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = +let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false ~opaque ~poly sigma udecl ~types:tyopt ~body in let uctx = Evd.evar_universe_context sigma in let ubinders = Evd.universe_binders sigma in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data + DeclareDef.declare_definition ident k ce ubinders imps ?hook_data let packed_declare_definition ~poly ident value_with_constraints = let body, ctx = value_with_constraints in let sigma = Evd.from_ctx ctx in let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ~ontop:None ident k ~opaque:false sigma udecl body None []) + ignore (edeclare ident k ~opaque:false sigma udecl body None []) (* But this definition cannot be undone by Reset ident *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 6494e90a03..ce7d149ae1 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -414,7 +414,7 @@ let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * V match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition ~ontop:pstate + ComDefinition.do_definition ~program_mode:false fname (Decl_kinds.Global,false,Decl_kinds.Definition) pl diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 27e31f486d..635751bb24 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -43,7 +43,7 @@ let should_axiom_into_instance = function true | Global | Local -> !axiom_into_instance -let declare_assumption ~pstate is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = +let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with @@ -53,11 +53,6 @@ match local with let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in let () = assumption_message ident in - let () = - if not !Flags.quiet && Option.has_some pstate then - Feedback.msg_info Pp.(str"Variable" ++ spc () ++ Id.print ident ++ - strbrk " is not visible from current goals") - in let r = VarRef ident in let () = maybe_declare_manual_implicits true r imps in let env = Global.env () in @@ -101,11 +96,11 @@ let next_uctx = | Polymorphic_entry _ as uctx -> uctx | Monomorphic_entry _ -> empty_uctx -let declare_assumptions ~pstate idl is_coe k (c,uctx) pl imps nl = +let declare_assumptions idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = List.fold_left (fun (refs,status,uctx) id -> let ref',u',status' = - declare_assumption ~pstate is_coe k (c,uctx) pl imps false nl id in + declare_assumption is_coe k (c,uctx) pl imps false nl id in (ref',u')::refs, status' && status, next_uctx uctx) ([],true,uctx) idl in @@ -137,7 +132,7 @@ let process_assumptions_udecls kind l = in udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l -let do_assumptions ~pstate ~program_mode kind nl l = +let do_assumptions ~program_mode kind nl l = let open Context.Named.Declaration in let env = Global.env () in let udecl, l = process_assumptions_udecls kind l in @@ -183,7 +178,7 @@ let do_assumptions ~pstate ~program_mode kind nl l = let ubinders = Evd.universe_binders sigma in pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in - let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in + let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs @@ -231,7 +226,7 @@ let named_of_rel_context l = l ([], []) in ctx -let context ~pstate poly l = +let context poly l = let env = Global.env() in let sigma = Evd.from_env env in let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in @@ -296,12 +291,12 @@ let context ~pstate poly l = let decl = (Discharge, poly, Definitional) in let nstatus = match b with | None -> - pi3 (declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl + pi3 (declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl Declaremods.NoInline (CAst.make id)) | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in - let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in + let _gr = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 7c64317b70..8f37bc0ba4 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -16,8 +16,7 @@ open Decl_kinds (** {6 Parameters/Assumptions} *) val do_assumptions - : pstate:Proof_global.t option - -> program_mode:bool + : program_mode:bool -> locality * polymorphic * assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list @@ -26,8 +25,7 @@ val do_assumptions (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) val declare_assumption - : pstate:Proof_global.t option - -> coercion_flag + : coercion_flag -> assumption_kind -> Constr.types Entries.in_universes_entry -> UnivNames.universe_binders @@ -42,8 +40,7 @@ val declare_assumption (** returns [false] if, for lack of section, it declares an assumption (unless in a module type). *) val context - : pstate:Proof_global.t option - -> Decl_kinds.polymorphic + : Decl_kinds.polymorphic -> local_binder_expr list -> bool diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index d2c986fe5c..4cae4b8a74 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -79,7 +79,7 @@ let check_definition ~program_mode (ce, evd, _, imps) = check_evars_are_solved ~program_mode env evd; ce -let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ctypopt = +let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = interp_definition ~program_mode univdecl bl (pi2 k) red_option c ctypopt in @@ -104,4 +104,4 @@ let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ct let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - ignore(DeclareDef.declare_definition ~ontop ident k ?hook_data ce (Evd.universe_binders evd) imps) + ignore(DeclareDef.declare_definition ident k ?hook_data ce (Evd.universe_binders evd) imps) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 12853d83e0..fa4860b079 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -17,8 +17,7 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : ontop:Proof_global.t option - -> program_mode:bool + : program_mode:bool -> ?hook:Lemmas.declaration_hook -> Id.t -> definition_kind diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 1912646ffd..00f19f545c 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -284,7 +284,7 @@ let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, Fixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; @@ -319,7 +319,7 @@ let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,c let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, CoFixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames; diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 052832244b..bdda3314ca 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -14,12 +14,6 @@ open Entries open Globnames open Impargs -let warn_definition_not_visible = - CWarnings.create ~name:"definition-not-visible" ~category:"implicits" - Pp.(fun ident -> - strbrk "Section definition " ++ - Names.Id.print ident ++ strbrk " is not visible from current goals") - let warn_local_declaration = CWarnings.create ~name:"local-declaration" ~category:"scope" Pp.(fun (id,kind) -> @@ -33,12 +27,11 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = +let declare_definition ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with | Discharge when Lib.sections_are_opened () -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in - let () = if Option.has_some ontop then warn_definition_not_visible ident in VarRef ident | Discharge | Local | Global -> let local = get_locality ident ~kind:"definition" local in @@ -57,9 +50,9 @@ let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = end; gr -let declare_fix ~ontop ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = +let declare_fix ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - declare_definition ~ontop f kind ?hook_data ce pl imps + declare_definition f kind ?hook_data ce pl imps let check_definition_evars ~allow_evars sigma = let env = Global.env () in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 8e4f4bf7fb..c4500d0a6b 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -14,8 +14,7 @@ open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition - : ontop:Proof_global.t option - -> Id.t + : Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> Safe_typing.private_constants Entries.definition_entry @@ -24,8 +23,7 @@ val declare_definition -> GlobRef.t val declare_fix - : ontop:Proof_global.t option - -> ?opaque:bool + : ?opaque:bool -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> definition_kind -> UnivNames.universe_binders diff --git a/vernac/obligations.ml b/vernac/obligations.ml index f768278dd7..46c4422d17 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -454,7 +454,7 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let declare_definition ~ontop prg = +let declare_definition prg = let varsubst = obligation_substitution true prg in let body, typ = subst_prog varsubst prg in let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) @@ -473,7 +473,7 @@ let declare_definition ~ontop prg = let () = progmap_remove prg in let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition ~ontop prg.prg_name + DeclareDef.declare_definition prg.prg_name prg.prg_kind ce ubinders prg.prg_implicits ?hook_data let rec lam_index n t acc = @@ -552,7 +552,7 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let univs = UState.univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 (DeclareDef.declare_fix ~ontop:None ~opaque (local, poly, kind) UnivNames.empty_binders univs) + let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; @@ -759,7 +759,7 @@ let update_obls prg obls rem = else ( match prg'.prg_deps with | [] -> - let kn = declare_definition ~ontop:None prg' in + let kn = declare_definition prg' in progmap_remove prg'; Defined kn | l -> @@ -1110,7 +1110,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); - let cst = declare_definition ~ontop:None prg in + let cst = declare_definition prg in Defined cst) else ( let len = Array.length obls in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e1d134f3a9..918852239a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -605,7 +605,7 @@ let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = | Some r -> let sigma, env = get_current_or_global_context ~pstate in Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~ontop:pstate ~program_mode name + ComDefinition.do_definition ~program_mode name (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; pstate ) @@ -632,7 +632,7 @@ let vernac_exact_proof ~pstate c = if not status then Feedback.feedback Feedback.AddedAxiom; pstate -let vernac_assumption ~atts ~pstate discharge kind l nl = +let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in @@ -642,7 +642,7 @@ let vernac_assumption ~atts ~pstate discharge kind l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions ~pstate ~program_mode:atts.program kind nl l in + let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let is_polymorphic_inductive_cumulativity = @@ -1075,8 +1075,8 @@ let vernac_declare_instance ~atts sup inst pri = Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri -let vernac_context ~pstate ~poly l = - if not (ComAssumption.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~poly l = + if not (ComAssumption.context poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_existing_instance ~section_local insts = let glob = not section_local in @@ -2300,7 +2300,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = unsupported_attributes atts; vernac_require_open_proof ~pstate (vernac_exact_proof c) | VernacAssumption ((discharge,kind),nl,l) -> - with_def_attributes ~atts vernac_assumption ~pstate discharge kind l nl; + with_def_attributes ~atts vernac_assumption discharge kind l nl; pstate | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l; @@ -2383,7 +2383,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = with_def_attributes ~atts vernac_declare_instance sup inst info; pstate | VernacContext sup -> - let () = vernac_context ~pstate ~poly:(only_polymorphism atts) sup in + let () = vernac_context ~poly:(only_polymorphism atts) sup in pstate | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts; -- cgit v1.2.3 From f6751f5e8aae4f37d302f700d2f5f2e9fba73a1e Mon Sep 17 00:00:00 2001 From: Gaëtan Gilbert Date: Tue, 14 May 2019 14:28:43 +0200 Subject: Overlay for definition-not-visible overhaul --- .../10157-SkySkimmer-def-not-visible-generic-warning.sh | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh diff --git a/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh b/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh new file mode 100644 index 0000000000..fcbeb32a58 --- /dev/null +++ b/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10188" ] || [ "$CI_BRANCH" = "def-not-visible-remove-warning" ]; then + + elpi_CI_REF=def-not-visible-generic-warning + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi -- cgit v1.2.3